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