pa_bitmatch.ml

   1 (* Bitmatch syntax extension.
   2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *
  18  * $Id$
  19  *)
  20
  21 open Printf
  22
  23 open Camlp4.PreCast
  24 open Syntax
  25 open Ast
  26
  27 open Bitmatch
  28 module P = Bitmatch_persistent
  29
  30 (* If this is true then we emit some debugging code which can
  31  * be useful to tell what is happening during matches.  You
  32  * also need to do 'Bitmatch.debug := true' in your main program.
  33  *
  34  * If this is false then no extra debugging code is emitted.
  35  *)
  36 let debug = false
  37
  38 (* Hashtable storing named persistent patterns. *)
  39 let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
  40
  41 let locfail _loc msg = Loc.raise _loc (Failure msg)
  42
  43 (* Work out if an expression is an integer constant.
  44  *
  45  * Returns [Some i] if so (where i is the integer value), else [None].
  46  *
  47  * Fairly simplistic algorithm: we can only detect simple constant
  48  * expressions such as [k], [k+c], [k-c] etc.
  49  *)
  50 let rec expr_is_constant = function
  51   | <:expr< $int:i$ >> ->               (* Literal integer constant. *)
  52     Some (int_of_string i)
  53   | <:expr< $a$ + $b$ >> ->             (* Addition of constants. *)
  54     (match expr_is_constant a, expr_is_constant b with
  55      | Some a, Some b -> Some (a+b)
  56      | _ -> None)
  57   | <:expr< $a$ - $b$ >> ->             (* Subtraction. *)
  58     (match expr_is_constant a, expr_is_constant b with
  59      | Some a, Some b -> Some (a-b)
  60      | _ -> None)
  61   | <:expr< $a$ * $b$ >> ->             (* Multiplication. *)
  62     (match expr_is_constant a, expr_is_constant b with
  63      | Some a, Some b -> Some (a*b)
  64      | _ -> None)
  65   | <:expr< $a$ / $b$ >> ->             (* Division. *)
  66     (match expr_is_constant a, expr_is_constant b with
  67      | Some a, Some b -> Some (a/b)
  68      | _ -> None)
  69   | <:expr< $a$ lsl $b$ >> ->           (* Shift left. *)
  70     (match expr_is_constant a, expr_is_constant b with
  71      | Some a, Some b -> Some (a lsl b)
  72      | _ -> None)
  73   | <:expr< $a$ lsr $b$ >> ->           (* Shift right. *)
  74     (match expr_is_constant a, expr_is_constant b with
  75      | Some a, Some b -> Some (a lsr b)
  76      | _ -> None)
  77   | _ -> None                           (* Anything else is not constant. *)
  78
  79 (* Generate a fresh, unique symbol each time called. *)
  80 let gensym =
  81   let i = ref 1000 in
  82   fun name ->
  83     incr i; let i = !i in
  84     sprintf "__pabitmatch_%s_%d" name i
  85
  86 (* Deal with the qualifiers which appear for a field of both types. *)
  87 let parse_field _loc field qs =
  88   let fail = locfail _loc in
  89
  90   let endian_set, signed_set, type_set, offset_set, field =
  91     match qs with
  92     | None -> (false, false, false, false, field)
  93     | Some qs ->
  94         List.fold_left (
  95           fun (endian_set, signed_set, type_set, offset_set, field) qual_expr ->
  96             match qual_expr with
  97             | "bigendian", None ->
  98                 if endian_set then
  99                   fail "an endian flag has been set already"
 100                 else (
 101                   let field = P.set_endian field BigEndian in
 102                   (true, signed_set, type_set, offset_set, field)
 103                 )
 104             | "littleendian", None ->
 105                 if endian_set then
 106                   fail "an endian flag has been set already"
 107                 else (
 108                   let field = P.set_endian field LittleEndian in
 109                   (true, signed_set, type_set, offset_set, field)
 110                 )
 111             | "nativeendian", None ->
 112                 if endian_set then
 113                   fail "an endian flag has been set already"
 114                 else (
 115                   let field = P.set_endian field NativeEndian in
 116                   (true, signed_set, type_set, offset_set, field)
 117                 )
 118             | "endian", Some expr ->
 119                 if endian_set then
 120                   fail "an endian flag has been set already"
 121                 else (
 122                   let field = P.set_endian_expr field expr in
 123                   (true, signed_set, type_set, offset_set, field)
 124                 )
 125             | "signed", None ->
 126                 if signed_set then
 127                   fail "a signed flag has been set already"
 128                 else (
 129                   let field = P.set_signed field true in
 130                   (endian_set, true, type_set, offset_set, field)
 131                 )
 132             | "unsigned", None ->
 133                 if signed_set then
 134                   fail "a signed flag has been set already"
 135                 else (
 136                   let field = P.set_signed field false in
 137                   (endian_set, true, type_set, offset_set, field)
 138                 )
 139             | "int", None ->
 140                 if type_set then
 141                   fail "a type flag has been set already"
 142                 else (
 143                   let field = P.set_type_int field in
 144                   (endian_set, signed_set, true, offset_set, field)
 145                 )
 146             | "string", None ->
 147                 if type_set then
 148                   fail "a type flag has been set already"
 149                 else (
 150                   let field = P.set_type_string field in
 151                   (endian_set, signed_set, true, offset_set, field)
 152                 )
 153             | "bitstring", None ->
 154                 if type_set then
 155                   fail "a type flag has been set already"
 156                 else (
 157                   let field = P.set_type_bitstring field in
 158                   (endian_set, signed_set, true, offset_set, field)
 159                 )
 160             | "offset", Some expr ->
 161                 if offset_set then
 162                   fail "an offset has been set already"
 163                 else (
 164                   let field = P.set_offset field expr in
 165                   (endian_set, signed_set, type_set, true, field)
 166                 )
 167             | s, Some _ ->
 168                 fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
 169             | s, None ->
 170                 fail (s ^ ": unknown qualifier, or qualifier should be followed by an expression")
 171         ) (false, false, false, false, field) qs in
 172
 173   (* If type is set to string or bitstring then endianness and
 174    * signedness qualifiers are meaningless and must not be set.
 175    *)
 176   let () =
 177     let t = P.get_type field in
 178     if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
 179       fail "string types and endian or signed qualifiers cannot be mixed" in
 180
 181   (* Default endianness, signedness, type if not set already. *)
 182   let field = if endian_set then field else P.set_endian field BigEndian in
 183   let field = if signed_set then field else P.set_signed field false in
 184   let field = if type_set then field else P.set_type_int field in
 185
 186   field
 187
 188 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
 189 let output_constructor _loc fields =
 190   let fail = locfail _loc in
 191
 192   let loc_fname = Loc.file_name _loc in
 193   let loc_line = string_of_int (Loc.start_line _loc) in
 194   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 195
 196   (* Bitstrings are created like the 'Buffer' module (in fact, using
 197    * the Buffer module), by appending snippets to a growing buffer.
 198    * This is reasonably efficient and avoids a lot of garbage.
 199    *)
 200   let buffer = gensym "buffer" in
 201
 202   (* General exception which is raised inside the constructor functions
 203    * when an int expression is out of range at runtime.
 204    *)
 205   let exn = gensym "exn" in
 206   let exn_used = ref false in
 207
 208   (* Convert each field to a simple bitstring-generating expression. *)
 209   let fields = List.map (
 210     fun field ->
 211       let fexpr = P.get_expr field in
 212       let flen = P.get_length field in
 213       let endian = P.get_endian field in
 214       let signed = P.get_signed field in
 215       let t = P.get_type field in
 216       let _loc = P.get_location field in
 217       let offset = P.get_offset field in
 218
 219       (* offset() not supported in constructors.  Implementation of
 220        * forward-only offsets is fairly straightforward: we would
 221        * need to just calculate the length of padding here and add
 222        * it to what has been constructed.  For general offsets,
 223        * including going backwards, that would require a rethink in
 224        * how we construct bitstrings.
 225        *)
 226       if offset <> None then
 227         fail "offset expressions are not supported in BITSTRING constructors";
 228
 229       (* Is flen an integer constant?  If so, what is it?  This
 230        * is very simple-minded and only detects simple constants.
 231        *)
 232       let flen_is_const = expr_is_constant flen in
 233
 234       (* Choose the right constructor function. *)
 235       let int_construct_const = function
 236           (* XXX The meaning of signed/unsigned breaks down at
 237            * 31, 32, 63 and 64 bits.
 238            *)
 239         | (1, _, _) ->
 240             <:expr<Bitmatch.construct_bit>>
 241         | ((2|3|4|5|6|7|8), _, false) ->
 242             <:expr<Bitmatch.construct_char_unsigned>>
 243         | ((2|3|4|5|6|7|8), _, true) ->
 244             <:expr<Bitmatch.construct_char_signed>>
 245         | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
 246             <:expr<Bitmatch.construct_int_be_unsigned>>
 247         | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
 248             <:expr<Bitmatch.construct_int_be_signed>>
 249         | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
 250             <:expr<Bitmatch.construct_int_le_unsigned>>
 251         | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
 252             <:expr<Bitmatch.construct_int_le_signed>>
 253         | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
 254             <:expr<Bitmatch.construct_int_ne_unsigned>>
 255         | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
 256             <:expr<Bitmatch.construct_int_ne_signed>>
 257         | (i, P.EndianExpr expr, false) when i <= 31 ->
 258             <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
 259         | (i, P.EndianExpr expr, true) when i <= 31 ->
 260             <:expr<Bitmatch.construct_int_ee_signed $expr$>>
 261         | (32, P.ConstantEndian BigEndian, false) ->
 262             <:expr<Bitmatch.construct_int32_be_unsigned>>
 263         | (32, P.ConstantEndian BigEndian, true) ->
 264             <:expr<Bitmatch.construct_int32_be_signed>>
 265         | (32, P.ConstantEndian LittleEndian, false) ->
 266             <:expr<Bitmatch.construct_int32_le_unsigned>>
 267         | (32, P.ConstantEndian LittleEndian, true) ->
 268             <:expr<Bitmatch.construct_int32_le_signed>>
 269         | (32, P.ConstantEndian NativeEndian, false) ->
 270             <:expr<Bitmatch.construct_int32_ne_unsigned>>
 271         | (32, P.ConstantEndian NativeEndian, true) ->
 272             <:expr<Bitmatch.construct_int32_ne_signed>>
 273         | (32, P.EndianExpr expr, false) ->
 274             <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
 275         | (32, P.EndianExpr expr, true) ->
 276             <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
 277         | (_, P.ConstantEndian BigEndian, false) ->
 278             <:expr<Bitmatch.construct_int64_be_unsigned>>
 279         | (_, P.ConstantEndian BigEndian, true) ->
 280             <:expr<Bitmatch.construct_int64_be_signed>>
 281         | (_, P.ConstantEndian LittleEndian, false) ->
 282             <:expr<Bitmatch.construct_int64_le_unsigned>>
 283         | (_, P.ConstantEndian LittleEndian, true) ->
 284             <:expr<Bitmatch.construct_int64_le_signed>>
 285         | (_, P.ConstantEndian NativeEndian, false) ->
 286             <:expr<Bitmatch.construct_int64_ne_unsigned>>
 287         | (_, P.ConstantEndian NativeEndian, true) ->
 288             <:expr<Bitmatch.construct_int64_ne_signed>>
 289         | (_, P.EndianExpr expr, false) ->
 290             <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
 291         | (_, P.EndianExpr expr, true) ->
 292             <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
 293       in
 294       let int_construct = function
 295         | (P.ConstantEndian BigEndian, false) ->
 296             <:expr<Bitmatch.construct_int64_be_unsigned>>
 297         | (P.ConstantEndian BigEndian, true) ->
 298             <:expr<Bitmatch.construct_int64_be_signed>>
 299         | (P.ConstantEndian LittleEndian, false) ->
 300             <:expr<Bitmatch.construct_int64_le_unsigned>>
 301         | (P.ConstantEndian LittleEndian, true) ->
 302             <:expr<Bitmatch.construct_int64_le_signed>>
 303         | (P.ConstantEndian NativeEndian, false) ->
 304             <:expr<Bitmatch.construct_int64_ne_unsigned>>
 305         | (P.ConstantEndian NativeEndian, true) ->
 306             <:expr<Bitmatch.construct_int64_ne_signed>>
 307         | (P.EndianExpr expr, false) ->
 308             <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
 309         | (P.EndianExpr expr, true) ->
 310             <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
 311       in
 312
 313       let expr =
 314         match t, flen_is_const with
 315         (* Common case: int field, constant flen.
 316          *
 317          * Range checks are done inside the construction function
 318          * because that's a lot simpler w.r.t. types.  It might
 319          * be better to move them here. XXX
 320          *)
 321         | P.Int, Some i when i > 0 && i <= 64 ->
 322             let construct_fn = int_construct_const (i,endian,signed) in
 323             exn_used := true;
 324
 325             <:expr<
 326               $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
 327             >>
 328
 329         | P.Int, Some _ ->
 330             fail "length of int field must be [1..64]"
 331
 332         (* Int field, non-constant length.  We need to perform a runtime
 333          * test to ensure the length is [1..64].
 334          *
 335          * Range checks are done inside the construction function
 336          * because that's a lot simpler w.r.t. types.  It might
 337          * be better to move them here. XXX
 338          *)
 339         | P.Int, None ->
 340             let construct_fn = int_construct (endian,signed) in
 341             exn_used := true;
 342
 343             <:expr<
 344               if $flen$ >= 1 && $flen$ <= 64 then
 345                 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
 346               else
 347                 raise (Bitmatch.Construct_failure
 348                          ("length of int field must be [1..64]",
 349                           $str:loc_fname$,
 350                           $int:loc_line$, $int:loc_char$))
 351             >>
 352
 353         (* String, constant length > 0, must be a multiple of 8. *)
 354         | P.String, Some i when i > 0 && i land 7 = 0 ->
 355             let bs = gensym "bs" in
 356             let j = i lsr 3 in
 357             <:expr<
 358               let $lid:bs$ = $fexpr$ in
 359               if String.length $lid:bs$ = $`int:j$ then
 360                 Bitmatch.construct_string $lid:buffer$ $lid:bs$
 361               else
 362                 raise (Bitmatch.Construct_failure
 363                          ("length of string does not match declaration",
 364                           $str:loc_fname$,
 365                           $int:loc_line$, $int:loc_char$))
 366             >>
 367
 368         (* String, constant length -1, means variable length string
 369          * with no checks.
 370          *)
 371         | P.String, Some (-1) ->
 372             <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
 373
 374         (* String, constant length = 0 is probably an error, and so is
 375          * any other value.
 376          *)
 377         | P.String, Some _ ->
 378             fail "length of string must be > 0 and a multiple of 8, or the special value -1"
 379
 380         (* String, non-constant length.
 381          * We check at runtime that the length is > 0, a multiple of 8,
 382          * and matches the declared length.
 383          *)
 384         | P.String, None ->
 385             let bslen = gensym "bslen" in
 386             let bs = gensym "bs" in
 387             <:expr<
 388               let $lid:bslen$ = $flen$ in
 389               if $lid:bslen$ > 0 then (
 390                 if $lid:bslen$ land 7 = 0 then (
 391                   let $lid:bs$ = $fexpr$ in
 392                   if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
 393                     Bitmatch.construct_string $lid:buffer$ $lid:bs$
 394                   else
 395                     raise (Bitmatch.Construct_failure
 396                              ("length of string does not match declaration",
 397                               $str:loc_fname$,
 398                               $int:loc_line$, $int:loc_char$))
 399                 ) else
 400                   raise (Bitmatch.Construct_failure
 401                            ("length of string must be a multiple of 8",
 402                             $str:loc_fname$,
 403                             $int:loc_line$, $int:loc_char$))
 404               ) else
 405                 raise (Bitmatch.Construct_failure
 406                          ("length of string must be > 0",
 407                           $str:loc_fname$,
 408                           $int:loc_line$, $int:loc_char$))
 409             >>
 410
 411         (* Bitstring, constant length >= 0. *)
 412         | P.Bitstring, Some i when i >= 0 ->
 413             let bs = gensym "bs" in
 414             <:expr<
 415               let $lid:bs$ = $fexpr$ in
 416               if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
 417                 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
 418               else
 419                 raise (Bitmatch.Construct_failure
 420                          ("length of bitstring does not match declaration",
 421                           $str:loc_fname$,
 422                           $int:loc_line$, $int:loc_char$))
 423             >>
 424
 425         (* Bitstring, constant length -1, means variable length bitstring
 426          * with no checks.
 427          *)
 428         | P.Bitstring, Some (-1) ->
 429             <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
 430
 431         (* Bitstring, constant length < -1 is an error. *)
 432         | P.Bitstring, Some _ ->
 433             fail "length of bitstring must be >= 0 or the special value -1"
 434
 435         (* Bitstring, non-constant length.
 436          * We check at runtime that the length is >= 0 and matches
 437          * the declared length.
 438          *)
 439         | P.Bitstring, None ->
 440             let bslen = gensym "bslen" in
 441             let bs = gensym "bs" in
 442             <:expr<
 443               let $lid:bslen$ = $flen$ in
 444               if $lid:bslen$ >= 0 then (
 445                 let $lid:bs$ = $fexpr$ in
 446                 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
 447                   Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
 448                 else
 449                   raise (Bitmatch.Construct_failure
 450                            ("length of bitstring does not match declaration",
 451                             $str:loc_fname$,
 452                             $int:loc_line$, $int:loc_char$))
 453               ) else
 454                 raise (Bitmatch.Construct_failure
 455                          ("length of bitstring must be > 0",
 456                           $str:loc_fname$,
 457                           $int:loc_line$, $int:loc_char$))
 458             >> in
 459       expr
 460   ) fields in
 461
 462   (* Create the final bitstring.  Start by creating an empty buffer
 463    * and then evaluate each expression above in turn which will
 464    * append some more to the bitstring buffer.  Finally extract
 465    * the bitstring.
 466    *
 467    * XXX We almost have enough information to be able to guess
 468    * a good initial size for the buffer.
 469    *)
 470   let fields =
 471     match fields with
 472     | [] -> <:expr< [] >>
 473     | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
 474
 475   let expr =
 476     <:expr<
 477       let $lid:buffer$ = Bitmatch.Buffer.create () in
 478       $fields$;
 479       Bitmatch.Buffer.contents $lid:buffer$
 480     >> in
 481
 482   if !exn_used then
 483     <:expr<
 484       let $lid:exn$ =
 485         Bitmatch.Construct_failure ("value out of range",
 486                                     $str:loc_fname$,
 487                                     $int:loc_line$, $int:loc_char$) in
 488         $expr$
 489     >>
 490   else
 491     expr
 492
 493 (* Generate the code for a bitmatch statement.  '_loc' is the
 494  * location, 'bs' is the bitstring parameter, 'cases' are
 495  * the list of cases to test against.
 496  *)
 497 let output_bitmatch _loc bs cases =
 498   let fail = locfail _loc in
 499
 500   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
 501   let result = gensym "result" in
 502
 503   (* This generates the field extraction code for each
 504    * field in a single case.  There must be enough remaining data
 505    * in the bitstring to satisfy the field.
 506    *
 507    * As we go through the fields, symbols 'data', 'off' and 'len'
 508    * track our position and remaining length in the bitstring.
 509    *
 510    * The whole thing is a lot of nested 'if' statements. Code
 511    * is generated from the inner-most (last) field outwards.
 512    *)
 513   let rec output_field_extraction inner = function
 514     | [] -> inner
 515     | field :: fields ->
 516         let fpatt = P.get_patt field in
 517         let flen = P.get_length field in
 518         let endian = P.get_endian field in
 519         let signed = P.get_signed field in
 520         let t = P.get_type field in
 521         let _loc = P.get_location field in
 522         let offset = P.get_offset field in
 523
 524         (* Is flen (field len) an integer constant?  If so, what is it?
 525          * This will be [Some i] if it's a constant or [None] if it's
 526          * non-constant or we couldn't determine.
 527          *)
 528         let flen_is_const = expr_is_constant flen in
 529
 530         let int_extract_const = function
 531             (* XXX The meaning of signed/unsigned breaks down at
 532              * 31, 32, 63 and 64 bits.
 533              *)
 534           | (1, _, _) ->
 535               <:expr<Bitmatch.extract_bit>>
 536           | ((2|3|4|5|6|7|8), _, false) ->
 537               <:expr<Bitmatch.extract_char_unsigned>>
 538           | ((2|3|4|5|6|7|8), _, true) ->
 539               <:expr<Bitmatch.extract_char_signed>>
 540           | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
 541               <:expr<Bitmatch.extract_int_be_unsigned>>
 542           | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
 543               <:expr<Bitmatch.extract_int_be_signed>>
 544           | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
 545               <:expr<Bitmatch.extract_int_le_unsigned>>
 546           | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
 547               <:expr<Bitmatch.extract_int_le_signed>>
 548           | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
 549               <:expr<Bitmatch.extract_int_ne_unsigned>>
 550           | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
 551               <:expr<Bitmatch.extract_int_ne_signed>>
 552           | (i, P.EndianExpr expr, false) when i <= 31 ->
 553               <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
 554           | (i, P.EndianExpr expr, true) when i <= 31 ->
 555               <:expr<Bitmatch.extract_int_ee_signed $expr$>>
 556           | (32, P.ConstantEndian BigEndian, false) ->
 557               <:expr<Bitmatch.extract_int32_be_unsigned>>
 558           | (32, P.ConstantEndian BigEndian, true) ->
 559               <:expr<Bitmatch.extract_int32_be_signed>>
 560           | (32, P.ConstantEndian LittleEndian, false) ->
 561               <:expr<Bitmatch.extract_int32_le_unsigned>>
 562           | (32, P.ConstantEndian LittleEndian, true) ->
 563               <:expr<Bitmatch.extract_int32_le_signed>>
 564           | (32, P.ConstantEndian NativeEndian, false) ->
 565               <:expr<Bitmatch.extract_int32_ne_unsigned>>
 566           | (32, P.ConstantEndian NativeEndian, true) ->
 567               <:expr<Bitmatch.extract_int32_ne_signed>>
 568           | (32, P.EndianExpr expr, false) ->
 569               <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
 570           | (32, P.EndianExpr expr, true) ->
 571               <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
 572           | (_, P.ConstantEndian BigEndian, false) ->
 573               <:expr<Bitmatch.extract_int64_be_unsigned>>
 574           | (_, P.ConstantEndian BigEndian, true) ->
 575               <:expr<Bitmatch.extract_int64_be_signed>>
 576           | (_, P.ConstantEndian LittleEndian, false) ->
 577               <:expr<Bitmatch.extract_int64_le_unsigned>>
 578           | (_, P.ConstantEndian LittleEndian, true) ->
 579               <:expr<Bitmatch.extract_int64_le_signed>>
 580           | (_, P.ConstantEndian NativeEndian, false) ->
 581               <:expr<Bitmatch.extract_int64_ne_unsigned>>
 582           | (_, P.ConstantEndian NativeEndian, true) ->
 583               <:expr<Bitmatch.extract_int64_ne_signed>>
 584           | (_, P.EndianExpr expr, false) ->
 585               <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
 586           | (_, P.EndianExpr expr, true) ->
 587               <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
 588         in
 589         let int_extract = function
 590           | (P.ConstantEndian BigEndian, false) ->
 591               <:expr<Bitmatch.extract_int64_be_unsigned>>
 592           | (P.ConstantEndian BigEndian, true) ->
 593               <:expr<Bitmatch.extract_int64_be_signed>>
 594           | (P.ConstantEndian LittleEndian, false) ->
 595               <:expr<Bitmatch.extract_int64_le_unsigned>>
 596           | (P.ConstantEndian LittleEndian, true) ->
 597               <:expr<Bitmatch.extract_int64_le_signed>>
 598           | (P.ConstantEndian NativeEndian, false) ->
 599               <:expr<Bitmatch.extract_int64_ne_unsigned>>
 600           | (P.ConstantEndian NativeEndian, true) ->
 601               <:expr<Bitmatch.extract_int64_ne_signed>>
 602           | (P.EndianExpr expr, false) ->
 603               <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
 604           | (P.EndianExpr expr, true) ->
 605               <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
 606         in
 607
 608         let expr =
 609           match t, flen_is_const with
 610           (* Common case: int field, constant flen *)
 611           | P.Int, Some i when i > 0 && i <= 64 ->
 612               let extract_fn = int_extract_const (i,endian,signed) in
 613               let v = gensym "val" in
 614               <:expr<
 615                 if $lid:len$ >= $`int:i$ then (
 616                   let $lid:v$, $lid:off$, $lid:len$ =
 617                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
 618                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 619                 )
 620               >>
 621
 622           | P.Int, Some _ ->
 623               fail "length of int field must be [1..64]"
 624
 625           (* Int field, non-const flen.  We have to test the range of
 626            * the field at runtime.  If outside the range it's a no-match
 627            * (not an error).
 628            *)
 629           | P.Int, None ->
 630               let extract_fn = int_extract (endian,signed) in
 631               let v = gensym "val" in
 632               <:expr<
 633                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
 634                   let $lid:v$, $lid:off$, $lid:len$ =
 635                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
 636                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 637                 )
 638               >>
 639
 640           (* String, constant flen > 0. *)
 641           | P.String, Some i when i > 0 && i land 7 = 0 ->
 642               let bs = gensym "bs" in
 643               <:expr<
 644                 if $lid:len$ >= $`int:i$ then (
 645                   let $lid:bs$, $lid:off$, $lid:len$ =
 646                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 647                       $`int:i$ in
 648                   match Bitmatch.string_of_bitstring $lid:bs$ with
 649                   | $fpatt$ when true -> $inner$
 650                   | _ -> ()
 651                 )
 652               >>
 653
 654           (* String, constant flen = -1, means consume all the
 655            * rest of the input.
 656            *)
 657           | P.String, Some i when i = -1 ->
 658               let bs = gensym "bs" in
 659               <:expr<
 660                 let $lid:bs$, $lid:off$, $lid:len$ =
 661                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 662                 match Bitmatch.string_of_bitstring $lid:bs$ with
 663                 | $fpatt$ when true -> $inner$
 664                 | _ -> ()
 665               >>
 666
 667           | P.String, Some _ ->
 668               fail "length of string must be > 0 and a multiple of 8, or the special value -1"
 669
 670           (* String field, non-const flen.  We check the flen is > 0
 671            * and a multiple of 8 (-1 is not allowed here), at runtime.
 672            *)
 673           | P.String, None ->
 674               let bs = gensym "bs" in
 675               <:expr<
 676                 if $flen$ >= 0 && $flen$ <= $lid:len$
 677                   && $flen$ land 7 = 0 then (
 678                     let $lid:bs$, $lid:off$, $lid:len$ =
 679                       Bitmatch.extract_bitstring
 680                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
 681                     match Bitmatch.string_of_bitstring $lid:bs$ with
 682                     | $fpatt$ when true -> $inner$
 683                     | _ -> ()
 684                   )
 685               >>
 686
 687           (* Bitstring, constant flen >= 0.
 688            * At the moment all we can do is assign the bitstring to an
 689            * identifier.
 690            *)
 691           | P.Bitstring, Some i when i >= 0 ->
 692               let ident =
 693                 match fpatt with
 694                 | <:patt< $lid:ident$ >> -> ident
 695                 | <:patt< _ >> -> "_"
 696                 | _ ->
 697                     fail "cannot compare a bitstring to a constant" in
 698               <:expr<
 699                 if $lid:len$ >= $`int:i$ then (
 700                   let $lid:ident$, $lid:off$, $lid:len$ =
 701                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 702                       $`int:i$ in
 703                   $inner$
 704                 )
 705               >>
 706
 707           (* Bitstring, constant flen = -1, means consume all the
 708            * rest of the input.
 709            *)
 710           | P.Bitstring, Some i when i = -1 ->
 711               let ident =
 712                 match fpatt with
 713                 | <:patt< $lid:ident$ >> -> ident
 714                 | <:patt< _ >> -> "_"
 715                 | _ ->
 716                     fail "cannot compare a bitstring to a constant" in
 717               <:expr<
 718                 let $lid:ident$, $lid:off$, $lid:len$ =
 719                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 720                   $inner$
 721               >>
 722
 723           | P.Bitstring, Some _ ->
 724               fail "length of bitstring must be >= 0 or the special value -1"
 725
 726           (* Bitstring field, non-const flen.  We check the flen is >= 0
 727            * (-1 is not allowed here) at runtime.
 728            *)
 729           | P.Bitstring, None ->
 730               let ident =
 731                 match fpatt with
 732                 | <:patt< $lid:ident$ >> -> ident
 733                 | <:patt< _ >> -> "_"
 734                 | _ ->
 735                     fail "cannot compare a bitstring to a constant" in
 736               <:expr<
 737                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
 738                   let $lid:ident$, $lid:off$, $lid:len$ =
 739                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 740                       $flen$ in
 741                   $inner$
 742                 )
 743               >>
 744         in
 745
 746         (* Computed offset: only offsets forward are supported.
 747          *
 748          * We try hard to optimize this based on what we know.  Are
 749          * we at a predictable offset now?  (Look at the outer 'fields'
 750          * list and see if they all have constant field length starting
 751          * at some constant offset).  Is this offset constant?
 752          *
 753          * Based on this we can do a lot of the computation at
 754          * compile time, or defer it to runtime only if necessary.
 755          *
 756          * In all cases, the off and len fields get updated.
 757          *)
 758         let expr =
 759           match offset with
 760           | None -> expr (* common case: there was no offset expression *)
 761           | Some offset_expr ->
 762               (* This will be [Some i] if offset is a constant expression
 763                * or [None] if it's a non-constant.
 764                *)
 765               let requested_offset = expr_is_constant offset_expr in
 766
 767               (* This will be [Some i] if our current offset is known
 768                * at compile time, or [None] if we can't determine it.
 769                *)
 770               let current_offset =
 771                 let has_constant_offset field =
 772                   match P.get_offset field with
 773                   | None -> false
 774                   | Some expr ->
 775                       match expr_is_constant expr with
 776                       | None -> false
 777                       | Some i -> true
 778                 in
 779                 let get_constant_offset field =
 780                   match P.get_offset field with
 781                   | None -> assert false
 782                   | Some expr ->
 783                       match expr_is_constant expr with
 784                       | None -> assert false
 785                       | Some i -> i
 786                 in
 787
 788                 let has_constant_len field =
 789                   match expr_is_constant (P.get_length field) with
 790                   | None -> false
 791                   | Some i when i > 0 -> true
 792                   | Some _ -> false
 793                 in
 794                 let get_constant_len field =
 795                   match expr_is_constant (P.get_length field) with
 796                   | None -> assert false
 797                   | Some i when i > 0 -> i
 798                   | Some _ -> assert false
 799                 in
 800
 801                 let rec loop = function
 802                   (* first field has constant offset 0 *)
 803                   | [] -> Some 0
 804                   (* field with constant offset & length *)
 805                   | field :: _
 806                       when has_constant_offset field &&
 807                         has_constant_len field ->
 808                       Some (get_constant_offset field + get_constant_len field)
 809                   (* field with no offset & constant length *)
 810                   | field :: fields
 811                       when P.get_offset field = None &&
 812                         has_constant_len field ->
 813                       (match loop fields with
 814                        | None -> None
 815                        | Some offset -> Some (offset + get_constant_len field))
 816                   (* else, can't work out the offset *)
 817                   | _ -> None
 818                 in
 819                 loop fields in
 820
 821               (* Look at the current offset and requested offset cases and
 822                * determine what code to generate.
 823                *)
 824               match current_offset, requested_offset with
 825                 (* This is the good case: both the current offset and
 826                  * the requested offset are constant, so we can remove
 827                  * almost all the runtime checks.
 828                  *)
 829               | Some current_offset, Some requested_offset ->
 830                   let move = requested_offset - current_offset in
 831                   if move < 0 then
 832                     fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
 833                   (* Add some code to move the offset and length by a
 834                    * constant amount, and a runtime test that len >= 0
 835                    * (XXX possibly the runtime test is unnecessary?)
 836                    *)
 837                   <:expr<
 838                     let $lid:off$ = $lid:off$ + $`int:move$ in
 839                     let $lid:len$ = $lid:len$ - $`int:move$ in
 840                     if $lid:len$ >= 0 then $expr$
 841                   >>
 842               (* In any other case, we need to use runtime checks.
 843                *
 844                * XXX It's not clear if a backwards move detected at runtime
 845                * is merely a match failure, or a runtime error.  At the
 846                * moment it's just a match failure since bitmatch generally
 847                * doesn't raise runtime errors.
 848                *)
 849               | _ ->
 850                   let move = gensym "move" in
 851                   <:expr<
 852                     let $lid:move$ = $offset_expr$ - $lid:off$ in
 853                     if $lid:move$ >= 0 then (
 854                       let $lid:off$ = $lid:off$ + $lid:move$ in
 855                       let $lid:len$ = $lid:len$ - $lid:move$ in
 856                       if $lid:len$ >= 0 then $expr$
 857                     )
 858                   >> in (* end of computed offset code *)
 859
 860         (* Emit extra debugging code. *)
 861         let expr =
 862           if not debug then expr else (
 863             let field = P.string_of_pattern_field field in
 864
 865             <:expr<
 866               if !Bitmatch.debug then (
 867                 Printf.eprintf "PA_BITMATCH: TEST:\n";
 868                 Printf.eprintf "  %s\n" $str:field$;
 869                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
 870                 (*Bitmatch.hexdump_bitstring stderr
 871                   ($lid:data$,$lid:off$,$lid:len$);*)
 872               );
 873               $expr$
 874             >>
 875           ) in
 876
 877         output_field_extraction expr fields
 878   in
 879
 880   (* Convert each case in the match. *)
 881   let cases = List.map (
 882     fun (fields, bind, whenclause, code) ->
 883       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
 884       let inner =
 885         match whenclause with
 886         | Some whenclause ->
 887             <:expr< if $whenclause$ then $inner$ >>
 888         | None -> inner in
 889       let inner =
 890         match bind with
 891         | Some name ->
 892             <:expr<
 893               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
 894               $inner$
 895               >>
 896         | None -> inner in
 897       output_field_extraction inner (List.rev fields)
 898   ) cases in
 899
 900   (* Join them into a single expression.
 901    *
 902    * Don't do it with a normal fold_right because that leaves
 903    * 'raise Exit; ()' at the end which causes a compiler warning.
 904    * Hence a bit of complexity here.
 905    *
 906    * Note that the number of cases is always >= 1 so List.hd is safe.
 907    *)
 908   let cases = List.rev cases in
 909   let cases =
 910     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
 911       (List.hd cases) (List.tl cases) in
 912
 913   (* The final code just wraps the list of cases in a
 914    * try/with construct so that each case is tried in
 915    * turn until one case matches (that case sets 'result'
 916    * and raises 'Exit' to leave the whole statement).
 917    * If result isn't set by the end then we will raise
 918    * Match_failure with the location of the bitmatch
 919    * statement in the original code.
 920    *)
 921   let loc_fname = Loc.file_name _loc in
 922   let loc_line = string_of_int (Loc.start_line _loc) in
 923   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 924
 925   <:expr<
 926     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
 927     let $lid:result$ = ref None in
 928     (try
 929       $cases$
 930     with Exit -> ());
 931     match ! $lid:result$ with
 932     | Some x -> x
 933     | None -> raise (Match_failure ($str:loc_fname$,
 934                                     $int:loc_line$, $int:loc_char$))
 935   >>
 936
 937 (* Add a named pattern. *)
 938 let add_named_pattern _loc name pattern =
 939   Hashtbl.add pattern_hash name pattern
 940
 941 (* Expand a named pattern from the pattern_hash. *)
 942 let expand_named_pattern _loc name =
 943   try Hashtbl.find pattern_hash name
 944   with Not_found ->
 945     locfail _loc (sprintf "named pattern not found: %s" name)
 946
 947 (* Add named patterns from a file.  See the documentation on the
 948  * directory search path in bitmatch_persistent.mli
 949  *)
 950 let load_patterns_from_file _loc filename =
 951   let chan =
 952     if Filename.is_relative filename && Filename.is_implicit filename then (
 953       (* Try current directory. *)
 954       try open_in filename
 955       with _ ->
 956         (* Try OCaml library directory. *)
 957         try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
 958         with exn -> Loc.raise _loc exn
 959     ) else (
 960       try open_in filename
 961       with exn -> Loc.raise _loc exn
 962     ) in
 963   let names = ref [] in
 964   (try
 965      let rec loop () =
 966        let name = P.named_from_channel chan in
 967        names := name :: !names
 968      in
 969      loop ()
 970    with End_of_file -> ()
 971   );
 972   close_in chan;
 973   let names = List.rev !names in
 974   List.iter (
 975     function
 976     | name, P.Pattern patt -> add_named_pattern _loc name patt
 977     | _, P.Constructor _ -> () (* just ignore these for now *)
 978   ) names
 979
 980 EXTEND Gram
 981   GLOBAL: expr str_item;
 982
 983   (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
 984    * followed by an optional expression (used in certain cases).  Note
 985    * that we are careful not to declare any explicit reserved words.
 986    *)
 987   qualifiers: [
 988     [ LIST0
 989         [ q = LIDENT;
 990           e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
 991         SEP "," ]
 992   ];
 993
 994   (* Field used in the bitmatch operator (a pattern).  This can actually
 995    * return multiple fields, in the case where the 'field' is a named
 996    * persitent pattern.
 997    *)
 998   patt_field: [
 999     [ fpatt = patt; ":"; len = expr LEVEL "top";
1000       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
1001         let field = P.create_pattern_field _loc in
1002         let field = P.set_patt field fpatt in
1003         let field = P.set_length field len in
1004         [parse_field _loc field qs]     (* Normal, single field. *)
1005     | ":"; name = LIDENT ->
1006         expand_named_pattern _loc name (* Named -> list of fields. *)
1007     ]
1008   ];
1009
1010   (* Case inside bitmatch operator. *)
1011   patt_fields: [
1012     [ "{";
1013       fields = LIST0 patt_field SEP ";";
1014       "}" ->
1015         List.concat fields
1016     ]
1017   ];
1018
1019   patt_case: [
1020     [ fields = patt_fields;
1021       bind = OPT [ "as"; name = LIDENT -> name ];
1022       whenclause = OPT [ "when"; e = expr -> e ]; "->";
1023       code = expr ->
1024         (fields, bind, whenclause, code)
1025     ]
1026   ];
1027
1028   (* Field used in the BITSTRING constructor (an expression). *)
1029   constr_field: [
1030     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
1031       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
1032         let field = P.create_constructor_field _loc in
1033         let field = P.set_expr field fexpr in
1034         let field = P.set_length field len in
1035         parse_field _loc field qs
1036     ]
1037   ];
1038
1039   constr_fields: [
1040     [ "{";
1041       fields = LIST0 constr_field SEP ";";
1042       "}" ->
1043         fields
1044     ]
1045   ];
1046
1047   (* 'bitmatch' expressions. *)
1048   expr: LEVEL ";" [
1049     [ "bitmatch";
1050       bs = expr; "with"; OPT "|";
1051       cases = LIST1 patt_case SEP "|" ->
1052         output_bitmatch _loc bs cases
1053     ]
1054
1055   (* Constructor. *)
1056   | [ "BITSTRING";
1057       fields = constr_fields ->
1058         output_constructor _loc fields
1059     ]
1060   ];
1061
1062   (* Named persistent patterns.
1063    *
1064    * NB: Currently only allowed at the top level.  We can probably lift
1065    * this restriction later if necessary.  We only deal with patterns
1066    * at the moment, not constructors, but the infrastructure to do
1067    * constructors is in place.
1068    *)
1069   str_item: LEVEL "top" [
1070     [ "let"; "bitmatch";
1071       name = LIDENT; "="; fields = patt_fields ->
1072         add_named_pattern _loc name fields;
1073         (* The statement disappears, but we still need a str_item so ... *)
1074         <:str_item< >>
1075     | "open"; "bitmatch"; filename = STRING ->
1076         load_patterns_from_file _loc filename;
1077         <:str_item< >>
1078     ]
1079   ];
1080
1081 END