Don't allow zero-length patterns to be loaded from a file
[ocaml-bitstring.git] / pa_bitmatch.ml
1 (* Bitmatch syntax extension.
2  * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
3  *
4  * This library is free software; you can redistribute it and/or
5  * modify it under the terms of the GNU Lesser General Public
6  * License as published by the Free Software Foundation; either
7  * version 2 of the License, or (at your option) any later version.
8  *
9  * This library is distributed in the hope that it will be useful,
10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12  * Lesser General Public License for more details.
13  *
14  * You should have received a copy of the GNU Lesser General Public
15  * License along with this library; if not, write to the Free Software
16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17  *
18  * $Id$
19  *)
20
21 open Printf
22
23 open Camlp4.PreCast
24 open Syntax
25 open Ast
26
27 open Bitmatch
28 module P = Bitmatch_persistent
29
30 (* If this is true then we emit some debugging code which can
31  * be useful to tell what is happening during matches.  You
32  * also need to do 'Bitmatch.debug := true' in your main program.
33  *
34  * If this is false then no extra debugging code is emitted.
35  *)
36 let debug = false
37
38 (* Hashtable storing named persistent patterns. *)
39 let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
40
41 let locfail _loc msg = Loc.raise _loc (Failure msg)
42
43 (* Work out if an expression is an integer constant.
44  *
45  * Returns [Some i] if so (where i is the integer value), else [None].
46  *
47  * Fairly simplistic algorithm: we can only detect simple constant
48  * expressions such as [k], [k+c], [k-c] etc.
49  *)
50 let rec expr_is_constant = function
51   | <:expr< $int:i$ >> ->              (* Literal integer constant. *)
52     Some (int_of_string i)
53   | <:expr< $lid:op$ $a$ $b$ >> ->
54     (match expr_is_constant a, expr_is_constant b with
55      | Some a, Some b ->               (* Integer binary operations. *)
56          let ops = ["+", (+); "-", (-); "*", ( * ); "/", (/);
57                     "land", (land); "lor", (lor); "lxor", (lxor);
58                     "lsl", (lsl); "lsr", (lsr); "asr", (asr);
59                     "mod", (mod)] in
60          (try Some ((List.assoc op ops) a b) with Not_found -> None)
61      | _ -> None)
62   | _ -> None
63
64 (* Generate a fresh, unique symbol each time called. *)
65 let gensym =
66   let i = ref 1000 in
67   fun name ->
68     incr i; let i = !i in
69     sprintf "__pabitmatch_%s_%d" name i
70
71 (* Deal with the qualifiers which appear for a field of both types. *)
72 let parse_field _loc field qs =
73   let fail = locfail _loc in
74
75   let endian_set, signed_set, type_set, offset_set, field =
76     match qs with
77     | None -> (false, false, false, false, field)
78     | Some qs ->
79         let check already_set msg = if already_set then fail msg in
80         let apply_qualifier
81             (endian_set, signed_set, type_set, offset_set, field) =
82           function
83           | "endian", Some expr ->
84               check endian_set "an endian flag has been set already";
85               let field = P.set_endian_expr field expr in
86               (true, signed_set, type_set, offset_set, field)
87           | "endian", None ->
88               fail "qualifier 'endian' should be followed by an expression"
89           | "offset", Some expr ->
90               check offset_set "an offset has been set already";
91               let field = P.set_offset field expr in
92               (endian_set, signed_set, type_set, true, field)
93           | "offset", None ->
94               fail "qualifier 'offset' should be followed by an expression"
95           | s, Some _ ->
96               fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
97           | qual, None ->
98               let endian_quals = ["bigendian", BigEndian;
99                                   "littleendian", LittleEndian;
100                                   "nativeendian", NativeEndian] in
101               let sign_quals = ["signed", true; "unsigned", false] in
102               let type_quals = ["int", P.set_type_int;
103                                 "string", P.set_type_string;
104                                 "bitstring", P.set_type_bitstring] in
105               if List.mem_assoc qual endian_quals then (
106                 check endian_set "an endian flag has been set already";
107                 let field = P.set_endian field (List.assoc qual endian_quals) in
108                 (true, signed_set, type_set, offset_set, field)
109               ) else if List.mem_assoc qual sign_quals then (
110                 check signed_set "a signed flag has been set already";
111                 let field = P.set_signed field (List.assoc qual sign_quals) in
112                 (endian_set, true, type_set, offset_set, field)
113               ) else if List.mem_assoc qual type_quals then (
114                 check type_set "a type flag has been set already";
115                 let field = List.assoc qual type_quals field in
116                 (endian_set, signed_set, true, offset_set, field)
117               ) else
118                 fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in
119         List.fold_left apply_qualifier (false, false, false, false, field) qs in
120
121   (* If type is set to string or bitstring then endianness and
122    * signedness qualifiers are meaningless and must not be set.
123    *)
124   let () =
125     let t = P.get_type field in
126     if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
127       fail "string types and endian or signed qualifiers cannot be mixed" in
128
129   (* Default endianness, signedness, type if not set already. *)
130   let field = if endian_set then field else P.set_endian field BigEndian in
131   let field = if signed_set then field else P.set_signed field false in
132   let field = if type_set then field else P.set_type_int field in
133
134   field
135
136 (* Choose the right constructor function. *)
137 let build_bitmatch_call _loc funcname length endian signed =
138   match length, endian, signed with
139     (* XXX The meaning of signed/unsigned breaks down at
140      * 31, 32, 63 and 64 bits.
141      *)
142   | (Some 1, _, _) -> <:expr<Bitmatch.$lid:funcname ^ "_bit"$ >>
143   | (Some (2|3|4|5|6|7|8), _, sign) ->
144       let call = Printf.sprintf "%s_char_%s"
145         funcname (if sign then "signed" else "unsigned") in
146       <:expr< Bitmatch.$lid:call$ >>
147   | (len, endian, signed) ->
148       let t = match len with
149       | Some i when i <= 31 -> "int"
150       | Some 32 -> "int32"
151       | _ -> "int64" in
152       let sign = if signed then "signed" else "unsigned" in
153       match endian with
154       | P.ConstantEndian constant ->
155           let endianness = match constant with
156           | BigEndian -> "be"
157           | LittleEndian -> "le"
158           | NativeEndian -> "ne" in
159           let call = Printf.sprintf "%s_%s_%s_%s"
160             funcname t endianness sign in
161           <:expr< Bitmatch.$lid:call$ >>
162       | P.EndianExpr expr ->
163           let call = Printf.sprintf "%s_%s_%s_%s"
164             funcname t "ee" sign in
165           <:expr< Bitmatch.$lid:call$ $expr$ >>
166
167 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
168 let output_constructor _loc fields =
169   (* This function makes code to raise a Bitmatch.Construct_failure exception
170    * containing a message and the current _loc context.
171    * (Thanks to Bluestorm for suggesting this).
172    *)
173   let construct_failure _loc msg =
174     <:expr<
175       Bitmatch.Construct_failure
176         ($`str:msg$,
177          $`str:Loc.file_name _loc$,
178          $`int:Loc.start_line _loc$,
179          $`int:Loc.start_off _loc - Loc.start_bol _loc$)
180     >>
181   in
182   let raise_construct_failure _loc msg =
183     <:expr< raise $construct_failure _loc msg$ >>
184   in
185
186   (* Bitstrings are created like the 'Buffer' module (in fact, using
187    * the Buffer module), by appending snippets to a growing buffer.
188    * This is reasonably efficient and avoids a lot of garbage.
189    *)
190   let buffer = gensym "buffer" in
191
192   (* General exception which is raised inside the constructor functions
193    * when an int expression is out of range at runtime.
194    *)
195   let exn = gensym "exn" in
196   let exn_used = ref false in
197
198   (* Convert each field to a simple bitstring-generating expression. *)
199   let fields = List.map (
200     fun field ->
201       let fexpr = P.get_expr field in
202       let flen = P.get_length field in
203       let endian = P.get_endian field in
204       let signed = P.get_signed field in
205       let t = P.get_type field in
206       let _loc = P.get_location field in
207       let offset = P.get_offset field in
208
209       let fail = locfail _loc in
210
211       (* offset() not supported in constructors.  Implementation of
212        * forward-only offsets is fairly straightforward: we would
213        * need to just calculate the length of padding here and add
214        * it to what has been constructed.  For general offsets,
215        * including going backwards, that would require a rethink in
216        * how we construct bitstrings.
217        *)
218       if offset <> None then
219         fail "offset expressions are not supported in BITSTRING constructors";
220
221       (* Is flen an integer constant?  If so, what is it?  This
222        * is very simple-minded and only detects simple constants.
223        *)
224       let flen_is_const = expr_is_constant flen in
225
226       let int_construct_const (i, endian, signed) =
227         build_bitmatch_call _loc "construct" (Some i) endian signed in
228       let int_construct (endian, signed) =
229        build_bitmatch_call _loc "construct" None endian signed in
230
231       let expr =
232         match t, flen_is_const with
233         (* Common case: int field, constant flen.
234          *
235          * Range checks are done inside the construction function
236          * because that's a lot simpler w.r.t. types.  It might
237          * be better to move them here. XXX
238          *)
239         | P.Int, Some i when i > 0 && i <= 64 ->
240             let construct_fn = int_construct_const (i,endian,signed) in
241             exn_used := true;
242
243             <:expr<
244               $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
245             >>
246
247         | P.Int, Some _ ->
248             fail "length of int field must be [1..64]"
249
250         (* Int field, non-constant length.  We need to perform a runtime
251          * test to ensure the length is [1..64].
252          *
253          * Range checks are done inside the construction function
254          * because that's a lot simpler w.r.t. types.  It might
255          * be better to move them here. XXX
256          *)
257         | P.Int, None ->
258             let construct_fn = int_construct (endian,signed) in
259             exn_used := true;
260
261             <:expr<
262               if $flen$ >= 1 && $flen$ <= 64 then
263                 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
264               else
265                 $raise_construct_failure _loc "length of int field must be [1..64]"$
266             >>
267
268         (* String, constant length > 0, must be a multiple of 8. *)
269         | P.String, Some i when i > 0 && i land 7 = 0 ->
270             let bs = gensym "bs" in
271             let j = i lsr 3 in
272             <:expr<
273               let $lid:bs$ = $fexpr$ in
274               if String.length $lid:bs$ = $`int:j$ then
275                 Bitmatch.construct_string $lid:buffer$ $lid:bs$
276               else
277                 $raise_construct_failure _loc "length of string does not match declaration"$
278             >>
279
280         (* String, constant length -1, means variable length string
281          * with no checks.
282          *)
283         | P.String, Some (-1) ->
284             <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
285
286         (* String, constant length = 0 is probably an error, and so is
287          * any other value.
288          *)
289         | P.String, Some _ ->
290             fail "length of string must be > 0 and a multiple of 8, or the special value -1"
291
292         (* String, non-constant length.
293          * We check at runtime that the length is > 0, a multiple of 8,
294          * and matches the declared length.
295          *)
296         | P.String, None ->
297             let bslen = gensym "bslen" in
298             let bs = gensym "bs" in
299             <:expr<
300               let $lid:bslen$ = $flen$ in
301               if $lid:bslen$ > 0 then (
302                 if $lid:bslen$ land 7 = 0 then (
303                   let $lid:bs$ = $fexpr$ in
304                   if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
305                     Bitmatch.construct_string $lid:buffer$ $lid:bs$
306                   else
307                     $raise_construct_failure _loc "length of string does not match declaration"$
308                 ) else
309                   $raise_construct_failure _loc "length of string must be a multiple of 8"$
310               ) else
311                 $raise_construct_failure _loc "length of string must be > 0"$
312             >>
313
314         (* Bitstring, constant length >= 0. *)
315         | P.Bitstring, Some i when i >= 0 ->
316             let bs = gensym "bs" in
317             <:expr<
318               let $lid:bs$ = $fexpr$ in
319               if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
320                 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
321               else
322                 $raise_construct_failure _loc "length of bitstring does not match declaration"$
323             >>
324
325         (* Bitstring, constant length -1, means variable length bitstring
326          * with no checks.
327          *)
328         | P.Bitstring, Some (-1) ->
329             <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
330
331         (* Bitstring, constant length < -1 is an error. *)
332         | P.Bitstring, Some _ ->
333             fail "length of bitstring must be >= 0 or the special value -1"
334
335         (* Bitstring, non-constant length.
336          * We check at runtime that the length is >= 0 and matches
337          * the declared length.
338          *)
339         | P.Bitstring, None ->
340             let bslen = gensym "bslen" in
341             let bs = gensym "bs" in
342             <:expr<
343               let $lid:bslen$ = $flen$ in
344               if $lid:bslen$ >= 0 then (
345                 let $lid:bs$ = $fexpr$ in
346                 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
347                   Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
348                 else
349                   $raise_construct_failure _loc "length of bitstring does not match declaration"$
350               ) else
351                 $raise_construct_failure _loc "length of bitstring must be > 0"$
352             >> in
353       expr
354   ) fields in
355
356   (* Create the final bitstring.  Start by creating an empty buffer
357    * and then evaluate each expression above in turn which will
358    * append some more to the bitstring buffer.  Finally extract
359    * the bitstring.
360    *
361    * XXX We almost have enough information to be able to guess
362    * a good initial size for the buffer.
363    *)
364   let fields =
365     match fields with
366     | [] -> <:expr< [] >>
367     | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
368
369   let expr =
370     <:expr<
371       let $lid:buffer$ = Bitmatch.Buffer.create () in
372       $fields$;
373       Bitmatch.Buffer.contents $lid:buffer$
374     >> in
375
376   if !exn_used then
377     <:expr<
378       let $lid:exn$ = $construct_failure _loc "value out of range"$ in
379       $expr$
380     >>
381   else
382     expr
383
384 (* Generate the code for a bitmatch statement.  '_loc' is the
385  * location, 'bs' is the bitstring parameter, 'cases' are
386  * the list of cases to test against.
387  *)
388 let output_bitmatch _loc bs cases =
389   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
390   let result = gensym "result" in
391
392   (* This generates the field extraction code for each
393    * field in a single case.  There must be enough remaining data
394    * in the bitstring to satisfy the field.
395    *
396    * As we go through the fields, symbols 'data', 'off' and 'len'
397    * track our position and remaining length in the bitstring.
398    *
399    * The whole thing is a lot of nested 'if' statements. Code
400    * is generated from the inner-most (last) field outwards.
401    *)
402   let rec output_field_extraction inner = function
403     | [] -> inner
404     | field :: fields ->
405         let fpatt = P.get_patt field in
406         let flen = P.get_length field in
407         let endian = P.get_endian field in
408         let signed = P.get_signed field in
409         let t = P.get_type field in
410         let _loc = P.get_location field in
411         let offset = P.get_offset field in
412
413         let fail = locfail _loc in
414
415         (* Is flen (field len) an integer constant?  If so, what is it?
416          * This will be [Some i] if it's a constant or [None] if it's
417          * non-constant or we couldn't determine.
418          *)
419         let flen_is_const = expr_is_constant flen in
420
421       let int_extract_const (i, endian, signed) =
422         build_bitmatch_call _loc "extract" (Some i) endian signed in
423       let int_extract (endian, signed) =
424        build_bitmatch_call _loc "extract" None endian signed in
425
426         let expr =
427           match t, flen_is_const with
428           (* Common case: int field, constant flen *)
429           | P.Int, Some i when i > 0 && i <= 64 ->
430               let extract_fn = int_extract_const (i,endian,signed) in
431               let v = gensym "val" in
432               <:expr<
433                 if $lid:len$ >= $`int:i$ then (
434                   let $lid:v$, $lid:off$, $lid:len$ =
435                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
436                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
437                 )
438               >>
439
440           | P.Int, Some _ ->
441               fail "length of int field must be [1..64]"
442
443           (* Int field, non-const flen.  We have to test the range of
444            * the field at runtime.  If outside the range it's a no-match
445            * (not an error).
446            *)
447           | P.Int, None ->
448               let extract_fn = int_extract (endian,signed) in
449               let v = gensym "val" in
450               <:expr<
451                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
452                   let $lid:v$, $lid:off$, $lid:len$ =
453                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
454                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
455                 )
456               >>
457
458           (* String, constant flen > 0. *)
459           | P.String, Some i when i > 0 && i land 7 = 0 ->
460               let bs = gensym "bs" in
461               <:expr<
462                 if $lid:len$ >= $`int:i$ then (
463                   let $lid:bs$, $lid:off$, $lid:len$ =
464                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
465                       $`int:i$ in
466                   match Bitmatch.string_of_bitstring $lid:bs$ with
467                   | $fpatt$ when true -> $inner$
468                   | _ -> ()
469                 )
470               >>
471
472           (* String, constant flen = -1, means consume all the
473            * rest of the input.
474            *)
475           | P.String, Some i when i = -1 ->
476               let bs = gensym "bs" in
477               <:expr<
478                 let $lid:bs$, $lid:off$, $lid:len$ =
479                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
480                 match Bitmatch.string_of_bitstring $lid:bs$ with
481                 | $fpatt$ when true -> $inner$
482                 | _ -> ()
483               >>
484
485           | P.String, Some _ ->
486               fail "length of string must be > 0 and a multiple of 8, or the special value -1"
487
488           (* String field, non-const flen.  We check the flen is > 0
489            * and a multiple of 8 (-1 is not allowed here), at runtime.
490            *)
491           | P.String, None ->
492               let bs = gensym "bs" in
493               <:expr<
494                 if $flen$ >= 0 && $flen$ <= $lid:len$
495                   && $flen$ land 7 = 0 then (
496                     let $lid:bs$, $lid:off$, $lid:len$ =
497                       Bitmatch.extract_bitstring
498                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
499                     match Bitmatch.string_of_bitstring $lid:bs$ with
500                     | $fpatt$ when true -> $inner$
501                     | _ -> ()
502                   )
503               >>
504
505           (* Bitstring, constant flen >= 0.
506            * At the moment all we can do is assign the bitstring to an
507            * identifier.
508            *)
509           | P.Bitstring, Some i when i >= 0 ->
510               let ident =
511                 match fpatt with
512                 | <:patt< $lid:ident$ >> -> ident
513                 | <:patt< _ >> -> "_"
514                 | _ ->
515                     fail "cannot compare a bitstring to a constant" in
516               <:expr<
517                 if $lid:len$ >= $`int:i$ then (
518                   let $lid:ident$, $lid:off$, $lid:len$ =
519                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
520                       $`int:i$ in
521                   $inner$
522                 )
523               >>
524
525           (* Bitstring, constant flen = -1, means consume all the
526            * rest of the input.
527            *)
528           | P.Bitstring, Some i when i = -1 ->
529               let ident =
530                 match fpatt with
531                 | <:patt< $lid:ident$ >> -> ident
532                 | <:patt< _ >> -> "_"
533                 | _ ->
534                     fail "cannot compare a bitstring to a constant" in
535               <:expr<
536                 let $lid:ident$, $lid:off$, $lid:len$ =
537                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
538                   $inner$
539               >>
540
541           | P.Bitstring, Some _ ->
542               fail "length of bitstring must be >= 0 or the special value -1"
543
544           (* Bitstring field, non-const flen.  We check the flen is >= 0
545            * (-1 is not allowed here) at runtime.
546            *)
547           | P.Bitstring, None ->
548               let ident =
549                 match fpatt with
550                 | <:patt< $lid:ident$ >> -> ident
551                 | <:patt< _ >> -> "_"
552                 | _ ->
553                     fail "cannot compare a bitstring to a constant" in
554               <:expr<
555                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
556                   let $lid:ident$, $lid:off$, $lid:len$ =
557                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
558                       $flen$ in
559                   $inner$
560                 )
561               >>
562         in
563
564         (* Computed offset: only offsets forward are supported.
565          *
566          * We try hard to optimize this based on what we know.  Are
567          * we at a predictable offset now?  (Look at the outer 'fields'
568          * list and see if they all have constant field length starting
569          * at some constant offset).  Is this offset constant?
570          *
571          * Based on this we can do a lot of the computation at
572          * compile time, or defer it to runtime only if necessary.
573          *
574          * In all cases, the off and len fields get updated.
575          *)
576         let expr =
577           match offset with
578           | None -> expr (* common case: there was no offset expression *)
579           | Some offset_expr ->
580               (* This will be [Some i] if offset is a constant expression
581                * or [None] if it's a non-constant.
582                *)
583               let requested_offset = expr_is_constant offset_expr in
584
585               (* This will be [Some i] if our current offset is known
586                * at compile time, or [None] if we can't determine it.
587                *)
588               let current_offset =
589                 let has_constant_offset field =
590                   match P.get_offset field with
591                   | None -> false
592                   | Some expr ->
593                       match expr_is_constant expr with
594                       | None -> false
595                       | Some i -> true
596                 in
597                 let get_constant_offset field =
598                   match P.get_offset field with
599                   | None -> assert false
600                   | Some expr ->
601                       match expr_is_constant expr with
602                       | None -> assert false
603                       | Some i -> i
604                 in
605
606                 let has_constant_len field =
607                   match expr_is_constant (P.get_length field) with
608                   | None -> false
609                   | Some i when i > 0 -> true
610                   | Some _ -> false
611                 in
612                 let get_constant_len field =
613                   match expr_is_constant (P.get_length field) with
614                   | None -> assert false
615                   | Some i when i > 0 -> i
616                   | Some _ -> assert false
617                 in
618
619                 let rec loop = function
620                   (* first field has constant offset 0 *)
621                   | [] -> Some 0
622                   (* field with constant offset & length *)
623                   | field :: _
624                       when has_constant_offset field &&
625                         has_constant_len field ->
626                       Some (get_constant_offset field + get_constant_len field)
627                   (* field with no offset & constant length *)
628                   | field :: fields
629                       when P.get_offset field = None &&
630                         has_constant_len field ->
631                       (match loop fields with
632                        | None -> None
633                        | Some offset -> Some (offset + get_constant_len field))
634                   (* else, can't work out the offset *)
635                   | _ -> None
636                 in
637                 loop fields in
638
639               (* Look at the current offset and requested offset cases and
640                * determine what code to generate.
641                *)
642               match current_offset, requested_offset with
643                 (* This is the good case: both the current offset and
644                  * the requested offset are constant, so we can remove
645                  * almost all the runtime checks.
646                  *)
647               | Some current_offset, Some requested_offset ->
648                   let move = requested_offset - current_offset in
649                   if move < 0 then
650                     fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
651                   (* Add some code to move the offset and length by a
652                    * constant amount, and a runtime test that len >= 0
653                    * (XXX possibly the runtime test is unnecessary?)
654                    *)
655                   <:expr<
656                     let $lid:off$ = $lid:off$ + $`int:move$ in
657                     let $lid:len$ = $lid:len$ - $`int:move$ in
658                     if $lid:len$ >= 0 then $expr$
659                   >>
660               (* In any other case, we need to use runtime checks.
661                *
662                * XXX It's not clear if a backwards move detected at runtime
663                * is merely a match failure, or a runtime error.  At the
664                * moment it's just a match failure since bitmatch generally
665                * doesn't raise runtime errors.
666                *)
667               | _ ->
668                   let move = gensym "move" in
669                   <:expr<
670                     let $lid:move$ = $offset_expr$ - $lid:off$ in
671                     if $lid:move$ >= 0 then (
672                       let $lid:off$ = $lid:off$ + $lid:move$ in
673                       let $lid:len$ = $lid:len$ - $lid:move$ in
674                       if $lid:len$ >= 0 then $expr$
675                     )
676                   >> in (* end of computed offset code *)
677
678         (* Emit extra debugging code. *)
679         let expr =
680           if not debug then expr else (
681             let field = P.string_of_pattern_field field in
682
683             <:expr<
684               if !Bitmatch.debug then (
685                 Printf.eprintf "PA_BITMATCH: TEST:\n";
686                 Printf.eprintf "  %s\n" $str:field$;
687                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
688                 (*Bitmatch.hexdump_bitstring stderr
689                   ($lid:data$,$lid:off$,$lid:len$);*)
690               );
691               $expr$
692             >>
693           ) in
694
695         output_field_extraction expr fields
696   in
697
698   (* Convert each case in the match. *)
699   let cases = List.map (
700     fun (fields, bind, whenclause, code) ->
701       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
702       let inner =
703         match whenclause with
704         | Some whenclause ->
705             <:expr< if $whenclause$ then $inner$ >>
706         | None -> inner in
707       let inner =
708         match bind with
709         | Some name ->
710             <:expr<
711               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
712               $inner$
713               >>
714         | None -> inner in
715       output_field_extraction inner (List.rev fields)
716   ) cases in
717
718   (* Join them into a single expression.
719    *
720    * Don't do it with a normal fold_right because that leaves
721    * 'raise Exit; ()' at the end which causes a compiler warning.
722    * Hence a bit of complexity here.
723    *
724    * Note that the number of cases is always >= 1 so List.hd is safe.
725    *)
726   let cases = List.rev cases in
727   let cases =
728     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
729       (List.hd cases) (List.tl cases) in
730
731   (* The final code just wraps the list of cases in a
732    * try/with construct so that each case is tried in
733    * turn until one case matches (that case sets 'result'
734    * and raises 'Exit' to leave the whole statement).
735    * If result isn't set by the end then we will raise
736    * Match_failure with the location of the bitmatch
737    * statement in the original code.
738    *)
739   let loc_fname = Loc.file_name _loc in
740   let loc_line = string_of_int (Loc.start_line _loc) in
741   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
742
743   <:expr<
744     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
745     let $lid:result$ = ref None in
746     (try
747       $cases$
748     with Exit -> ());
749     match ! $lid:result$ with
750     | Some x -> x
751     | None -> raise (Match_failure ($str:loc_fname$,
752                                     $int:loc_line$, $int:loc_char$))
753   >>
754
755 (* Add a named pattern. *)
756 let add_named_pattern _loc name pattern =
757   Hashtbl.add pattern_hash name pattern
758
759 (* Expand a named pattern from the pattern_hash. *)
760 let expand_named_pattern _loc name =
761   try Hashtbl.find pattern_hash name
762   with Not_found ->
763     locfail _loc (sprintf "named pattern not found: %s" name)
764
765 (* Add named patterns from a file.  See the documentation on the
766  * directory search path in bitmatch_persistent.mli
767  *)
768 let load_patterns_from_file _loc filename =
769   let chan =
770     if Filename.is_relative filename && Filename.is_implicit filename then (
771       (* Try current directory. *)
772       try open_in filename
773       with _ ->
774         (* Try OCaml library directory. *)
775         try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
776         with exn -> Loc.raise _loc exn
777     ) else (
778       try open_in filename
779       with exn -> Loc.raise _loc exn
780     ) in
781   let names = ref [] in
782   (try
783      let rec loop () =
784        let name = P.named_from_channel chan in
785        names := name :: !names
786      in
787      loop ()
788    with End_of_file -> ()
789   );
790   close_in chan;
791   let names = List.rev !names in
792   List.iter (
793     function
794     | name, P.Pattern patt ->
795         if patt = [] then
796           locfail _loc (sprintf "pattern %s: no fields" name);
797         add_named_pattern _loc name patt
798     | _, P.Constructor _ -> () (* just ignore these for now *)
799   ) names
800
801 EXTEND Gram
802   GLOBAL: expr str_item;
803
804   (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
805    * followed by an optional expression (used in certain cases).  Note
806    * that we are careful not to declare any explicit reserved words.
807    *)
808   qualifiers: [
809     [ LIST0
810         [ q = LIDENT;
811           e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
812         SEP "," ]
813   ];
814
815   (* Field used in the bitmatch operator (a pattern).  This can actually
816    * return multiple fields, in the case where the 'field' is a named
817    * persitent pattern.
818    *)
819   patt_field: [
820     [ fpatt = patt; ":"; len = expr LEVEL "top";
821       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
822         let field = P.create_pattern_field _loc in
823         let field = P.set_patt field fpatt in
824         let field = P.set_length field len in
825         [parse_field _loc field qs]     (* Normal, single field. *)
826     | ":"; name = LIDENT ->
827         expand_named_pattern _loc name (* Named -> list of fields. *)
828     ]
829   ];
830
831   (* Case inside bitmatch operator. *)
832   patt_fields: [
833     [ "{";
834       fields = LIST0 patt_field SEP ";";
835       "}" ->
836         List.concat fields
837     ]
838   ];
839
840   patt_case: [
841     [ fields = patt_fields;
842       bind = OPT [ "as"; name = LIDENT -> name ];
843       whenclause = OPT [ "when"; e = expr -> e ]; "->";
844       code = expr ->
845         (fields, bind, whenclause, code)
846     ]
847   ];
848
849   (* Field used in the BITSTRING constructor (an expression). *)
850   constr_field: [
851     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
852       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
853         let field = P.create_constructor_field _loc in
854         let field = P.set_expr field fexpr in
855         let field = P.set_length field len in
856         parse_field _loc field qs
857     ]
858   ];
859
860   constr_fields: [
861     [ "{";
862       fields = LIST0 constr_field SEP ";";
863       "}" ->
864         fields
865     ]
866   ];
867
868   (* 'bitmatch' expressions. *)
869   expr: LEVEL ";" [
870     [ "bitmatch";
871       bs = expr; "with"; OPT "|";
872       cases = LIST1 patt_case SEP "|" ->
873         output_bitmatch _loc bs cases
874     ]
875
876   (* Constructor. *)
877   | [ "BITSTRING";
878       fields = constr_fields ->
879         output_constructor _loc fields
880     ]
881   ];
882
883   (* Named persistent patterns.
884    *
885    * NB: Currently only allowed at the top level.  We can probably lift
886    * this restriction later if necessary.  We only deal with patterns
887    * at the moment, not constructors, but the infrastructure to do
888    * constructors is in place.
889    *)
890   str_item: LEVEL "top" [
891     [ "let"; "bitmatch";
892       name = LIDENT; "="; fields = patt_fields ->
893         add_named_pattern _loc name fields;
894         (* The statement disappears, but we still need a str_item so ... *)
895         <:str_item< >>
896     | "open"; "bitmatch"; filename = STRING ->
897         load_patterns_from_file _loc filename;
898         <:str_item< >>
899     ]
900   ];
901
902 END