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