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