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