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