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