pa_bitmatch.ml

   1 (* Bitmatch syntax extension.
   2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
   3  *
   4  * This library is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU Lesser General Public
   6  * License as published by the Free Software Foundation; either
   7  * version 2 of the License, or (at your option) any later version.
   8  *
   9  * This library is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * Lesser General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU Lesser General Public
  15  * License along with this library; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *
  18  * $Id$
  19  *)
  20
  21 open Printf
  22
  23 open Camlp4.PreCast
  24 open Syntax
  25 open Ast
  26
  27 (* 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 : Bitmatch.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 t = Int | String | Bitstring
  84
  85 (* Generate a fresh, unique symbol each time called. *)
  86 let gensym =
  87   let i = ref 1000 in
  88   fun name ->
  89     incr i; let i = !i in
  90     sprintf "__pabitmatch_%s_%d" name i
  91
  92 (* Deal with the qualifiers which appear for a field of both types. *)
  93 let parse_field _loc field flen qs printer =
  94   let endian, signed, t =
  95     match qs with
  96     | None -> (None, None, None)
  97     | Some qs ->
  98         List.fold_left (
  99           fun (endian, signed, t) q ->
 100             match q with
 101             | "bigendian" ->
 102                 if endian <> None then
 103                   Loc.raise _loc (Failure "an endian flag has been set already")
 104                 else (
 105                   let endian = Some Bitmatch.BigEndian in
 106                   (endian, signed, t)
 107                 )
 108             | "littleendian" ->
 109                 if endian <> None then
 110                   Loc.raise _loc (Failure "an endian flag has been set already")
 111                 else (
 112                   let endian = Some Bitmatch.LittleEndian in
 113                   (endian, signed, t)
 114                 )
 115             | "nativeendian" ->
 116                 if endian <> None then
 117                   Loc.raise _loc (Failure "an endian flag has been set already")
 118                 else (
 119                   let endian = Some Bitmatch.NativeEndian in
 120                   (endian, signed, t)
 121                 )
 122             | "signed" ->
 123                 if signed <> None then
 124                   Loc.raise _loc (Failure "a signed flag has been set already")
 125                 else (
 126                   let signed = Some true in
 127                   (endian, signed, t)
 128                 )
 129             | "unsigned" ->
 130                 if signed <> None then
 131                   Loc.raise _loc (Failure "a signed flag has been set already")
 132                 else (
 133                   let signed = Some false in
 134                   (endian, signed, t)
 135                 )
 136             | "int" ->
 137                 if t <> None then
 138                   Loc.raise _loc (Failure "a type flag has been set already")
 139                 else (
 140                   let t = Some Int in
 141                   (endian, signed, t)
 142                 )
 143             | "string" ->
 144                 if t <> None then
 145                   Loc.raise _loc (Failure "a type flag has been set already")
 146                 else (
 147                   let t = Some String in
 148                   (endian, signed, t)
 149                 )
 150             | "bitstring" ->
 151                 if t <> None then
 152                   Loc.raise _loc (Failure "a type flag has been set already")
 153                 else (
 154                   let t = Some Bitstring in
 155                   (endian, signed, t)
 156                 )
 157             | s ->
 158                 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
 159         ) (None, None, None) qs in
 160
 161   (* If type is set to string or bitstring then endianness and
 162    * signedness qualifiers are meaningless and must not be set.
 163    *)
 164   if (t = Some Bitstring || t = Some String)
 165     && (endian <> None || signed <> None) then
 166       Loc.raise _loc (
 167         Failure "string types and endian or signed qualifiers cannot be mixed"
 168       );
 169
 170   (* Default endianness, signedness, type. *)
 171   let endian = match endian with None -> Bitmatch.BigEndian | Some e -> e in
 172   let signed = match signed with None -> false | Some s -> s in
 173   let t = match t with None -> Int | Some t -> t in
 174
 175   {
 176     field = field;
 177     flen = flen;
 178     endian = endian;
 179     signed = signed;
 180     t = t;
 181     _loc = _loc;
 182     printer = printer;
 183   }
 184
 185 let string_of_t = function
 186   | Int -> "int"
 187   | String -> "string"
 188   | Bitstring -> "bitstring"
 189
 190 let patt_printer = function
 191   | <:patt< $lid:id$ >> -> id
 192   | _ -> "[pattern]"
 193
 194 let expr_printer = function
 195   | <:expr< $lid:id$ >> -> id
 196   | _ -> "[expression]"
 197
 198 let string_of_field { field = field; flen = flen;
 199                       endian = endian; signed = signed; t = t;
 200                       _loc = _loc;
 201                       printer = printer} =
 202   let flen =
 203     match expr_is_constant flen with
 204     | Some i -> string_of_int i
 205     | None -> "[non-const-len]" in
 206   let endian = Bitmatch.string_of_endian endian in
 207   let signed = if signed then "signed" else "unsigned" in
 208   let t = string_of_t t in
 209   let loc_fname = Loc.file_name _loc in
 210   let loc_line = Loc.start_line _loc in
 211   let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
 212
 213   sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)"
 214     (printer field) flen t endian signed loc_fname loc_line loc_char
 215
 216 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
 217 let output_constructor _loc fields =
 218   let loc_fname = Loc.file_name _loc in
 219   let loc_line = string_of_int (Loc.start_line _loc) in
 220   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 221
 222   (* Bitstrings are created like the 'Buffer' module (in fact, using
 223    * the Buffer module), by appending snippets to a growing buffer.
 224    * This is reasonably efficient and avoids a lot of garbage.
 225    *)
 226   let buffer = gensym "buffer" in
 227
 228   (* General exception which is raised inside the constructor functions
 229    * when an int expression is out of range at runtime.
 230    *)
 231   let exn = gensym "exn" in
 232   let exn_used = ref false in
 233
 234   (* Convert each field to a simple bitstring-generating expression. *)
 235   let fields = List.map (
 236     fun {field=fexpr; flen=flen; endian=endian; signed=signed;
 237          t=t; _loc=_loc} ->
 238       (* Is flen an integer constant?  If so, what is it?  This
 239        * is very simple-minded and only detects simple constants.
 240        *)
 241       let flen_is_const = expr_is_constant flen in
 242
 243       let name_of_int_construct_const = function
 244           (* XXX As an enhancement we should allow a 64-bit-only
 245            * mode which lets us use 'int' up to 63 bits and won't
 246            * compile on 32-bit platforms.
 247            *)
 248           (* XXX The meaning of signed/unsigned breaks down at
 249            * 31, 32, 63 and 64 bits.
 250            *)
 251         | (1, _, _) -> "construct_bit"
 252         | ((2|3|4|5|6|7|8), _, false) -> "construct_char_unsigned"
 253         | ((2|3|4|5|6|7|8), _, true) -> "construct_char_signed"
 254         | (i, Bitmatch.BigEndian, false) when i <= 31 ->
 255             "construct_int_be_unsigned"
 256         | (i, Bitmatch.BigEndian, true) when i <= 31 ->
 257             "construct_int_be_signed"
 258         | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
 259             "construct_int_le_unsigned"
 260         | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
 261             "construct_int_le_signed"
 262         | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
 263             "construct_int_ne_unsigned"
 264         | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
 265             "construct_int_ne_signed"
 266         | (32, Bitmatch.BigEndian, false) -> "construct_int32_be_unsigned"
 267         | (32, Bitmatch.BigEndian, true) -> "construct_int32_be_signed"
 268         | (32, Bitmatch.LittleEndian, false) -> "construct_int32_le_unsigned"
 269         | (32, Bitmatch.LittleEndian, true) -> "construct_int32_le_signed"
 270         | (32, Bitmatch.NativeEndian, false) -> "construct_int32_ne_unsigned"
 271         | (32, Bitmatch.NativeEndian, true) -> "construct_int32_ne_signed"
 272         | (_, Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
 273         | (_, Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
 274         | (_, Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
 275         | (_, Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
 276         | (_, Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
 277         | (_, Bitmatch.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         | (Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
 285         | (Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
 286         | (Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
 287         | (Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
 288         | (Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
 289         | (Bitmatch.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, Bitmatch.BigEndian, false) when i <= 31 ->
 520               "extract_int_be_unsigned"
 521           | (i, Bitmatch.BigEndian, true) when i <= 31 ->
 522               "extract_int_be_signed"
 523           | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
 524               "extract_int_le_unsigned"
 525           | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
 526               "extract_int_le_signed"
 527           | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
 528               "extract_int_ne_unsigned"
 529           | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
 530               "extract_int_ne_signed"
 531           | (32, Bitmatch.BigEndian, false) -> "extract_int32_be_unsigned"
 532           | (32, Bitmatch.BigEndian, true) -> "extract_int32_be_signed"
 533           | (32, Bitmatch.LittleEndian, false) -> "extract_int32_le_unsigned"
 534           | (32, Bitmatch.LittleEndian, true) -> "extract_int32_le_signed"
 535           | (32, Bitmatch.NativeEndian, false) -> "extract_int32_ne_unsigned"
 536           | (32, Bitmatch.NativeEndian, true) -> "extract_int32_ne_signed"
 537           | (_, Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
 538           | (_, Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
 539           | (_, Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
 540           | (_, Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
 541           | (_, Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
 542           | (_, Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
 543         in
 544         let name_of_int_extract = function
 545             (* XXX As an enhancement we should allow users to
 546              * specify that a field length can fit into a char/int/int32
 547              * (of course, this would have to be checked at runtime).
 548              *)
 549           | (Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
 550           | (Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
 551           | (Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
 552           | (Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
 553           | (Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
 554           | (Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
 555         in
 556
 557         let expr =
 558           match t, flen_is_const with
 559           (* Common case: int field, constant flen *)
 560           | Int, Some i when i > 0 && i <= 64 ->
 561               let extract_func = name_of_int_extract_const (i,endian,signed) in
 562               let v = gensym "val" in
 563               <:expr<
 564                 if $lid:len$ >= $flen$ then (
 565                   let $lid:v$, $lid:off$, $lid:len$ =
 566                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 567                       $flen$ in
 568                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 569                 )
 570               >>
 571
 572           | Int, Some _ ->
 573               Loc.raise _loc (Failure "length of int field must be [1..64]")
 574
 575           (* Int field, non-const flen.  We have to test the range of
 576            * the field at runtime.  If outside the range it's a no-match
 577            * (not an error).
 578            *)
 579           | Int, None ->
 580               let extract_func = name_of_int_extract (endian,signed) in
 581               let v = gensym "val" in
 582               <:expr<
 583                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
 584                   let $lid:v$, $lid:off$, $lid:len$ =
 585                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 586                       $flen$ in
 587                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 588                 )
 589               >>
 590
 591           (* String, constant flen > 0. *)
 592           | String, Some i when i > 0 && i land 7 = 0 ->
 593               let bs = gensym "bs" in
 594               <:expr<
 595                 if $lid:len$ >= $flen$ then (
 596                   let $lid:bs$, $lid:off$, $lid:len$ =
 597                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 598                       $flen$ in
 599                   match Bitmatch.string_of_bitstring $lid:bs$ with
 600                   | $fpatt$ when true -> $inner$
 601                   | _ -> ()
 602                 )
 603               >>
 604
 605           (* String, constant flen = -1, means consume all the
 606            * rest of the input.
 607            *)
 608           | String, Some i when i = -1 ->
 609               let bs = gensym "bs" in
 610               <:expr<
 611                 let $lid:bs$, $lid:off$, $lid:len$ =
 612                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 613                 match Bitmatch.string_of_bitstring $lid:bs$ with
 614                 | $fpatt$ when true -> $inner$
 615                 | _ -> ()
 616               >>
 617
 618           | String, Some _ ->
 619               Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
 620
 621           (* String field, non-const flen.  We check the flen is > 0
 622            * and a multiple of 8 (-1 is not allowed here), at runtime.
 623            *)
 624           | String, None ->
 625               let bs = gensym "bs" in
 626               <:expr<
 627                 if $flen$ >= 0 && $flen$ <= $lid:len$
 628                   && $flen$ land 7 = 0 then (
 629                     let $lid:bs$, $lid:off$, $lid:len$ =
 630                       Bitmatch.extract_bitstring
 631                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
 632                     match Bitmatch.string_of_bitstring $lid:bs$ with
 633                     | $fpatt$ when true -> $inner$
 634                     | _ -> ()
 635                   )
 636               >>
 637
 638           (* Bitstring, constant flen >= 0.
 639            * At the moment all we can do is assign the bitstring to an
 640            * identifier.
 641            *)
 642           | Bitstring, Some i when i >= 0 ->
 643               let ident =
 644                 match fpatt with
 645                 | <:patt< $lid:ident$ >> -> ident
 646                 | <:patt< _ >> -> "_"
 647                 | _ ->
 648                     Loc.raise _loc
 649                       (Failure "cannot compare a bitstring to a constant") in
 650               <:expr<
 651                 if $lid:len$ >= $flen$ then (
 652                   let $lid:ident$, $lid:off$, $lid:len$ =
 653                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 654                       $flen$ in
 655                   $inner$
 656                 )
 657               >>
 658
 659           (* Bitstring, constant flen = -1, means consume all the
 660            * rest of the input.
 661            *)
 662           | Bitstring, Some i when i = -1 ->
 663               let ident =
 664                 match fpatt with
 665                 | <:patt< $lid:ident$ >> -> ident
 666                 | <:patt< _ >> -> "_"
 667                 | _ ->
 668                     Loc.raise _loc
 669                       (Failure "cannot compare a bitstring to a constant") in
 670               <:expr<
 671                 let $lid:ident$, $lid:off$, $lid:len$ =
 672                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 673                   $inner$
 674               >>
 675
 676           | Bitstring, Some _ ->
 677               Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
 678
 679           (* Bitstring field, non-const flen.  We check the flen is >= 0
 680            * (-1 is not allowed here) at runtime.
 681            *)
 682           | Bitstring, None ->
 683               let ident =
 684                 match fpatt with
 685                 | <:patt< $lid:ident$ >> -> ident
 686                 | <:patt< _ >> -> "_"
 687                 | _ ->
 688                     Loc.raise _loc
 689                       (Failure "cannot compare a bitstring to a constant") in
 690               <:expr<
 691                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
 692                   let $lid:ident$, $lid:off$, $lid:len$ =
 693                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 694                       $flen$ in
 695                   $inner$
 696                 )
 697               >>
 698         in
 699
 700         (* Emit extra debugging code. *)
 701         let expr =
 702           if not debug then expr else (
 703             let field = string_of_field field in
 704
 705             <:expr<
 706               if !Bitmatch.debug then (
 707                 Printf.eprintf "PA_BITMATCH: TEST:\n";
 708                 Printf.eprintf "  %s\n" $str:field$;
 709                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
 710                 (*Bitmatch.hexdump_bitstring stderr
 711                   ($lid:data$,$lid:off$,$lid:len$);*)
 712               );
 713               $expr$
 714             >>
 715           ) in
 716
 717         output_field_extraction expr fields
 718   in
 719
 720   (* Convert each case in the match. *)
 721   let cases = List.map (
 722     fun (fields, bind, whenclause, code) ->
 723       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
 724       let inner =
 725         match whenclause with
 726         | Some whenclause ->
 727             <:expr< if $whenclause$ then $inner$ >>
 728         | None -> inner in
 729       let inner =
 730         match bind with
 731         | Some name ->
 732             <:expr<
 733               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
 734               $inner$
 735               >>
 736         | None -> inner in
 737       output_field_extraction inner (List.rev fields)
 738   ) cases in
 739
 740   (* Join them into a single expression.
 741    *
 742    * Don't do it with a normal fold_right because that leaves
 743    * 'raise Exit; ()' at the end which causes a compiler warning.
 744    * Hence a bit of complexity here.
 745    *
 746    * Note that the number of cases is always >= 1 so List.hd is safe.
 747    *)
 748   let cases = List.rev cases in
 749   let cases =
 750     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
 751       (List.hd cases) (List.tl cases) in
 752
 753   (* The final code just wraps the list of cases in a
 754    * try/with construct so that each case is tried in
 755    * turn until one case matches (that case sets 'result'
 756    * and raises 'Exit' to leave the whole statement).
 757    * If result isn't set by the end then we will raise
 758    * Match_failure with the location of the bitmatch
 759    * statement in the original code.
 760    *)
 761   let loc_fname = Loc.file_name _loc in
 762   let loc_line = string_of_int (Loc.start_line _loc) in
 763   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 764
 765   <:expr<
 766     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
 767     let $lid:result$ = ref None in
 768     (try
 769       $cases$
 770     with Exit -> ());
 771     match ! $lid:result$ with
 772     | Some x -> x
 773     | None -> raise (Match_failure ($str:loc_fname$,
 774                                     $int:loc_line$, $int:loc_char$))
 775   >>
 776
 777 EXTEND Gram
 778   GLOBAL: expr;
 779
 780   qualifiers: [
 781     [ LIST0 [ q = LIDENT -> q ] SEP "," ]
 782   ];
 783
 784   (* Field used in the bitmatch operator (a pattern). *)
 785   patt_field: [
 786     [ fpatt = patt; ":"; len = expr LEVEL "top";
 787       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
 788         parse_field _loc fpatt len qs patt_printer
 789     ]
 790   ];
 791
 792   (* Case inside bitmatch operator. *)
 793   match_case: [
 794     [ "{";
 795       fields = LIST0 patt_field SEP ";";
 796       "}";
 797       bind = OPT [ "as"; name = LIDENT -> name ];
 798       whenclause = OPT [ "when"; e = expr -> e ]; "->";
 799       code = expr ->
 800         (fields, bind, whenclause, code)
 801     ]
 802   ];
 803
 804   (* Field used in the BITSTRING constructor (an expression). *)
 805   constr_field: [
 806     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
 807       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
 808         parse_field _loc fexpr len qs expr_printer
 809     ]
 810   ];
 811
 812   (* 'bitmatch' expressions. *)
 813   expr: LEVEL ";" [
 814     [ "bitmatch";
 815       bs = expr; "with"; OPT "|";
 816       cases = LIST1 match_case SEP "|" ->
 817         output_bitmatch _loc bs cases
 818     ]
 819
 820   (* Constructor. *)
 821   | [ "BITSTRING"; "{";
 822       fields = LIST0 constr_field SEP ";";
 823       "}" ->
 824         output_constructor _loc fields
 825     ]
 826   ];
 827
 828 END