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