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$ $`int:i$
 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             let j = i lsr 3 in
 339             <:expr<
 340               let $lid:bs$ = $fexpr$ in
 341               if String.length $lid:bs$ = $`int:j$ then
 342                 Bitmatch.construct_string $lid:buffer$ $lid:bs$
 343               else
 344                 raise (Bitmatch.Construct_failure
 345                          ("length of string does not match declaration",
 346                           $str:loc_fname$,
 347                           $int:loc_line$, $int:loc_char$))
 348             >>
 349
 350         (* String, constant length -1, means variable length string
 351          * with no checks.
 352          *)
 353         | String, Some (-1) ->
 354             <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
 355
 356         (* String, constant length = 0 is probably an error, and so is
 357          * any other value.
 358          *)
 359         | String, Some _ ->
 360             Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
 361
 362         (* String, non-constant length.
 363          * We check at runtime that the length is > 0, a multiple of 8,
 364          * and matches the declared length.
 365          *)
 366         | String, None ->
 367             let bslen = gensym "bslen" in
 368             let bs = gensym "bs" in
 369             <:expr<
 370               let $lid:bslen$ = $flen$ in
 371               if $lid:bslen$ > 0 then (
 372                 if $lid:bslen$ land 7 = 0 then (
 373                   let $lid:bs$ = $fexpr$ in
 374                   if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
 375                     Bitmatch.construct_string $lid:buffer$ $lid:bs$
 376                   else
 377                     raise (Bitmatch.Construct_failure
 378                              ("length of string does not match declaration",
 379                               $str:loc_fname$,
 380                               $int:loc_line$, $int:loc_char$))
 381                 ) else
 382                   raise (Bitmatch.Construct_failure
 383                            ("length of string must be a multiple of 8",
 384                             $str:loc_fname$,
 385                             $int:loc_line$, $int:loc_char$))
 386               ) else
 387                 raise (Bitmatch.Construct_failure
 388                          ("length of string must be > 0",
 389                           $str:loc_fname$,
 390                           $int:loc_line$, $int:loc_char$))
 391             >>
 392
 393         (* Bitstring, constant length > 0. *)
 394         | Bitstring, Some i when i > 0 ->
 395             let bs = gensym "bs" in
 396             <:expr<
 397               let $lid:bs$ = $fexpr$ in
 398               if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
 399                 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
 400               else
 401                 raise (Bitmatch.Construct_failure
 402                          ("length of bitstring does not match declaration",
 403                           $str:loc_fname$,
 404                           $int:loc_line$, $int:loc_char$))
 405             >>
 406
 407         (* Bitstring, constant length -1, means variable length bitstring
 408          * with no checks.
 409          *)
 410         | Bitstring, Some (-1) ->
 411             <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
 412
 413         (* Bitstring, constant length = 0 is probably an error, and so is
 414          * any other value.
 415          *)
 416         | Bitstring, Some _ ->
 417             Loc.raise _loc
 418               (Failure
 419                  "length of bitstring must be > 0 or the special value -1")
 420
 421         (* Bitstring, non-constant length.
 422          * We check at runtime that the length is > 0 and matches
 423          * the declared length.
 424          *)
 425         | Bitstring, None ->
 426             let bslen = gensym "bslen" in
 427             let bs = gensym "bs" in
 428             <:expr<
 429               let $lid:bslen$ = $flen$ in
 430               if $lid:bslen$ > 0 then (
 431                 let $lid:bs$ = $fexpr$ in
 432                 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
 433                   Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
 434                 else
 435                   raise (Bitmatch.Construct_failure
 436                            ("length of bitstring does not match declaration",
 437                             $str:loc_fname$,
 438                             $int:loc_line$, $int:loc_char$))
 439               ) else
 440                 raise (Bitmatch.Construct_failure
 441                          ("length of bitstring must be > 0",
 442                           $str:loc_fname$,
 443                           $int:loc_line$, $int:loc_char$))
 444             >> in
 445       expr
 446   ) fields in
 447
 448   (* Create the final bitstring.  Start by creating an empty buffer
 449    * and then evaluate each expression above in turn which will
 450    * append some more to the bitstring buffer.  Finally extract
 451    * the bitstring.
 452    *
 453    * XXX We almost have enough information to be able to guess
 454    * a good initial size for the buffer.
 455    *)
 456   let fields =
 457     match fields with
 458     | [] -> <:expr< [] >>
 459     | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
 460
 461   let expr =
 462     <:expr<
 463       let $lid:buffer$ = Bitmatch.Buffer.create () in
 464       $fields$;
 465       Bitmatch.Buffer.contents $lid:buffer$
 466     >> in
 467
 468   if !exn_used then
 469     <:expr<
 470       let $lid:exn$ =
 471         Bitmatch.Construct_failure ("value out of range",
 472                                     $str:loc_fname$,
 473                                     $int:loc_line$, $int:loc_char$) in
 474         $expr$
 475     >>
 476   else
 477     expr
 478
 479 (* Generate the code for a bitmatch statement.  '_loc' is the
 480  * location, 'bs' is the bitstring parameter, 'cases' are
 481  * the list of cases to test against.
 482  *)
 483 let output_bitmatch _loc bs cases =
 484   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
 485   let result = gensym "result" in
 486
 487   (* This generates the field extraction code for each
 488    * field a single case.  Each field must be wider than
 489    * the minimum permitted for the type and there must be
 490    * enough remaining data in the bitstring to satisfy it.
 491    * As we go through the fields, symbols 'data', 'off' and 'len'
 492    * track our position and remaining length in the bitstring.
 493    *
 494    * The whole thing is a lot of nested 'if' statements. Code
 495    * is generated from the inner-most (last) field outwards.
 496    *)
 497   let rec output_field_extraction inner = function
 498     | [] -> inner
 499     | field :: fields ->
 500         let {field=fpatt; flen=flen; endian=endian; signed=signed;
 501              t=t; _loc=_loc}
 502             = field in
 503
 504         (* Is flen an integer constant?  If so, what is it?  This
 505          * is very simple-minded and only detects simple constants.
 506          *)
 507         let flen_is_const = expr_is_constant flen in
 508
 509         let name_of_int_extract_const = function
 510             (* XXX As an enhancement we should allow a 64-bit-only
 511              * mode which lets us use 'int' up to 63 bits and won't
 512              * compile on 32-bit platforms.
 513              *)
 514             (* XXX The meaning of signed/unsigned breaks down at
 515              * 31, 32, 63 and 64 bits.
 516              *)
 517           | (1, _, _) -> "extract_bit"
 518           | ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
 519           | ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
 520           | (i, Bitmatch.BigEndian, false) when i <= 31 ->
 521               "extract_int_be_unsigned"
 522           | (i, Bitmatch.BigEndian, true) when i <= 31 ->
 523               "extract_int_be_signed"
 524           | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
 525               "extract_int_le_unsigned"
 526           | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
 527               "extract_int_le_signed"
 528           | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
 529               "extract_int_ne_unsigned"
 530           | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
 531               "extract_int_ne_signed"
 532           | (32, Bitmatch.BigEndian, false) -> "extract_int32_be_unsigned"
 533           | (32, Bitmatch.BigEndian, true) -> "extract_int32_be_signed"
 534           | (32, Bitmatch.LittleEndian, false) -> "extract_int32_le_unsigned"
 535           | (32, Bitmatch.LittleEndian, true) -> "extract_int32_le_signed"
 536           | (32, Bitmatch.NativeEndian, false) -> "extract_int32_ne_unsigned"
 537           | (32, Bitmatch.NativeEndian, true) -> "extract_int32_ne_signed"
 538           | (_, Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
 539           | (_, Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
 540           | (_, Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
 541           | (_, Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
 542           | (_, Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
 543           | (_, Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
 544         in
 545         let name_of_int_extract = function
 546             (* XXX As an enhancement we should allow users to
 547              * specify that a field length can fit into a char/int/int32
 548              * (of course, this would have to be checked at runtime).
 549              *)
 550           | (Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
 551           | (Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
 552           | (Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
 553           | (Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
 554           | (Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
 555           | (Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
 556         in
 557
 558         let expr =
 559           match t, flen_is_const with
 560           (* Common case: int field, constant flen *)
 561           | Int, Some i when i > 0 && i <= 64 ->
 562               let extract_func = name_of_int_extract_const (i,endian,signed) in
 563               let v = gensym "val" in
 564               <:expr<
 565                 if $lid:len$ >= $`int:i$ then (
 566                   let $lid:v$, $lid:off$, $lid:len$ =
 567                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 568                       $`int:i$ in
 569                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 570                 )
 571               >>
 572
 573           | Int, Some _ ->
 574               Loc.raise _loc (Failure "length of int field must be [1..64]")
 575
 576           (* Int field, non-const flen.  We have to test the range of
 577            * the field at runtime.  If outside the range it's a no-match
 578            * (not an error).
 579            *)
 580           | Int, None ->
 581               let extract_func = name_of_int_extract (endian,signed) in
 582               let v = gensym "val" in
 583               <:expr<
 584                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
 585                   let $lid:v$, $lid:off$, $lid:len$ =
 586                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 587                       $flen$ in
 588                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
 589                 )
 590               >>
 591
 592           (* String, constant flen > 0. *)
 593           | String, Some i when i > 0 && i land 7 = 0 ->
 594               let bs = gensym "bs" in
 595               <:expr<
 596                 if $lid:len$ >= $`int:i$ then (
 597                   let $lid:bs$, $lid:off$, $lid:len$ =
 598                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 599                       $`int:i$ in
 600                   match Bitmatch.string_of_bitstring $lid:bs$ with
 601                   | $fpatt$ when true -> $inner$
 602                   | _ -> ()
 603                 )
 604               >>
 605
 606           (* String, constant flen = -1, means consume all the
 607            * rest of the input.
 608            *)
 609           | String, Some i when i = -1 ->
 610               let bs = gensym "bs" in
 611               <:expr<
 612                 let $lid:bs$, $lid:off$, $lid:len$ =
 613                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 614                 match Bitmatch.string_of_bitstring $lid:bs$ with
 615                 | $fpatt$ when true -> $inner$
 616                 | _ -> ()
 617               >>
 618
 619           | String, Some _ ->
 620               Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
 621
 622           (* String field, non-const flen.  We check the flen is > 0
 623            * and a multiple of 8 (-1 is not allowed here), at runtime.
 624            *)
 625           | String, None ->
 626               let bs = gensym "bs" in
 627               <:expr<
 628                 if $flen$ >= 0 && $flen$ <= $lid:len$
 629                   && $flen$ land 7 = 0 then (
 630                     let $lid:bs$, $lid:off$, $lid:len$ =
 631                       Bitmatch.extract_bitstring
 632                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
 633                     match Bitmatch.string_of_bitstring $lid:bs$ with
 634                     | $fpatt$ when true -> $inner$
 635                     | _ -> ()
 636                   )
 637               >>
 638
 639           (* Bitstring, constant flen >= 0.
 640            * At the moment all we can do is assign the bitstring to an
 641            * identifier.
 642            *)
 643           | Bitstring, Some i when i >= 0 ->
 644               let ident =
 645                 match fpatt with
 646                 | <:patt< $lid:ident$ >> -> ident
 647                 | <:patt< _ >> -> "_"
 648                 | _ ->
 649                     Loc.raise _loc
 650                       (Failure "cannot compare a bitstring to a constant") in
 651               <:expr<
 652                 if $lid:len$ >= $`int:i$ then (
 653                   let $lid:ident$, $lid:off$, $lid:len$ =
 654                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 655                       $`int:i$ in
 656                   $inner$
 657                 )
 658               >>
 659
 660           (* Bitstring, constant flen = -1, means consume all the
 661            * rest of the input.
 662            *)
 663           | Bitstring, Some i when i = -1 ->
 664               let ident =
 665                 match fpatt with
 666                 | <:patt< $lid:ident$ >> -> ident
 667                 | <:patt< _ >> -> "_"
 668                 | _ ->
 669                     Loc.raise _loc
 670                       (Failure "cannot compare a bitstring to a constant") in
 671               <:expr<
 672                 let $lid:ident$, $lid:off$, $lid:len$ =
 673                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 674                   $inner$
 675               >>
 676
 677           | Bitstring, Some _ ->
 678               Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
 679
 680           (* Bitstring field, non-const flen.  We check the flen is >= 0
 681            * (-1 is not allowed here) at runtime.
 682            *)
 683           | Bitstring, None ->
 684               let ident =
 685                 match fpatt with
 686                 | <:patt< $lid:ident$ >> -> ident
 687                 | <:patt< _ >> -> "_"
 688                 | _ ->
 689                     Loc.raise _loc
 690                       (Failure "cannot compare a bitstring to a constant") in
 691               <:expr<
 692                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
 693                   let $lid:ident$, $lid:off$, $lid:len$ =
 694                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 695                       $flen$ in
 696                   $inner$
 697                 )
 698               >>
 699         in
 700
 701         (* Emit extra debugging code. *)
 702         let expr =
 703           if not debug then expr else (
 704             let field = string_of_field field in
 705
 706             <:expr<
 707               if !Bitmatch.debug then (
 708                 Printf.eprintf "PA_BITMATCH: TEST:\n";
 709                 Printf.eprintf "  %s\n" $str:field$;
 710                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
 711                 (*Bitmatch.hexdump_bitstring stderr
 712                   ($lid:data$,$lid:off$,$lid:len$);*)
 713               );
 714               $expr$
 715             >>
 716           ) in
 717
 718         output_field_extraction expr fields
 719   in
 720
 721   (* Convert each case in the match. *)
 722   let cases = List.map (
 723     fun (fields, bind, whenclause, code) ->
 724       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
 725       let inner =
 726         match whenclause with
 727         | Some whenclause ->
 728             <:expr< if $whenclause$ then $inner$ >>
 729         | None -> inner in
 730       let inner =
 731         match bind with
 732         | Some name ->
 733             <:expr<
 734               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
 735               $inner$
 736               >>
 737         | None -> inner in
 738       output_field_extraction inner (List.rev fields)
 739   ) cases in
 740
 741   (* Join them into a single expression.
 742    *
 743    * Don't do it with a normal fold_right because that leaves
 744    * 'raise Exit; ()' at the end which causes a compiler warning.
 745    * Hence a bit of complexity here.
 746    *
 747    * Note that the number of cases is always >= 1 so List.hd is safe.
 748    *)
 749   let cases = List.rev cases in
 750   let cases =
 751     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
 752       (List.hd cases) (List.tl cases) in
 753
 754   (* The final code just wraps the list of cases in a
 755    * try/with construct so that each case is tried in
 756    * turn until one case matches (that case sets 'result'
 757    * and raises 'Exit' to leave the whole statement).
 758    * If result isn't set by the end then we will raise
 759    * Match_failure with the location of the bitmatch
 760    * statement in the original code.
 761    *)
 762   let loc_fname = Loc.file_name _loc in
 763   let loc_line = string_of_int (Loc.start_line _loc) in
 764   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 765
 766   <:expr<
 767     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
 768     let $lid:result$ = ref None in
 769     (try
 770       $cases$
 771     with Exit -> ());
 772     match ! $lid:result$ with
 773     | Some x -> x
 774     | None -> raise (Match_failure ($str:loc_fname$,
 775                                     $int:loc_line$, $int:loc_char$))
 776   >>
 777
 778 EXTEND Gram
 779   GLOBAL: expr;
 780
 781   qualifiers: [
 782     [ LIST0 [ q = LIDENT -> q ] SEP "," ]
 783   ];
 784
 785   (* Field used in the bitmatch operator (a pattern). *)
 786   patt_field: [
 787     [ fpatt = patt; ":"; len = expr LEVEL "top";
 788       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
 789         parse_field _loc fpatt len qs patt_printer
 790     ]
 791   ];
 792
 793   (* Case inside bitmatch operator. *)
 794   match_case: [
 795     [ "{";
 796       fields = LIST0 patt_field SEP ";";
 797       "}";
 798       bind = OPT [ "as"; name = LIDENT -> name ];
 799       whenclause = OPT [ "when"; e = expr -> e ]; "->";
 800       code = expr ->
 801         (fields, bind, whenclause, code)
 802     ]
 803   ];
 804
 805   (* Field used in the BITSTRING constructor (an expression). *)
 806   constr_field: [
 807     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
 808       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
 809         parse_field _loc fexpr len qs expr_printer
 810     ]
 811   ];
 812
 813   (* 'bitmatch' expressions. *)
 814   expr: LEVEL ";" [
 815     [ "bitmatch";
 816       bs = expr; "with"; OPT "|";
 817       cases = LIST1 match_case SEP "|" ->
 818         output_bitmatch _loc bs cases
 819     ]
 820
 821   (* Constructor. *)
 822   | [ "BITSTRING"; "{";
 823       fields = LIST0 constr_field SEP ";";
 824       "}" ->
 825         output_constructor _loc fields
 826     ]
 827   ];
 828
 829 END