pa_bitstring.ml

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