Enable svn:keywords Id property on relevant files.
[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 (* 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 : Bitmatch.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 t = Int | String | Bitstring
84
85 (* Generate a fresh, unique symbol each time called. *)
86 let gensym =
87   let i = ref 1000 in
88   fun name ->
89     incr i; let i = !i in
90     sprintf "__pabitmatch_%s_%d" name i
91
92 (* Deal with the qualifiers which appear for a field of both types. *)
93 let parse_field _loc field flen qs printer =
94   let endian, signed, t =
95     match qs with
96     | None -> (None, None, None)
97     | Some qs ->
98         List.fold_left (
99           fun (endian, signed, t) q ->
100             match q with
101             | "bigendian" ->
102                 if endian <> None then
103                   Loc.raise _loc (Failure "an endian flag has been set already")
104                 else (
105                   let endian = Some Bitmatch.BigEndian in
106                   (endian, signed, t)
107                 )
108             | "littleendian" ->
109                 if endian <> None then
110                   Loc.raise _loc (Failure "an endian flag has been set already")
111                 else (
112                   let endian = Some Bitmatch.LittleEndian in
113                   (endian, signed, t)
114                 )
115             | "nativeendian" ->
116                 if endian <> None then
117                   Loc.raise _loc (Failure "an endian flag has been set already")
118                 else (
119                   let endian = Some Bitmatch.NativeEndian in
120                   (endian, signed, t)
121                 )
122             | "signed" ->
123                 if signed <> None then
124                   Loc.raise _loc (Failure "a signed flag has been set already")
125                 else (
126                   let signed = Some true in
127                   (endian, signed, t)
128                 )
129             | "unsigned" ->
130                 if signed <> None then
131                   Loc.raise _loc (Failure "a signed flag has been set already")
132                 else (
133                   let signed = Some false in
134                   (endian, signed, t)
135                 )
136             | "int" ->
137                 if t <> None then
138                   Loc.raise _loc (Failure "a type flag has been set already")
139                 else (
140                   let t = Some Int in
141                   (endian, signed, t)
142                 )
143             | "string" ->
144                 if t <> None then
145                   Loc.raise _loc (Failure "a type flag has been set already")
146                 else (
147                   let t = Some String in
148                   (endian, signed, t)
149                 )
150             | "bitstring" ->
151                 if t <> None then
152                   Loc.raise _loc (Failure "a type flag has been set already")
153                 else (
154                   let t = Some Bitstring in
155                   (endian, signed, t)
156                 )
157             | s ->
158                 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
159         ) (None, None, None) qs in
160
161   (* If type is set to string or bitstring then endianness and
162    * signedness qualifiers are meaningless and must not be set.
163    *)
164   if (t = Some Bitstring || t = Some String)
165     && (endian <> None || signed <> None) then
166       Loc.raise _loc (
167         Failure "string types and endian or signed qualifiers cannot be mixed"
168       );
169
170   (* Default endianness, signedness, type. *)
171   let endian = match endian with None -> Bitmatch.BigEndian | Some e -> e in
172   let signed = match signed with None -> false | Some s -> s in
173   let t = match t with None -> Int | Some t -> t in
174
175   {
176     field = field;
177     flen = flen;
178     endian = endian;
179     signed = signed;
180     t = t;
181     _loc = _loc;
182     printer = printer;
183   }
184
185 let string_of_t = function
186   | Int -> "int"
187   | String -> "string"
188   | Bitstring -> "bitstring"
189
190 let patt_printer = function
191   | <:patt< $lid:id$ >> -> id
192   | _ -> "[pattern]"
193
194 let expr_printer = function
195   | <:expr< $lid:id$ >> -> id
196   | _ -> "[expression]"
197
198 let string_of_field { field = field; flen = flen;
199                       endian = endian; signed = signed; t = t;
200                       _loc = _loc;
201                       printer = printer} =
202   let flen =
203     match expr_is_constant flen with
204     | Some i -> string_of_int i
205     | None -> "[non-const-len]" in
206   let endian = Bitmatch.string_of_endian endian in
207   let signed = if signed then "signed" else "unsigned" in
208   let t = string_of_t t in
209   let loc_fname = Loc.file_name _loc in
210   let loc_line = Loc.start_line _loc in
211   let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
212
213   sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)"
214     (printer field) flen t endian signed loc_fname loc_line loc_char
215
216 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
217 let output_constructor _loc fields =
218   let loc_fname = Loc.file_name _loc in
219   let loc_line = string_of_int (Loc.start_line _loc) in
220   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
221
222   (* Bitstrings are created like the 'Buffer' module (in fact, using
223    * the Buffer module), by appending snippets to a growing buffer.
224    * This is reasonably efficient and avoids a lot of garbage.
225    *)
226   let buffer = gensym "buffer" in
227
228   (* General exception which is raised inside the constructor functions
229    * when an int expression is out of range at runtime.
230    *)
231   let exn = gensym "exn" in
232   let exn_used = ref false in
233
234   (* Convert each field to a simple bitstring-generating expression. *)
235   let fields = List.map (
236     fun {field=fexpr; flen=flen; endian=endian; signed=signed;
237          t=t; _loc=_loc} ->
238       (* Is flen an integer constant?  If so, what is it?  This
239        * is very simple-minded and only detects simple constants.
240        *)
241       let flen_is_const = expr_is_constant flen in
242
243       let name_of_int_construct_const = function
244           (* XXX As an enhancement we should allow a 64-bit-only
245            * mode which lets us use 'int' up to 63 bits and won't
246            * compile on 32-bit platforms.
247            *)
248           (* XXX The meaning of signed/unsigned breaks down at
249            * 31, 32, 63 and 64 bits.
250            *)
251         | (1, _, _) -> "construct_bit"
252         | ((2|3|4|5|6|7|8), _, false) -> "construct_char_unsigned"
253         | ((2|3|4|5|6|7|8), _, true) -> "construct_char_signed"
254         | (i, Bitmatch.BigEndian, false) when i <= 31 ->
255             "construct_int_be_unsigned"
256         | (i, Bitmatch.BigEndian, true) when i <= 31 ->
257             "construct_int_be_signed"
258         | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
259             "construct_int_le_unsigned"
260         | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
261             "construct_int_le_signed"
262         | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
263             "construct_int_ne_unsigned"
264         | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
265             "construct_int_ne_signed"
266         | (32, Bitmatch.BigEndian, false) -> "construct_int32_be_unsigned"
267         | (32, Bitmatch.BigEndian, true) -> "construct_int32_be_signed"
268         | (32, Bitmatch.LittleEndian, false) -> "construct_int32_le_unsigned"
269         | (32, Bitmatch.LittleEndian, true) -> "construct_int32_le_signed"
270         | (32, Bitmatch.NativeEndian, false) -> "construct_int32_ne_unsigned"
271         | (32, Bitmatch.NativeEndian, true) -> "construct_int32_ne_signed"
272         | (_, Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
273         | (_, Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
274         | (_, Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
275         | (_, Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
276         | (_, Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
277         | (_, Bitmatch.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         | (Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
285         | (Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
286         | (Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
287         | (Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
288         | (Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
289         | (Bitmatch.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, Bitmatch.BigEndian, false) when i <= 31 ->
520               "extract_int_be_unsigned"
521           | (i, Bitmatch.BigEndian, true) when i <= 31 ->
522               "extract_int_be_signed"
523           | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
524               "extract_int_le_unsigned"
525           | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
526               "extract_int_le_signed"
527           | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
528               "extract_int_ne_unsigned"
529           | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
530               "extract_int_ne_signed"
531           | (32, Bitmatch.BigEndian, false) -> "extract_int32_be_unsigned"
532           | (32, Bitmatch.BigEndian, true) -> "extract_int32_be_signed"
533           | (32, Bitmatch.LittleEndian, false) -> "extract_int32_le_unsigned"
534           | (32, Bitmatch.LittleEndian, true) -> "extract_int32_le_signed"
535           | (32, Bitmatch.NativeEndian, false) -> "extract_int32_ne_unsigned"
536           | (32, Bitmatch.NativeEndian, true) -> "extract_int32_ne_signed"
537           | (_, Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
538           | (_, Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
539           | (_, Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
540           | (_, Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
541           | (_, Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
542           | (_, Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
543         in
544         let name_of_int_extract = function
545             (* XXX As an enhancement we should allow users to
546              * specify that a field length can fit into a char/int/int32
547              * (of course, this would have to be checked at runtime).
548              *)
549           | (Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
550           | (Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
551           | (Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
552           | (Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
553           | (Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
554           | (Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
555         in
556
557         let expr =
558           match t, flen_is_const with
559           (* Common case: int field, constant flen *)
560           | Int, Some i when i > 0 && i <= 64 ->
561               let extract_func = name_of_int_extract_const (i,endian,signed) in
562               let v = gensym "val" in
563               <:expr<
564                 if $lid:len$ >= $flen$ then (
565                   let $lid:v$, $lid:off$, $lid:len$ =
566                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
567                       $flen$ in
568                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
569                 )
570               >>
571
572           | Int, Some _ ->
573               Loc.raise _loc (Failure "length of int field must be [1..64]")
574
575           (* Int field, non-const flen.  We have to test the range of
576            * the field at runtime.  If outside the range it's a no-match
577            * (not an error).
578            *)
579           | Int, None ->
580               let extract_func = name_of_int_extract (endian,signed) in
581               let v = gensym "val" in
582               <:expr<
583                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
584                   let $lid:v$, $lid:off$, $lid:len$ =
585                     Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
586                       $flen$ in
587                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
588                 )
589               >>
590
591           (* String, constant flen > 0. *)
592           | String, Some i when i > 0 && i land 7 = 0 ->
593               let bs = gensym "bs" in
594               <:expr<
595                 if $lid:len$ >= $flen$ then (
596                   let $lid:bs$, $lid:off$, $lid:len$ =
597                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
598                       $flen$ in
599                   match Bitmatch.string_of_bitstring $lid:bs$ with
600                   | $fpatt$ when true -> $inner$
601                   | _ -> ()
602                 )
603               >>
604
605           (* String, constant flen = -1, means consume all the
606            * rest of the input.
607            *)
608           | String, Some i when i = -1 ->
609               let bs = gensym "bs" in
610               <:expr<
611                 let $lid:bs$, $lid:off$, $lid:len$ =
612                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
613                 match Bitmatch.string_of_bitstring $lid:bs$ with
614                 | $fpatt$ when true -> $inner$
615                 | _ -> ()
616               >>
617
618           | String, Some _ ->
619               Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
620
621           (* String field, non-const flen.  We check the flen is > 0
622            * and a multiple of 8 (-1 is not allowed here), at runtime.
623            *)
624           | String, None ->
625               let bs = gensym "bs" in
626               <:expr<
627                 if $flen$ >= 0 && $flen$ <= $lid:len$
628                   && $flen$ land 7 = 0 then (
629                     let $lid:bs$, $lid:off$, $lid:len$ =
630                       Bitmatch.extract_bitstring
631                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
632                     match Bitmatch.string_of_bitstring $lid:bs$ with
633                     | $fpatt$ when true -> $inner$
634                     | _ -> ()
635                   )
636               >>
637
638           (* Bitstring, constant flen >= 0.
639            * At the moment all we can do is assign the bitstring to an
640            * identifier.
641            *)
642           | Bitstring, Some i when i >= 0 ->
643               let ident =
644                 match fpatt with
645                 | <:patt< $lid:ident$ >> -> ident
646                 | <:patt< _ >> -> "_"
647                 | _ ->
648                     Loc.raise _loc
649                       (Failure "cannot compare a bitstring to a constant") in
650               <:expr<
651                 if $lid:len$ >= $flen$ then (
652                   let $lid:ident$, $lid:off$, $lid:len$ =
653                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
654                       $flen$ in
655                   $inner$
656                 )
657               >>
658
659           (* Bitstring, constant flen = -1, means consume all the
660            * rest of the input.
661            *)
662           | Bitstring, Some i when i = -1 ->
663               let ident =
664                 match fpatt with
665                 | <:patt< $lid:ident$ >> -> ident
666                 | <:patt< _ >> -> "_"
667                 | _ ->
668                     Loc.raise _loc
669                       (Failure "cannot compare a bitstring to a constant") in
670               <:expr<
671                 let $lid:ident$, $lid:off$, $lid:len$ =
672                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
673                   $inner$
674               >>
675
676           | Bitstring, Some _ ->
677               Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
678
679           (* Bitstring field, non-const flen.  We check the flen is >= 0
680            * (-1 is not allowed here) at runtime.
681            *)
682           | Bitstring, None ->
683               let ident =
684                 match fpatt with
685                 | <:patt< $lid:ident$ >> -> ident
686                 | <:patt< _ >> -> "_"
687                 | _ ->
688                     Loc.raise _loc
689                       (Failure "cannot compare a bitstring to a constant") in
690               <:expr<
691                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
692                   let $lid:ident$, $lid:off$, $lid:len$ =
693                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
694                       $flen$ in
695                   $inner$
696                 )
697               >>
698         in
699
700         (* Emit extra debugging code. *)
701         let expr =
702           if not debug then expr else (
703             let field = string_of_field field in
704
705             <:expr<
706               if !Bitmatch.debug then (
707                 Printf.eprintf "PA_BITMATCH: TEST:\n";
708                 Printf.eprintf "  %s\n" $str:field$;
709                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
710                 (*Bitmatch.hexdump_bitstring stderr
711                   ($lid:data$,$lid:off$,$lid:len$);*)
712               );
713               $expr$
714             >>
715           ) in
716
717         output_field_extraction expr fields
718   in
719
720   (* Convert each case in the match. *)
721   let cases = List.map (
722     fun (fields, bind, whenclause, code) ->
723       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
724       let inner =
725         match whenclause with
726         | Some whenclause ->
727             <:expr< if $whenclause$ then $inner$ >>
728         | None -> inner in
729       let inner =
730         match bind with
731         | Some name ->
732             <:expr<
733               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
734               $inner$
735               >>
736         | None -> inner in
737       output_field_extraction inner (List.rev fields)
738   ) cases in
739
740   (* Join them into a single expression.
741    *
742    * Don't do it with a normal fold_right because that leaves
743    * 'raise Exit; ()' at the end which causes a compiler warning.
744    * Hence a bit of complexity here.
745    *
746    * Note that the number of cases is always >= 1 so List.hd is safe.
747    *)
748   let cases = List.rev cases in
749   let cases =
750     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
751       (List.hd cases) (List.tl cases) in
752
753   (* The final code just wraps the list of cases in a
754    * try/with construct so that each case is tried in
755    * turn until one case matches (that case sets 'result'
756    * and raises 'Exit' to leave the whole statement).
757    * If result isn't set by the end then we will raise
758    * Match_failure with the location of the bitmatch
759    * statement in the original code.
760    *)
761   let loc_fname = Loc.file_name _loc in
762   let loc_line = string_of_int (Loc.start_line _loc) in
763   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
764
765   <:expr<
766     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
767     let $lid:result$ = ref None in
768     (try
769       $cases$
770     with Exit -> ());
771     match ! $lid:result$ with
772     | Some x -> x
773     | None -> raise (Match_failure ($str:loc_fname$,
774                                     $int:loc_line$, $int:loc_char$))
775   >>
776
777 EXTEND Gram
778   GLOBAL: expr;
779
780   qualifiers: [
781     [ LIST0 [ q = LIDENT -> q ] SEP "," ]
782   ];
783
784   (* Field used in the bitmatch operator (a pattern). *)
785   patt_field: [
786     [ fpatt = patt; ":"; len = expr LEVEL "top";
787       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
788         parse_field _loc fpatt len qs patt_printer
789     ]
790   ];
791
792   (* Case inside bitmatch operator. *)
793   match_case: [
794     [ "{";
795       fields = LIST0 patt_field SEP ";";
796       "}";
797       bind = OPT [ "as"; name = LIDENT -> name ];
798       whenclause = OPT [ "when"; e = expr -> e ]; "->";
799       code = expr ->
800         (fields, bind, whenclause, code)
801     ]
802   ];
803
804   (* Field used in the BITSTRING constructor (an expression). *)
805   constr_field: [
806     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
807       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
808         parse_field _loc fexpr len qs expr_printer
809     ]
810   ];
811
812   (* 'bitmatch' expressions. *)
813   expr: LEVEL ";" [
814     [ "bitmatch";
815       bs = expr; "with"; OPT "|";
816       cases = LIST1 match_case SEP "|" ->
817         output_bitmatch _loc bs cases
818     ]
819
820   (* Constructor. *)
821   | [ "BITSTRING"; "{";
822       fields = LIST0 constr_field SEP ";";
823       "}" ->
824         output_constructor _loc fields
825     ]
826   ];
827
828 END