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