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