pa_bitmatch.ml

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