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