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