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