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