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