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: pa_bitmatch.ml,v 1.11 2008-04-25 14:57:11 rjones Exp $
  19  *)
  20
  21 open Printf
  22
  23 open Camlp4.PreCast
  24 open Syntax
  25 open Ast
  26
  27 (* If this is true then we emit some debugging code which can
  28  * be useful to tell what is happening during matches.  You
  29  * also need to do 'Bitmatch.debug := true' in your main program.
  30  *
  31  * If this is false then no extra debugging code is emitted.
  32  *)
  33 let debug = false
  34
  35 (* Work out if an expression is an integer constant.
  36  *
  37  * Returns [Some i] if so (where i is the integer value), else [None].
  38  *
  39  * Fairly simplistic algorithm: we can only detect simple constant
  40  * expressions such as [k], [k+c], [k-c] etc.
  41  *)
  42 let rec expr_is_constant = function
  43   | <:expr< $int:i$ >> ->               (* Literal integer constant. *)
  44     Some (int_of_string i)
  45   | <:expr< $a$ + $b$ >> ->             (* Addition of constants. *)
  46     (match expr_is_constant a, expr_is_constant b with
  47      | Some a, Some b -> Some (a+b)
  48      | _ -> None)
  49   | <:expr< $a$ - $b$ >> ->             (* Subtraction. *)
  50     (match expr_is_constant a, expr_is_constant b with
  51      | Some a, Some b -> Some (a-b)
  52      | _ -> None)
  53   | <:expr< $a$ * $b$ >> ->             (* Multiplication. *)
  54     (match expr_is_constant a, expr_is_constant b with
  55      | Some a, Some b -> Some (a*b)
  56      | _ -> None)
  57   | <:expr< $a$ / $b$ >> ->             (* Division. *)
  58     (match expr_is_constant a, expr_is_constant b with
  59      | Some a, Some b -> Some (a/b)
  60      | _ -> None)
  61   | <:expr< $a$ lsl $b$ >> ->           (* Shift left. *)
  62     (match expr_is_constant a, expr_is_constant b with
  63      | Some a, Some b -> Some (a lsl b)
  64      | _ -> None)
  65   | <:expr< $a$ lsr $b$ >> ->           (* Shift right. *)
  66     (match expr_is_constant a, expr_is_constant b with
  67      | Some a, Some b -> Some (a lsr b)
  68      | _ -> None)
  69   | _ -> None                           (* Anything else is not constant. *)
  70
  71 (* A field when used in a bitmatch (a pattern). *)
  72 type fpatt = {
  73   fpatt : patt;                         (* field matching pattern *)
  74   fpc : fcommon;
  75 }
  76 (* A field when used in a BITSTRING constructor (an expression). *)
  77 and fexpr = {
  78   fexpr : expr;                         (* field value *)
  79   fec : fcommon;
  80 }
  81
  82 and fcommon = {
  83   flen : expr;                          (* length in bits, may be non-const *)
  84   endian : endian;                      (* endianness *)
  85   signed : bool;                        (* true if signed, false if unsigned *)
  86   t : t;                                (* type *)
  87   _loc : Loc.t;                         (* location in source code *)
  88 }
  89 and endian = BigEndian | LittleEndian | NativeEndian
  90 and t = Int | String | Bitstring
  91
  92 (* Generate a fresh, unique symbol each time called. *)
  93 let gensym =
  94   let i = ref 1000 in
  95   fun name ->
  96     incr i; let i = !i in
  97     sprintf "__pabitmatch_%s_%d" name i
  98
  99 let rec parse_patt_field _loc fpatt flen qs =
 100   let fpc = parse_field_common _loc flen qs in
 101   { fpatt = fpatt; fpc = fpc }
 102
 103 and parse_constr_field _loc fexpr flen qs =
 104   let fec = parse_field_common _loc flen qs in
 105   { fexpr = fexpr; fec = fec }
 106
 107 (* Deal with the qualifiers which appear for a field of both types. *)
 108 and parse_field_common _loc flen qs =
 109   let endian, signed, t =
 110     match qs with
 111     | None -> (None, None, None)
 112     | Some qs ->
 113         List.fold_left (
 114           fun (endian, signed, t) q ->
 115             match q with
 116             | "bigendian" ->
 117                 if endian <> None then
 118                   Loc.raise _loc (Failure "an endian flag has been set already")
 119                 else (
 120                   let endian = Some BigEndian in
 121                   (endian, signed, t)
 122                 )
 123             | "littleendian" ->
 124                 if endian <> None then
 125                   Loc.raise _loc (Failure "an endian flag has been set already")
 126                 else (
 127                   let endian = Some LittleEndian in
 128                   (endian, signed, t)
 129                 )
 130             | "nativeendian" ->
 131                 if endian <> None then
 132                   Loc.raise _loc (Failure "an endian flag has been set already")
 133                 else (
 134                   let endian = Some NativeEndian in
 135                   (endian, signed, t)
 136                 )
 137             | "signed" ->
 138                 if signed <> None then
 139                   Loc.raise _loc (Failure "a signed flag has been set already")
 140                 else (
 141                   let signed = Some true in
 142                   (endian, signed, t)
 143                 )
 144             | "unsigned" ->
 145                 if signed <> None then
 146                   Loc.raise _loc (Failure "a signed flag has been set already")
 147                 else (
 148                   let signed = Some false in
 149                   (endian, signed, t)
 150                 )
 151             | "int" ->
 152                 if t <> None then
 153                   Loc.raise _loc (Failure "a type flag has been set already")
 154                 else (
 155                   let t = Some Int in
 156                   (endian, signed, t)
 157                 )
 158             | "string" ->
 159                 if t <> None then
 160                   Loc.raise _loc (Failure "a type flag has been set already")
 161                 else (
 162                   let t = Some String in
 163                   (endian, signed, t)
 164                 )
 165             | "bitstring" ->
 166                 if t <> None then
 167                   Loc.raise _loc (Failure "a type flag has been set already")
 168                 else (
 169                   let t = Some Bitstring in
 170                   (endian, signed, t)
 171                 )
 172             | s ->
 173                 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
 174         ) (None, None, None) qs in
 175
 176   (* If type is set to string or bitstring then endianness and
 177    * signedness qualifiers are meaningless and must not be set.
 178    *)
 179   if (t = Some Bitstring || t = Some String)
 180     && (endian <> None || signed <> None) then
 181       Loc.raise _loc (
 182         Failure "string types and endian or signed qualifiers cannot be mixed"
 183       );
 184
 185   (* Default endianness, signedness, type. *)
 186   let endian = match endian with None -> BigEndian | Some e -> e in
 187   let signed = match signed with None -> false | Some s -> s in
 188   let t = match t with None -> Int | Some t -> t in
 189
 190   {
 191     flen = flen;
 192     endian = endian;
 193     signed = signed;
 194     t = t;
 195     _loc = _loc;
 196   }
 197
 198 let string_of_endian = function
 199   | BigEndian -> "bigendian"
 200   | LittleEndian -> "littleendian"
 201   | NativeEndian -> "nativeendian"
 202
 203 let string_of_t = function
 204   | Int -> "int"
 205   | String -> "string"
 206   | Bitstring -> "bitstring"
 207
 208 let rec string_of_patt_field { fpatt = fpatt; fpc = fpc } =
 209   let fpc = string_of_field_common fpc in
 210   let fpatt =
 211     match fpatt with
 212     | <:patt< $lid:id$ >> -> id
 213     | _ -> "[pattern]" in
 214   fpatt ^ " : " ^ fpc
 215
 216 and string_of_constr_field { fexpr = fexpr; fec = fec } =
 217   let fec = string_of_field_common fec in
 218   let fexpr =
 219     match fexpr with
 220     | <:expr< $lid:id$ >> -> id
 221     | _ -> "[expression]" in
 222   fexpr ^ " : " ^ fec
 223
 224 and string_of_field_common { flen = flen;
 225                              endian = endian; signed = signed; t = t;
 226                              _loc = _loc } =
 227   let flen =
 228     match expr_is_constant flen with
 229     | Some i -> string_of_int i
 230     | None -> "[non-const-len]" in
 231   let endian = string_of_endian endian in
 232   let signed = if signed then "signed" else "unsigned" in
 233   let t = string_of_t t in
 234   let loc_fname = Loc.file_name _loc in
 235   let loc_line = Loc.start_line _loc in
 236   let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
 237
 238   sprintf "%s : %s, %s, %s @ (%S, %d, %d)"
 239     flen t endian signed loc_fname loc_line loc_char
 240
 241 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
 242 let output_constructor _loc fields =
 243   let loc_fname = Loc.file_name _loc in
 244   let loc_line = string_of_int (Loc.start_line _loc) in
 245   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 246
 247   (* Bitstrings are created like the 'Buffer' module (in fact, using
 248    * the Buffer module), by appending snippets to a growing buffer.
 249    * This is reasonably efficient and avoids a lot of garbage.
 250    *)
 251   let buffer = gensym "buffer" in
 252
 253   (* General exception which is raised inside the constructor functions
 254    * when an int expression is out of range at runtime.
 255    *)
 256   let exn = gensym "exn" in
 257   let exn_used = ref false in
 258
 259   (* Convert each field to a simple bitstring-generating expression. *)
 260   let fields = List.map (
 261     fun {fexpr=fexpr; fec={flen=flen; endian=endian; signed=signed;
 262                            t=t; _loc=_loc}} ->
 263       (* Is flen an integer constant?  If so, what is it?  This
 264        * is very simple-minded and only detects simple constants.
 265        *)
 266       let flen_is_const = expr_is_constant flen in
 267
 268       let name_of_int_construct_const = function
 269           (* XXX As an enhancement we should allow a 64-bit-only
 270            * mode which lets us use 'int' up to 63 bits and won't
 271            * compile on 32-bit platforms.
 272            *)
 273           (* XXX The meaning of signed/unsigned breaks down at
 274            * 31, 32, 63 and 64 bits.
 275            *)
 276         | (1, _, _) -> "construct_bit"
 277         | ((2|3|4|5|6|7|8), _, false) -> "construct_char_unsigned"
 278         | ((2|3|4|5|6|7|8), _, true) -> "construct_char_signed"
 279         | (i, BigEndian, false) when i <= 31 -> "construct_int_be_unsigned"
 280         | (i, BigEndian, true) when i <= 31 -> "construct_int_be_signed"
 281         | (i, LittleEndian, false) when i <= 31 -> "construct_int_le_unsigned"
 282         | (i, LittleEndian, true) when i <= 31 -> "construct_int_le_signed"
 283         | (i, NativeEndian, false) when i <= 31 -> "construct_int_ne_unsigned"
 284         | (i, NativeEndian, true) when i <= 31 -> "construct_int_ne_signed"
 285         | (32, BigEndian, false) -> "construct_int32_be_unsigned"
 286         | (32, BigEndian, true) -> "construct_int32_be_signed"
 287         | (32, LittleEndian, false) -> "construct_int32_le_unsigned"
 288         | (32, LittleEndian, true) -> "construct_int32_le_signed"
 289         | (32, NativeEndian, false) -> "construct_int32_ne_unsigned"
 290         | (32, NativeEndian, true) -> "construct_int32_ne_signed"
 291         | (_, BigEndian, false) -> "construct_int64_be_unsigned"
 292         | (_, BigEndian, true) -> "construct_int64_be_signed"
 293         | (_, LittleEndian, false) -> "construct_int64_le_unsigned"
 294         | (_, LittleEndian, true) -> "construct_int64_le_signed"
 295         | (_, NativeEndian, false) -> "construct_int64_ne_unsigned"
 296         | (_, NativeEndian, true) -> "construct_int64_ne_signed"
 297       in
 298       let name_of_int_construct = function
 299           (* XXX As an enhancement we should allow users to
 300            * specify that a field length can fit into a char/int/int32
 301            * (of course, this would have to be checked at runtime).
 302            *)
 303         | (BigEndian, false) -> "construct_int64_be_unsigned"
 304         | (BigEndian, true) -> "construct_int64_be_signed"
 305         | (LittleEndian, false) -> "construct_int64_le_unsigned"
 306         | (LittleEndian, true) -> "construct_int64_le_signed"
 307         | (NativeEndian, false) -> "construct_int64_ne_unsigned"
 308         | (NativeEndian, true) -> "construct_int64_ne_signed"
 309       in
 310
 311       let expr =
 312         match t, flen_is_const with
 313         (* Common case: int field, constant flen.
 314          *
 315          * Range checks are done inside the construction function
 316          * because that's a lot simpler w.r.t. types.  It might
 317          * be better to move them here. XXX
 318          *)
 319         | Int, Some i when i > 0 && i <= 64 ->
 320             let construct_func =
 321               name_of_int_construct_const (i,endian,signed) in
 322             exn_used := true;
 323
 324             <:expr<
 325               Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
 326                 $lid:exn$
 327             >>
 328
 329         | Int, Some _ ->
 330             Loc.raise _loc (Failure "length of int field must be [1..64]")
 331
 332         (* Int field, non-constant length.  We need to perform a runtime
 333          * test to ensure the length is [1..64].
 334          *
 335          * Range checks are done inside the construction function
 336          * because that's a lot simpler w.r.t. types.  It might
 337          * be better to move them here. XXX
 338          *)
 339         | Int, None ->
 340             let construct_func = name_of_int_construct (endian,signed) in
 341             exn_used := true;
 342
 343             <:expr<
 344               if $flen$ >= 1 && $flen$ <= 64 then
 345                 Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
 346                   $lid:exn$
 347               else
 348                 raise (Bitmatch.Construct_failure
 349                          ("length of int field must be [1..64]",
 350                           $str:loc_fname$,
 351                           $int:loc_line$, $int:loc_char$))
 352             >>
 353
 354         (* String, constant length > 0, must be a multiple of 8. *)
 355         | String, Some i when i > 0 && i land 7 = 0 ->
 356             let bs = gensym "bs" in
 357             <:expr<
 358               let $lid:bs$ = $fexpr$ in
 359               if String.length $lid:bs$ = ($flen$ lsr 3) then
 360                 Bitmatch.construct_string $lid:buffer$ $lid:bs$
 361               else
 362                 raise (Bitmatch.Construct_failure
 363                          ("length of string does not match declaration",
 364                           $str:loc_fname$,
 365                           $int:loc_line$, $int:loc_char$))
 366             >>
 367
 368         (* String, constant length -1, means variable length string
 369          * with no checks.
 370          *)
 371         | String, Some (-1) ->
 372             <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
 373
 374         (* String, constant length = 0 is probably an error, and so is
 375          * any other value.
 376          *)
 377         | String, Some _ ->
 378             Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
 379
 380         (* String, non-constant length.
 381          * We check at runtime that the length is > 0, a multiple of 8,
 382          * and matches the declared length.
 383          *)
 384         | String, None ->
 385             let bslen = gensym "bslen" in
 386             let bs = gensym "bs" in
 387             <:expr<
 388               let $lid:bslen$ = $flen$ in
 389               if $lid:bslen$ > 0 then (
 390                 if $lid:bslen$ land 7 = 0 then (
 391                   let $lid:bs$ = $fexpr$ in
 392                   if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
 393                     Bitmatch.construct_string $lid:buffer$ $lid:bs$
 394                   else
 395                     raise (Bitmatch.Construct_failure
 396                              ("length of string does not match declaration",
 397                               $str:loc_fname$,
 398                               $int:loc_line$, $int:loc_char$))
 399                 ) else
 400                   raise (Bitmatch.Construct_failure
 401                            ("length of string must be a multiple of 8",
 402                             $str:loc_fname$,
 403                             $int:loc_line$, $int:loc_char$))
 404               ) else
 405                 raise (Bitmatch.Construct_failure
 406                          ("length of string must be > 0",
 407                           $str:loc_fname$,
 408                           $int:loc_line$, $int:loc_char$))
 409             >>
 410
 411         (* Bitstring, constant length > 0. *)
 412         | Bitstring, Some i when i > 0 ->
 413             let bs = gensym "bs" in
 414             <:expr<
 415               let $lid:bs$ = $fexpr$ in
 416               if Bitmatch.bitstring_length $lid:bs$ = $flen$ then
 417                 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
 418               else
 419                 raise (Bitmatch.Construct_failure
 420                          ("length of bitstring does not match declaration",
 421                           $str:loc_fname$,
 422                           $int:loc_line$, $int:loc_char$))
 423             >>
 424
 425         (* Bitstring, constant length -1, means variable length bitstring
 426          * with no checks.
 427          *)
 428         | Bitstring, Some (-1) ->
 429             <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
 430
 431         (* Bitstring, constant length = 0 is probably an error, and so is
 432          * any other value.
 433          *)
 434         | Bitstring, Some _ ->
 435             Loc.raise _loc
 436               (Failure
 437                  "length of bitstring must be > 0 or the special value -1")
 438
 439         (* Bitstring, non-constant length.
 440          * We check at runtime that the length is > 0 and matches
 441          * the declared length.
 442          *)
 443         | Bitstring, None ->
 444             let bslen = gensym "bslen" in
 445             let bs = gensym "bs" in
 446             <:expr<
 447               let $lid:bslen$ = $flen$ in
 448               if $lid:bslen$ > 0 then (
 449                 let $lid:bs$ = $fexpr$ in
 450                 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
 451                   Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
 452                 else
 453                   raise (Bitmatch.Construct_failure
 454                            ("length of bitstring does not match declaration",
 455                             $str:loc_fname$,
 456                             $int:loc_line$, $int:loc_char$))
 457               ) else
 458                 raise (Bitmatch.Construct_failure
 459                          ("length of bitstring must be > 0",
 460                           $str:loc_fname$,
 461                           $int:loc_line$, $int:loc_char$))
 462             >> in
 463       expr
 464   ) fields in
 465
 466   (* Create the final bitstring.  Start by creating an empty buffer
 467    * and then evaluate each expression above in turn which will
 468    * append some more to the bitstring buffer.  Finally extract
 469    * the bitstring.
 470    *
 471    * XXX We almost have enough information to be able to guess
 472    * a good initial size for the buffer.
 473    *)
 474   let fields =
 475     match fields with
 476     | [] -> <:expr< [] >>
 477     | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
 478
 479   let expr =
 480     <:expr<
 481       let $lid:buffer$ = Bitmatch.Buffer.create () in
 482       $fields$;
 483       Bitmatch.Buffer.contents $lid:buffer$
 484     >> in
 485
 486   if !exn_used then
 487     <:expr<
 488       let $lid:exn$ =
 489         Bitmatch.Construct_failure ("value out of range",
 490                                     $str:loc_fname$,
 491                                     $int:loc_line$, $int:loc_char$) in
 492         $expr$
 493     >>
 494   else
 495     expr
 496
 497 (* Generate the code for a bitmatch statement.  '_loc' is the
 498  * location, 'bs' is the bitstring parameter, 'cases' are
 499  * the list of cases to test against.
 500  *)
 501 let output_bitmatch _loc bs cases =
 502   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
 503   let result = gensym "result" in
 504
 505   (* This generates the field extraction code for each
 506    * field a single case.  Each field must be wider than
 507    * the minimum permitted for the type and there must be
 508    * enough remaining data in the bitstring to satisfy it.
 509    * As we go through the fields, symbols 'data', 'off' and 'len'
 510    * track our position and remaining length in the bitstring.
 511    *
 512    * The whole thing is a lot of nested 'if' statements. Code
 513    * is generated from the inner-most (last) field outwards.
 514    *)
 515   let rec output_field_extraction inner = function
 516     | [] -> inner
 517     | field :: fields ->
 518         let {fpatt=fpatt; fpc={flen=flen; endian=endian; signed=signed;
 519                                t=t; _loc=_loc}}
 520             = field in
 521
 522         (* Is flen an integer constant?  If so, what is it?  This
 523          * is very simple-minded and only detects simple constants.
 524          *)
 525         let flen_is_const = expr_is_constant flen in
 526
 527         let name_of_int_extract_const = function
 528             (* XXX As an enhancement we should allow a 64-bit-only
 529              * mode which lets us use 'int' up to 63 bits and won't
 530              * compile on 32-bit platforms.
 531              *)
 532             (* XXX The meaning of signed/unsigned breaks down at
 533              * 31, 32, 63 and 64 bits.
 534              *)
 535           | (1, _, _) -> "extract_bit"
 536           | ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
 537           | ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
 538           | (i, BigEndian, false) when i <= 31 -> "extract_int_be_unsigned"
 539           | (i, BigEndian, true) when i <= 31 -> "extract_int_be_signed"
 540           | (i, LittleEndian, false) when i <= 31 -> "extract_int_le_unsigned"
 541           | (i, LittleEndian, true) when i <= 31 -> "extract_int_le_signed"
 542           | (i, NativeEndian, false) when i <= 31 -> "extract_int_ne_unsigned"
 543           | (i, NativeEndian, true) when i <= 31 -> "extract_int_ne_signed"
 544           | (32, BigEndian, false) -> "extract_int32_be_unsigned"
 545           | (32, BigEndian, true) -> "extract_int32_be_signed"
 546           | (32, LittleEndian, false) -> "extract_int32_le_unsigned"
 547           | (32, LittleEndian, true) -> "extract_int32_le_signed"
 548           | (32, NativeEndian, false) -> "extract_int32_ne_unsigned"
 549           | (32, NativeEndian, true) -> "extract_int32_ne_signed"
 550           | (_, BigEndian, false) -> "extract_int64_be_unsigned"
 551           | (_, BigEndian, true) -> "extract_int64_be_signed"
 552           | (_, LittleEndian, false) -> "extract_int64_le_unsigned"
 553           | (_, LittleEndian, true) -> "extract_int64_le_signed"
 554           | (_, NativeEndian, false) -> "extract_int64_ne_unsigned"
 555           | (_, NativeEndian, true) -> "extract_int64_ne_signed"
 556         in
 557         let name_of_int_extract = function
 558             (* XXX As an enhancement we should allow users to
 559              * specify that a field length can fit into a char/int/int32
 560              * (of course, this would have to be checked at runtime).
 561              *)
 562           | (BigEndian, false) -> "extract_int64_be_unsigned"
 563           | (BigEndian, true) -> "extract_int64_be_signed"
 564           | (LittleEndian, false) -> "extract_int64_le_unsigned"
 565           | (LittleEndian, true) -> "extract_int64_le_signed"
 566           | (NativeEndian, false) -> "extract_int64_ne_unsigned"
 567           | (NativeEndian, true) -> "extract_int64_ne_signed"
 568         in
 569
 570         let expr =
 571           match t, flen_is_const with
 572           (* Common case: int field, constant flen *)
 573           | Int, Some i when i > 0 && i <= 64 ->
 574               let extract_func = name_of_int_extract_const (i,endian,signed) in
 575               let v = gensym "val" in
 576               <:expr<
 577                 if $lid:len$ >= $flen$ then (
 578                   let $lid:v$, $lid:off$, $lid:len$ =
 579                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 580                       $flen$ in
 581                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 582                 )
 583               >>
 584
 585           | Int, Some _ ->
 586               Loc.raise _loc (Failure "length of int field must be [1..64]")
 587
 588           (* Int field, non-const flen.  We have to test the range of
 589            * the field at runtime.  If outside the range it's a no-match
 590            * (not an error).
 591            *)
 592           | Int, None ->
 593               let extract_func = name_of_int_extract (endian,signed) in
 594               let v = gensym "val" in
 595               <:expr<
 596                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
 597                   let $lid:v$, $lid:off$, $lid:len$ =
 598                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 599                       $flen$ in
 600                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 601                 )
 602               >>
 603
 604           (* String, constant flen > 0. *)
 605           | String, Some i when i > 0 && i land 7 = 0 ->
 606               let bs = gensym "bs" in
 607               <:expr<
 608                 if $lid:len$ >= $flen$ then (
 609                   let $lid:bs$, $lid:off$, $lid:len$ =
 610                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 611                       $flen$ in
 612                   match Bitmatch.string_of_bitstring $lid:bs$ with
 613                   | $fpatt$ when true -> $inner$
 614                   | _ -> ()
 615                 )
 616               >>
 617
 618           (* String, constant flen = -1, means consume all the
 619            * rest of the input.
 620            *)
 621           | String, Some i when i = -1 ->
 622               let bs = gensym "bs" in
 623               <:expr<
 624                 let $lid:bs$, $lid:off$, $lid:len$ =
 625                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 626                 match Bitmatch.string_of_bitstring $lid:bs$ with
 627                 | $fpatt$ when true -> $inner$
 628                 | _ -> ()
 629               >>
 630
 631           | String, Some _ ->
 632               Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
 633
 634           (* String field, non-const flen.  We check the flen is > 0
 635            * and a multiple of 8 (-1 is not allowed here), at runtime.
 636            *)
 637           | String, None ->
 638               let bs = gensym "bs" in
 639               <:expr<
 640                 if $flen$ >= 0 && $flen$ <= $lid:len$
 641                   && $flen$ land 7 = 0 then (
 642                     let $lid:bs$, $lid:off$, $lid:len$ =
 643                       Bitmatch.extract_bitstring
 644                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
 645                     match Bitmatch.string_of_bitstring $lid:bs$ with
 646                     | $fpatt$ when true -> $inner$
 647                     | _ -> ()
 648                   )
 649               >>
 650
 651           (* Bitstring, constant flen >= 0.
 652            * At the moment all we can do is assign the bitstring to an
 653            * identifier.
 654            *)
 655           | Bitstring, Some i when i >= 0 ->
 656               let ident =
 657                 match fpatt with
 658                 | <:patt< $lid:ident$ >> -> ident
 659                 | <:patt< _ >> -> "_"
 660                 | _ ->
 661                     Loc.raise _loc
 662                       (Failure "cannot compare a bitstring to a constant") in
 663               <:expr<
 664                 if $lid:len$ >= $flen$ then (
 665                   let $lid:ident$, $lid:off$, $lid:len$ =
 666                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 667                       $flen$ in
 668                   $inner$
 669                 )
 670               >>
 671
 672           (* Bitstring, constant flen = -1, means consume all the
 673            * rest of the input.
 674            *)
 675           | Bitstring, Some i when i = -1 ->
 676               let ident =
 677                 match fpatt with
 678                 | <:patt< $lid:ident$ >> -> ident
 679                 | _ ->
 680                     Loc.raise _loc
 681                       (Failure "cannot compare a bitstring to a constant") in
 682               <:expr<
 683                 let $lid:ident$, $lid:off$, $lid:len$ =
 684                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 685                   $inner$
 686               >>
 687
 688           | Bitstring, Some _ ->
 689               Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
 690
 691           (* Bitstring field, non-const flen.  We check the flen is >= 0
 692            * (-1 is not allowed here) at runtime.
 693            *)
 694           | Bitstring, None ->
 695               let ident =
 696                 match fpatt with
 697                 | <:patt< $lid:ident$ >> -> ident
 698                 | _ ->
 699                     Loc.raise _loc
 700                       (Failure "cannot compare a bitstring to a constant") in
 701               <:expr<
 702                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
 703                   let $lid:ident$, $lid:off$, $lid:len$ =
 704                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 705                       $flen$ in
 706                   $inner$
 707                 )
 708               >>
 709         in
 710
 711         (* Emit extra debugging code. *)
 712         let expr =
 713           if not debug then expr else (
 714             let field = string_of_patt_field field in
 715
 716             <:expr<
 717               if !Bitmatch.debug then (
 718                 Printf.eprintf "PA_BITMATCH: TEST:\n";
 719                 Printf.eprintf "  %s\n" $str:field$;
 720                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
 721                 (*Bitmatch.hexdump_bitstring stderr
 722                   ($lid:data$,$lid:off$,$lid:len$);*)
 723               );
 724               $expr$
 725             >>
 726           ) in
 727
 728         output_field_extraction expr fields
 729   in
 730
 731   (* Convert each case in the match. *)
 732   let cases = List.map (
 733     fun (fields, bind, whenclause, code) ->
 734       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
 735       let inner =
 736         match whenclause with
 737         | Some whenclause ->
 738             <:expr< if $whenclause$ then $inner$ >>
 739         | None -> inner in
 740       let inner =
 741         match bind with
 742         | Some name ->
 743             <:expr<
 744               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
 745               $inner$
 746               >>
 747         | None -> inner in
 748       output_field_extraction inner (List.rev fields)
 749   ) cases in
 750
 751   (* Join them into a single expression.
 752    *
 753    * Don't do it with a normal fold_right because that leaves
 754    * 'raise Exit; ()' at the end which causes a compiler warning.
 755    * Hence a bit of complexity here.
 756    *
 757    * Note that the number of cases is always >= 1 so List.hd is safe.
 758    *)
 759   let cases = List.rev cases in
 760   let cases =
 761     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
 762       (List.hd cases) (List.tl cases) in
 763
 764   (* The final code just wraps the list of cases in a
 765    * try/with construct so that each case is tried in
 766    * turn until one case matches (that case sets 'result'
 767    * and raises 'Exit' to leave the whole statement).
 768    * If result isn't set by the end then we will raise
 769    * Match_failure with the location of the bitmatch
 770    * statement in the original code.
 771    *)
 772   let loc_fname = Loc.file_name _loc in
 773   let loc_line = string_of_int (Loc.start_line _loc) in
 774   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 775
 776   <:expr<
 777     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
 778     let $lid:result$ = ref None in
 779     (try
 780       $cases$
 781     with Exit -> ());
 782     match ! $lid:result$ with
 783     | Some x -> x
 784     | None -> raise (Match_failure ($str:loc_fname$,
 785                                     $int:loc_line$, $int:loc_char$))
 786   >>
 787
 788 EXTEND Gram
 789   GLOBAL: expr;
 790
 791   qualifiers: [
 792     [ LIST0 [ q = LIDENT -> q ] SEP "," ]
 793   ];
 794
 795   (* Field used in the bitmatch operator (a pattern). *)
 796   patt_field: [
 797     [ fpatt = patt; ":"; len = expr LEVEL "top";
 798       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
 799         parse_patt_field _loc fpatt len qs
 800     ]
 801   ];
 802
 803   (* Case inside bitmatch operator. *)
 804   match_case: [
 805     [ "{";
 806       fields = LIST0 patt_field SEP ";";
 807       "}";
 808       bind = OPT [ "as"; name = LIDENT -> name ];
 809       whenclause = OPT [ "when"; e = expr -> e ]; "->";
 810       code = expr ->
 811         (fields, bind, whenclause, code)
 812     ]
 813   ];
 814
 815   (* Field used in the BITSTRING constructor (an expression). *)
 816   constr_field: [
 817     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
 818       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
 819         parse_constr_field _loc fexpr len qs
 820     ]
 821   ];
 822
 823   (* 'bitmatch' expressions. *)
 824   expr: LEVEL ";" [
 825     [ "bitmatch";
 826       bs = expr; "with"; OPT "|";
 827       cases = LIST1 match_case SEP "|" ->
 828         output_bitmatch _loc bs cases
 829     ]
 830
 831   (* Constructor. *)
 832   | [ "BITSTRING"; "{";
 833       fields = LIST0 constr_field SEP ";";
 834       "}" ->
 835         output_constructor _loc fields
 836     ]
 837   ];
 838
 839 END