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