pa_bitmatch.ml

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