pa_bitmatch.ml

   1 (* Bitmatch syntax extension.
   2  * $Id: pa_bitmatch.ml,v 1.3 2008-04-01 10:05:14 rjones Exp $
   3  *)
   4
   5 open Printf
   6
   7 open Camlp4.PreCast
   8 open Syntax
   9 open Ast
  10
  11 type m = Fields of f list               (* field ; field -> ... *)
  12        | Bind of string option          (* _ -> ... *)
  13 and f = {
  14   ident : string;                       (* field name *)
  15   flen : expr;                          (* length in bits, may be non-const *)
  16   endian : endian;                      (* endianness *)
  17   signed : bool;                        (* true if signed, false if unsigned *)
  18   t : t;                                (* type *)
  19 }
  20 and endian = BigEndian | LittleEndian | NativeEndian
  21 and t = Int | Bitstring
  22
  23 (* Generate a fresh, unique symbol each time called. *)
  24 let gensym =
  25   let i = ref 1000 in
  26   fun name ->
  27     incr i; let i = !i in
  28     sprintf "__pabitmatch_%s_%d" name i
  29
  30 (* Deal with the qualifiers which appear for a field. *)
  31 let output_field _loc name flen qs =
  32   let endian, signed, t =
  33     match qs with
  34     | None -> (None, None, None)
  35     | Some qs ->
  36         List.fold_left (
  37           fun (endian, signed, t) q ->
  38             match q with
  39             | "bigendian" ->
  40                 if endian <> None then
  41                   Loc.raise _loc (Failure "an endian flag has been set already")
  42                 else (
  43                   let endian = Some BigEndian in
  44                   (endian, signed, t)
  45                 )
  46             | "littleendian" ->
  47                 if endian <> None then
  48                   Loc.raise _loc (Failure "an endian flag has been set already")
  49                 else (
  50                   let endian = Some LittleEndian in
  51                   (endian, signed, t)
  52                 )
  53             | "nativeendian" ->
  54                 if endian <> None then
  55                   Loc.raise _loc (Failure "an endian flag has been set already")
  56                 else (
  57                   let endian = Some NativeEndian in
  58                   (endian, signed, t)
  59                 )
  60             | "signed" ->
  61                 if signed <> None then
  62                   Loc.raise _loc (Failure "a signed flag has been set already")
  63                 else (
  64                   let signed = Some true in
  65                   (endian, signed, t)
  66                 )
  67             | "unsigned" ->
  68                 if signed <> None then
  69                   Loc.raise _loc (Failure "a signed flag has been set already")
  70                 else (
  71                   let signed = Some false in
  72                   (endian, signed, t)
  73                 )
  74             | "int" ->
  75                 if t <> None then
  76                   Loc.raise _loc (Failure "a type flag has been set already")
  77                 else (
  78                   let t = Some Int in
  79                   (endian, signed, t)
  80                 )
  81             | "bitstring" ->
  82                 if t <> None then
  83                   Loc.raise _loc (Failure "a type flag has been set already")
  84                 else (
  85                   let t = Some Bitstring in
  86                   (endian, signed, t)
  87                 )
  88             | s ->
  89                 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
  90         ) (None, None, None) qs in
  91
  92   (* If type is set to bitstring then endianness and signedness
  93    * qualifiers are meaningless and must not be set.
  94    *)
  95   if t = Some Bitstring && (endian <> None || signed <> None) then
  96     Loc.raise _loc (
  97       Failure "bitstring type and endian or signed qualifiers cannot be mixed"
  98     );
  99
 100   (* Default endianness, signedness, type. *)
 101   let endian = match endian with None -> BigEndian | Some e -> e in
 102   let signed = match signed with None -> false | Some s -> s in
 103   let t = match t with None -> Int | Some t -> t in
 104
 105   {
 106     ident = name;
 107     flen = flen;
 108     endian = endian;
 109     signed = signed;
 110     t = t;
 111   }
 112
 113 (* Generate the code for a bitmatch statement.  '_loc' is the
 114  * location, 'bs' is the bitstring parameter, 'cases' are
 115  * the list of cases to test against.
 116  *)
 117 let output_bitmatch _loc bs cases =
 118   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
 119   let result = gensym "result" in
 120
 121   (* This generates the field extraction code for each
 122    * field a single case.  Each field must be wider than
 123    * the minimum permitted for the type and there must be
 124    * enough remaining data in the bitstring to satisfy it.
 125    * As we go through the fields, symbols 'data', 'off' and 'len'
 126    * track our position and remaining length in the bitstring.
 127    *
 128    * The whole thing is a lot of nested 'if' statements. Code
 129    * is generated from the inner-most (last) field outwards.
 130    *)
 131   let rec output_field_extraction inner = function
 132     | [] -> inner
 133     | {ident=ident; flen=flen; endian=endian; signed=signed; t=t} :: fields ->
 134         (* If length an integer constant?  If so, what is it?  This
 135          * is very simple-minded and only detects simple constants.
 136          *)
 137         let flen_is_const =
 138           match flen with
 139           | <:expr< $int:i$ >> -> Some (int_of_string i)
 140           | _ -> None in
 141
 142         let name_of_int_extract_const = function
 143             (* XXX As an enhancement we should allow a 64-bit-only
 144              * mode which lets us use 'int' up to 63 bits and won't
 145              * compile on 32-bit platforms.
 146              *)
 147             (* XXX The meaning of signed/unsigned breaks down at
 148              * 31, 32, 63 and 64 bits.
 149              *)
 150           | (1, _, _) -> "extract_bit"
 151           | ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
 152           | ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
 153           | (i, BigEndian, false) when i <= 31 -> "extract_int_be_unsigned"
 154           | (i, BigEndian, true) when i <= 31 -> "extract_int_be_signed"
 155           | (i, LittleEndian, false) when i <= 31 -> "extract_int_le_unsigned"
 156           | (i, LittleEndian, true) when i <= 31 -> "extract_int_le_signed"
 157           | (i, NativeEndian, false) when i <= 31 -> "extract_int_ne_unsigned"
 158           | (i, NativeEndian, true) when i <= 31 -> "extract_int_ne_signed"
 159           | (32, BigEndian, false) -> "extract_int32_be_unsigned"
 160           | (32, BigEndian, true) -> "extract_int32_be_signed"
 161           | (32, LittleEndian, false) -> "extract_int32_le_unsigned"
 162           | (32, LittleEndian, true) -> "extract_int32_le_signed"
 163           | (32, NativeEndian, false) -> "extract_int32_ne_unsigned"
 164           | (32, NativeEndian, true) -> "extract_int32_ne_signed"
 165           | (_, BigEndian, false) -> "extract_int64_be_unsigned"
 166           | (_, BigEndian, true) -> "extract_int64_be_signed"
 167           | (_, LittleEndian, false) -> "extract_int64_le_unsigned"
 168           | (_, LittleEndian, true) -> "extract_int64_le_signed"
 169           | (_, NativeEndian, false) -> "extract_int64_ne_unsigned"
 170           | (_, NativeEndian, true) -> "extract_int64_ne_signed"
 171         in
 172         let name_of_int_extract = function
 173             (* XXX As an enhancement we should allow users to
 174              * specify that a field length can fit into a char/int/int32
 175              * (of course, this would have to be checked at runtime).
 176              *)
 177           | (BigEndian, false) -> "extract_int64_be_unsigned"
 178           | (BigEndian, true) -> "extract_int64_be_signed"
 179           | (LittleEndian, false) -> "extract_int64_le_unsigned"
 180           | (LittleEndian, true) -> "extract_int64_le_signed"
 181           | (NativeEndian, false) -> "extract_int64_ne_unsigned"
 182           | (NativeEndian, true) -> "extract_int64_ne_signed"
 183         in
 184
 185         let expr =
 186           match t, flen_is_const with
 187           (* Common case: int field, constant flen *)
 188           | Int, Some i when i > 0 && i <= 64 ->
 189               let extract_func = name_of_int_extract_const (i,endian,signed) in
 190               <:expr<
 191                 if $lid:len$ >= $flen$ then (
 192                   let $lid:ident$, $lid:off$, $lid:len$ =
 193                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 194                       $flen$ in
 195                   $inner$
 196                 )
 197               >>
 198
 199           | Int, Some _ ->
 200               Loc.raise _loc (Failure "length of int field must be [1..64]")
 201
 202           (* Int field, non-const flen.  We have to test the range of
 203            * the field at runtime.  If outside the range it's a no-match
 204            * (not an error).
 205            *)
 206           | Int, None ->
 207               let extract_func = name_of_int_extract (endian,signed) in
 208               <:expr<
 209                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ >= $lid:len$ then (
 210                   let $lid:ident$, $lid:off$, $lid:len$ =
 211                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
 212                       $flen$ in
 213                   $inner$
 214                 )
 215               >>
 216
 217           (* Bitstring, constant flen >= 0. *)
 218           | Bitstring, Some i when i >= 0 ->
 219               <:expr<
 220                 if $lid:len$ >= $flen$ then (
 221                   let $lid:ident$, $lid:off$, $lid:len$ =
 222                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 223                       $flen$ in
 224                   $inner$
 225                 )
 226               >>
 227
 228           (* Bitstring, constant flen = -1, means consume all the
 229            * rest of the input.
 230            *)
 231           | Bitstring, Some i when i = -1 ->
 232               <:expr<
 233                 let $lid:ident$, $lid:off$, $lid:len$ =
 234                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
 235                   $inner$
 236               >>
 237
 238           | Bitstring, Some _ ->
 239               Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
 240
 241           (* Bitstring field, non-const flen.  We check the flen is >= 0
 242            * (-1 is not allowed here) at runtime.
 243            *)
 244           | Bitstring, None ->
 245               <:expr<
 246                 if $flen$ >= 0 && $lid:len$ >= $flen$ then (
 247                   let $lid:ident$, $lid:off$, $lid:len$ =
 248                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 249                       $flen$ in
 250                   $inner$
 251                 )
 252               >>
 253         in
 254
 255         output_field_extraction expr fields
 256   in
 257
 258   (* Convert each case in the match. *)
 259   let cases = List.map (
 260     function
 261     (* field : len ; field : len when .. -> ..*)
 262     | (Fields fields, Some whenclause, code) ->
 263         let inner =
 264           <:expr<
 265             if $whenclause$ then (
 266               $lid:result$ := Some ($code$);
 267               raise Exit
 268             )
 269           >> in
 270         output_field_extraction inner (List.rev fields)
 271
 272     (* field : len ; field : len -> ... *)
 273     | (Fields fields, None, code) ->
 274         let inner =
 275           <:expr<
 276             $lid:result$ := Some ($code$);
 277             raise Exit
 278           >> in
 279         output_field_extraction inner (List.rev fields)
 280
 281     (* _ as name when ... -> ... *)
 282     | (Bind (Some name), Some whenclause, code) ->
 283         <:expr<
 284           let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
 285           if $whenclause$ then (
 286             $lid:result$ := Some ($code$);
 287             raise Exit
 288           )
 289         >>
 290
 291     (* _ as name -> ... *)
 292     | (Bind (Some name), None, code) ->
 293         <:expr<
 294           let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
 295           $lid:result$ := Some ($code$);
 296           raise Exit
 297         >>
 298
 299     (* _ when ... -> ... *)
 300     | (Bind None, Some whenclause, code) ->
 301         <:expr<
 302           if $whenclause$ then (
 303             $lid:result$ := Some ($code$);
 304             raise Exit
 305           )
 306         >>
 307
 308     (* _ -> ... *)
 309     | (Bind None, None, code) ->
 310         <:expr<
 311           $lid:result$ := Some ($code$);
 312           raise Exit
 313         >>
 314
 315   ) cases in
 316
 317   (* Join them into a single expression.
 318    *
 319    * Don't do it with a normal fold_right because that leaves
 320    * 'raise Exit; ()' at the end which causes a compiler warning.
 321    * Hence a bit of complexity here.
 322    *
 323    * Note that the number of cases is always >= 1 so List.hd is safe.
 324    *)
 325   let cases = List.rev cases in
 326   let cases =
 327     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
 328       (List.hd cases) (List.tl cases) in
 329
 330   (* The final code just wraps the list of cases in a
 331    * try/with construct so that each case is tried in
 332    * turn until one case matches (that case sets 'result'
 333    * and raises 'Exit' to leave the whole statement).
 334    * If result isn't set by the end then we will raise
 335    * Match_failure with the location of the bitmatch
 336    * statement in the original code.
 337    *)
 338   let loc_fname = Loc.file_name _loc in
 339   let loc_line = string_of_int (Loc.start_line _loc) in
 340   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
 341
 342   <:expr<
 343     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
 344     let $lid:result$ = ref None in
 345     (try
 346       $cases$
 347     with Exit -> ());
 348     match ! $lid:result$ with
 349     | Some x -> x
 350     | None -> raise (Match_failure ($str:loc_fname$,
 351                                     $int:loc_line$, $int:loc_char$))
 352   >>
 353
 354 EXTEND Gram
 355   GLOBAL: expr;
 356
 357   qualifiers: [
 358     [ LIST0 [ q = LIDENT -> q ] SEP "," ]
 359   ];
 360
 361   field: [
 362     [ name = LIDENT; ":"; len = expr LEVEL "top";
 363       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
 364         output_field _loc name len qs
 365     ]
 366   ];
 367
 368   match_case: [
 369     [ fields = LIST0 field SEP ";";
 370       w = OPT [ "when"; e = expr -> e ]; "->";
 371       code = expr ->
 372         (Fields fields, w, code)
 373     ]
 374   | [ "_";
 375       bind = OPT [ "as"; name = LIDENT -> name ];
 376       w = OPT [ "when"; e = expr -> e ]; "->";
 377       code = expr ->
 378         (Bind bind, w, code)
 379     ]
 380   ];
 381
 382   expr: LEVEL ";" [
 383     [ "bitmatch"; bs = expr; "with"; OPT "|";
 384       cases = LIST1 match_case SEP "|" ->
 385         output_bitmatch _loc bs cases
 386     ]
 387   ];
 388
 389 END