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