Make the locations in error messages more specific.
[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   let loc_fname = Loc.file_name _loc in
170   let loc_line = string_of_int (Loc.start_line _loc) in
171   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
172
173   (* Bitstrings are created like the 'Buffer' module (in fact, using
174    * the Buffer module), by appending snippets to a growing buffer.
175    * This is reasonably efficient and avoids a lot of garbage.
176    *)
177   let buffer = gensym "buffer" in
178
179   (* General exception which is raised inside the constructor functions
180    * when an int expression is out of range at runtime.
181    *)
182   let exn = gensym "exn" in
183   let exn_used = ref false in
184
185   (* Convert each field to a simple bitstring-generating expression. *)
186   let fields = List.map (
187     fun field ->
188       let fexpr = P.get_expr field in
189       let flen = P.get_length field in
190       let endian = P.get_endian field in
191       let signed = P.get_signed field in
192       let t = P.get_type field in
193       let _loc = P.get_location field in
194       let offset = P.get_offset field in
195
196       let fail = locfail _loc in
197
198       (* offset() not supported in constructors.  Implementation of
199        * forward-only offsets is fairly straightforward: we would
200        * need to just calculate the length of padding here and add
201        * it to what has been constructed.  For general offsets,
202        * including going backwards, that would require a rethink in
203        * how we construct bitstrings.
204        *)
205       if offset <> None then
206         fail "offset expressions are not supported in BITSTRING constructors";
207
208       (* Is flen an integer constant?  If so, what is it?  This
209        * is very simple-minded and only detects simple constants.
210        *)
211       let flen_is_const = expr_is_constant flen in
212
213       let int_construct_const (i, endian, signed) =
214         build_bitmatch_call _loc "construct" (Some i) endian signed in
215       let int_construct (endian, signed) =
216        build_bitmatch_call _loc "construct" None endian signed in
217
218       let expr =
219         match t, flen_is_const with
220         (* Common case: int field, constant flen.
221          *
222          * Range checks are done inside the construction function
223          * because that's a lot simpler w.r.t. types.  It might
224          * be better to move them here. XXX
225          *)
226         | P.Int, Some i when i > 0 && i <= 64 ->
227             let construct_fn = int_construct_const (i,endian,signed) in
228             exn_used := true;
229
230             <:expr<
231               $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
232             >>
233
234         | P.Int, Some _ ->
235             fail "length of int field must be [1..64]"
236
237         (* Int field, non-constant length.  We need to perform a runtime
238          * test to ensure the length is [1..64].
239          *
240          * Range checks are done inside the construction function
241          * because that's a lot simpler w.r.t. types.  It might
242          * be better to move them here. XXX
243          *)
244         | P.Int, None ->
245             let construct_fn = int_construct (endian,signed) in
246             exn_used := true;
247
248             <:expr<
249               if $flen$ >= 1 && $flen$ <= 64 then
250                 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
251               else
252                 raise (Bitmatch.Construct_failure
253                          ("length of int field must be [1..64]",
254                           $str:loc_fname$,
255                           $int:loc_line$, $int:loc_char$))
256             >>
257
258         (* String, constant length > 0, must be a multiple of 8. *)
259         | P.String, Some i when i > 0 && i land 7 = 0 ->
260             let bs = gensym "bs" in
261             let j = i lsr 3 in
262             <:expr<
263               let $lid:bs$ = $fexpr$ in
264               if String.length $lid:bs$ = $`int:j$ then
265                 Bitmatch.construct_string $lid:buffer$ $lid:bs$
266               else
267                 raise (Bitmatch.Construct_failure
268                          ("length of string does not match declaration",
269                           $str:loc_fname$,
270                           $int:loc_line$, $int:loc_char$))
271             >>
272
273         (* String, constant length -1, means variable length string
274          * with no checks.
275          *)
276         | P.String, Some (-1) ->
277             <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
278
279         (* String, constant length = 0 is probably an error, and so is
280          * any other value.
281          *)
282         | P.String, Some _ ->
283             fail "length of string must be > 0 and a multiple of 8, or the special value -1"
284
285         (* String, non-constant length.
286          * We check at runtime that the length is > 0, a multiple of 8,
287          * and matches the declared length.
288          *)
289         | P.String, None ->
290             let bslen = gensym "bslen" in
291             let bs = gensym "bs" in
292             <:expr<
293               let $lid:bslen$ = $flen$ in
294               if $lid:bslen$ > 0 then (
295                 if $lid:bslen$ land 7 = 0 then (
296                   let $lid:bs$ = $fexpr$ in
297                   if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
298                     Bitmatch.construct_string $lid:buffer$ $lid:bs$
299                   else
300                     raise (Bitmatch.Construct_failure
301                              ("length of string does not match declaration",
302                               $str:loc_fname$,
303                               $int:loc_line$, $int:loc_char$))
304                 ) else
305                   raise (Bitmatch.Construct_failure
306                            ("length of string must be a multiple of 8",
307                             $str:loc_fname$,
308                             $int:loc_line$, $int:loc_char$))
309               ) else
310                 raise (Bitmatch.Construct_failure
311                          ("length of string must be > 0",
312                           $str:loc_fname$,
313                           $int:loc_line$, $int:loc_char$))
314             >>
315
316         (* Bitstring, constant length >= 0. *)
317         | P.Bitstring, Some i when i >= 0 ->
318             let bs = gensym "bs" in
319             <:expr<
320               let $lid:bs$ = $fexpr$ in
321               if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
322                 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
323               else
324                 raise (Bitmatch.Construct_failure
325                          ("length of bitstring does not match declaration",
326                           $str:loc_fname$,
327                           $int:loc_line$, $int:loc_char$))
328             >>
329
330         (* Bitstring, constant length -1, means variable length bitstring
331          * with no checks.
332          *)
333         | P.Bitstring, Some (-1) ->
334             <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
335
336         (* Bitstring, constant length < -1 is an error. *)
337         | P.Bitstring, Some _ ->
338             fail "length of bitstring must be >= 0 or the special value -1"
339
340         (* Bitstring, non-constant length.
341          * We check at runtime that the length is >= 0 and matches
342          * the declared length.
343          *)
344         | P.Bitstring, None ->
345             let bslen = gensym "bslen" in
346             let bs = gensym "bs" in
347             <:expr<
348               let $lid:bslen$ = $flen$ in
349               if $lid:bslen$ >= 0 then (
350                 let $lid:bs$ = $fexpr$ in
351                 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
352                   Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
353                 else
354                   raise (Bitmatch.Construct_failure
355                            ("length of bitstring does not match declaration",
356                             $str:loc_fname$,
357                             $int:loc_line$, $int:loc_char$))
358               ) else
359                 raise (Bitmatch.Construct_failure
360                          ("length of bitstring must be > 0",
361                           $str:loc_fname$,
362                           $int:loc_line$, $int:loc_char$))
363             >> in
364       expr
365   ) fields in
366
367   (* Create the final bitstring.  Start by creating an empty buffer
368    * and then evaluate each expression above in turn which will
369    * append some more to the bitstring buffer.  Finally extract
370    * the bitstring.
371    *
372    * XXX We almost have enough information to be able to guess
373    * a good initial size for the buffer.
374    *)
375   let fields =
376     match fields with
377     | [] -> <:expr< [] >>
378     | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
379
380   let expr =
381     <:expr<
382       let $lid:buffer$ = Bitmatch.Buffer.create () in
383       $fields$;
384       Bitmatch.Buffer.contents $lid:buffer$
385     >> in
386
387   if !exn_used then
388     <:expr<
389       let $lid:exn$ =
390         Bitmatch.Construct_failure ("value out of range",
391                                     $str:loc_fname$,
392                                     $int:loc_line$, $int:loc_char$) in
393         $expr$
394     >>
395   else
396     expr
397
398 (* Generate the code for a bitmatch statement.  '_loc' is the
399  * location, 'bs' is the bitstring parameter, 'cases' are
400  * the list of cases to test against.
401  *)
402 let output_bitmatch _loc bs cases =
403   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
404   let result = gensym "result" in
405
406   (* This generates the field extraction code for each
407    * field in a single case.  There must be enough remaining data
408    * in the bitstring to satisfy the field.
409    *
410    * As we go through the fields, symbols 'data', 'off' and 'len'
411    * track our position and remaining length in the bitstring.
412    *
413    * The whole thing is a lot of nested 'if' statements. Code
414    * is generated from the inner-most (last) field outwards.
415    *)
416   let rec output_field_extraction inner = function
417     | [] -> inner
418     | field :: fields ->
419         let fpatt = P.get_patt field in
420         let flen = P.get_length field in
421         let endian = P.get_endian field in
422         let signed = P.get_signed field in
423         let t = P.get_type field in
424         let _loc = P.get_location field in
425         let offset = P.get_offset field in
426
427         let fail = locfail _loc in
428
429         (* Is flen (field len) an integer constant?  If so, what is it?
430          * This will be [Some i] if it's a constant or [None] if it's
431          * non-constant or we couldn't determine.
432          *)
433         let flen_is_const = expr_is_constant flen in
434
435       let int_extract_const (i, endian, signed) =
436         build_bitmatch_call _loc "extract" (Some i) endian signed in
437       let int_extract (endian, signed) =
438        build_bitmatch_call _loc "extract" None endian signed in
439
440         let expr =
441           match t, flen_is_const with
442           (* Common case: int field, constant flen *)
443           | P.Int, Some i when i > 0 && i <= 64 ->
444               let extract_fn = int_extract_const (i,endian,signed) in
445               let v = gensym "val" in
446               <:expr<
447                 if $lid:len$ >= $`int:i$ then (
448                   let $lid:v$, $lid:off$, $lid:len$ =
449                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
450                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
451                 )
452               >>
453
454           | P.Int, Some _ ->
455               fail "length of int field must be [1..64]"
456
457           (* Int field, non-const flen.  We have to test the range of
458            * the field at runtime.  If outside the range it's a no-match
459            * (not an error).
460            *)
461           | P.Int, None ->
462               let extract_fn = int_extract (endian,signed) in
463               let v = gensym "val" in
464               <:expr<
465                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
466                   let $lid:v$, $lid:off$, $lid:len$ =
467                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
468                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
469                 )
470               >>
471
472           (* String, constant flen > 0. *)
473           | P.String, Some i when i > 0 && i land 7 = 0 ->
474               let bs = gensym "bs" in
475               <:expr<
476                 if $lid:len$ >= $`int:i$ then (
477                   let $lid:bs$, $lid:off$, $lid:len$ =
478                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
479                       $`int:i$ in
480                   match Bitmatch.string_of_bitstring $lid:bs$ with
481                   | $fpatt$ when true -> $inner$
482                   | _ -> ()
483                 )
484               >>
485
486           (* String, constant flen = -1, means consume all the
487            * rest of the input.
488            *)
489           | P.String, Some i when i = -1 ->
490               let bs = gensym "bs" in
491               <:expr<
492                 let $lid:bs$, $lid:off$, $lid:len$ =
493                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
494                 match Bitmatch.string_of_bitstring $lid:bs$ with
495                 | $fpatt$ when true -> $inner$
496                 | _ -> ()
497               >>
498
499           | P.String, Some _ ->
500               fail "length of string must be > 0 and a multiple of 8, or the special value -1"
501
502           (* String field, non-const flen.  We check the flen is > 0
503            * and a multiple of 8 (-1 is not allowed here), at runtime.
504            *)
505           | P.String, None ->
506               let bs = gensym "bs" in
507               <:expr<
508                 if $flen$ >= 0 && $flen$ <= $lid:len$
509                   && $flen$ land 7 = 0 then (
510                     let $lid:bs$, $lid:off$, $lid:len$ =
511                       Bitmatch.extract_bitstring
512                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
513                     match Bitmatch.string_of_bitstring $lid:bs$ with
514                     | $fpatt$ when true -> $inner$
515                     | _ -> ()
516                   )
517               >>
518
519           (* Bitstring, constant flen >= 0.
520            * At the moment all we can do is assign the bitstring to an
521            * identifier.
522            *)
523           | P.Bitstring, Some i when i >= 0 ->
524               let ident =
525                 match fpatt with
526                 | <:patt< $lid:ident$ >> -> ident
527                 | <:patt< _ >> -> "_"
528                 | _ ->
529                     fail "cannot compare a bitstring to a constant" in
530               <:expr<
531                 if $lid:len$ >= $`int:i$ then (
532                   let $lid:ident$, $lid:off$, $lid:len$ =
533                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
534                       $`int:i$ in
535                   $inner$
536                 )
537               >>
538
539           (* Bitstring, constant flen = -1, means consume all the
540            * rest of the input.
541            *)
542           | P.Bitstring, Some i when i = -1 ->
543               let ident =
544                 match fpatt with
545                 | <:patt< $lid:ident$ >> -> ident
546                 | <:patt< _ >> -> "_"
547                 | _ ->
548                     fail "cannot compare a bitstring to a constant" in
549               <:expr<
550                 let $lid:ident$, $lid:off$, $lid:len$ =
551                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
552                   $inner$
553               >>
554
555           | P.Bitstring, Some _ ->
556               fail "length of bitstring must be >= 0 or the special value -1"
557
558           (* Bitstring field, non-const flen.  We check the flen is >= 0
559            * (-1 is not allowed here) at runtime.
560            *)
561           | P.Bitstring, None ->
562               let ident =
563                 match fpatt with
564                 | <:patt< $lid:ident$ >> -> ident
565                 | <:patt< _ >> -> "_"
566                 | _ ->
567                     fail "cannot compare a bitstring to a constant" in
568               <:expr<
569                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
570                   let $lid:ident$, $lid:off$, $lid:len$ =
571                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
572                       $flen$ in
573                   $inner$
574                 )
575               >>
576         in
577
578         (* Computed offset: only offsets forward are supported.
579          *
580          * We try hard to optimize this based on what we know.  Are
581          * we at a predictable offset now?  (Look at the outer 'fields'
582          * list and see if they all have constant field length starting
583          * at some constant offset).  Is this offset constant?
584          *
585          * Based on this we can do a lot of the computation at
586          * compile time, or defer it to runtime only if necessary.
587          *
588          * In all cases, the off and len fields get updated.
589          *)
590         let expr =
591           match offset with
592           | None -> expr (* common case: there was no offset expression *)
593           | Some offset_expr ->
594               (* This will be [Some i] if offset is a constant expression
595                * or [None] if it's a non-constant.
596                *)
597               let requested_offset = expr_is_constant offset_expr in
598
599               (* This will be [Some i] if our current offset is known
600                * at compile time, or [None] if we can't determine it.
601                *)
602               let current_offset =
603                 let has_constant_offset field =
604                   match P.get_offset field with
605                   | None -> false
606                   | Some expr ->
607                       match expr_is_constant expr with
608                       | None -> false
609                       | Some i -> true
610                 in
611                 let get_constant_offset field =
612                   match P.get_offset field with
613                   | None -> assert false
614                   | Some expr ->
615                       match expr_is_constant expr with
616                       | None -> assert false
617                       | Some i -> i
618                 in
619
620                 let has_constant_len field =
621                   match expr_is_constant (P.get_length field) with
622                   | None -> false
623                   | Some i when i > 0 -> true
624                   | Some _ -> false
625                 in
626                 let get_constant_len field =
627                   match expr_is_constant (P.get_length field) with
628                   | None -> assert false
629                   | Some i when i > 0 -> i
630                   | Some _ -> assert false
631                 in
632
633                 let rec loop = function
634                   (* first field has constant offset 0 *)
635                   | [] -> Some 0
636                   (* field with constant offset & length *)
637                   | field :: _
638                       when has_constant_offset field &&
639                         has_constant_len field ->
640                       Some (get_constant_offset field + get_constant_len field)
641                   (* field with no offset & constant length *)
642                   | field :: fields
643                       when P.get_offset field = None &&
644                         has_constant_len field ->
645                       (match loop fields with
646                        | None -> None
647                        | Some offset -> Some (offset + get_constant_len field))
648                   (* else, can't work out the offset *)
649                   | _ -> None
650                 in
651                 loop fields in
652
653               (* Look at the current offset and requested offset cases and
654                * determine what code to generate.
655                *)
656               match current_offset, requested_offset with
657                 (* This is the good case: both the current offset and
658                  * the requested offset are constant, so we can remove
659                  * almost all the runtime checks.
660                  *)
661               | Some current_offset, Some requested_offset ->
662                   let move = requested_offset - current_offset in
663                   if move < 0 then
664                     fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
665                   (* Add some code to move the offset and length by a
666                    * constant amount, and a runtime test that len >= 0
667                    * (XXX possibly the runtime test is unnecessary?)
668                    *)
669                   <:expr<
670                     let $lid:off$ = $lid:off$ + $`int:move$ in
671                     let $lid:len$ = $lid:len$ - $`int:move$ in
672                     if $lid:len$ >= 0 then $expr$
673                   >>
674               (* In any other case, we need to use runtime checks.
675                *
676                * XXX It's not clear if a backwards move detected at runtime
677                * is merely a match failure, or a runtime error.  At the
678                * moment it's just a match failure since bitmatch generally
679                * doesn't raise runtime errors.
680                *)
681               | _ ->
682                   let move = gensym "move" in
683                   <:expr<
684                     let $lid:move$ = $offset_expr$ - $lid:off$ in
685                     if $lid:move$ >= 0 then (
686                       let $lid:off$ = $lid:off$ + $lid:move$ in
687                       let $lid:len$ = $lid:len$ - $lid:move$ in
688                       if $lid:len$ >= 0 then $expr$
689                     )
690                   >> in (* end of computed offset code *)
691
692         (* Emit extra debugging code. *)
693         let expr =
694           if not debug then expr else (
695             let field = P.string_of_pattern_field field in
696
697             <:expr<
698               if !Bitmatch.debug then (
699                 Printf.eprintf "PA_BITMATCH: TEST:\n";
700                 Printf.eprintf "  %s\n" $str:field$;
701                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
702                 (*Bitmatch.hexdump_bitstring stderr
703                   ($lid:data$,$lid:off$,$lid:len$);*)
704               );
705               $expr$
706             >>
707           ) in
708
709         output_field_extraction expr fields
710   in
711
712   (* Convert each case in the match. *)
713   let cases = List.map (
714     fun (fields, bind, whenclause, code) ->
715       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
716       let inner =
717         match whenclause with
718         | Some whenclause ->
719             <:expr< if $whenclause$ then $inner$ >>
720         | None -> inner in
721       let inner =
722         match bind with
723         | Some name ->
724             <:expr<
725               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
726               $inner$
727               >>
728         | None -> inner in
729       output_field_extraction inner (List.rev fields)
730   ) cases in
731
732   (* Join them into a single expression.
733    *
734    * Don't do it with a normal fold_right because that leaves
735    * 'raise Exit; ()' at the end which causes a compiler warning.
736    * Hence a bit of complexity here.
737    *
738    * Note that the number of cases is always >= 1 so List.hd is safe.
739    *)
740   let cases = List.rev cases in
741   let cases =
742     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
743       (List.hd cases) (List.tl cases) in
744
745   (* The final code just wraps the list of cases in a
746    * try/with construct so that each case is tried in
747    * turn until one case matches (that case sets 'result'
748    * and raises 'Exit' to leave the whole statement).
749    * If result isn't set by the end then we will raise
750    * Match_failure with the location of the bitmatch
751    * statement in the original code.
752    *)
753   let loc_fname = Loc.file_name _loc in
754   let loc_line = string_of_int (Loc.start_line _loc) in
755   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
756
757   <:expr<
758     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
759     let $lid:result$ = ref None in
760     (try
761       $cases$
762     with Exit -> ());
763     match ! $lid:result$ with
764     | Some x -> x
765     | None -> raise (Match_failure ($str:loc_fname$,
766                                     $int:loc_line$, $int:loc_char$))
767   >>
768
769 (* Add a named pattern. *)
770 let add_named_pattern _loc name pattern =
771   Hashtbl.add pattern_hash name pattern
772
773 (* Expand a named pattern from the pattern_hash. *)
774 let expand_named_pattern _loc name =
775   try Hashtbl.find pattern_hash name
776   with Not_found ->
777     locfail _loc (sprintf "named pattern not found: %s" name)
778
779 (* Add named patterns from a file.  See the documentation on the
780  * directory search path in bitmatch_persistent.mli
781  *)
782 let load_patterns_from_file _loc filename =
783   let chan =
784     if Filename.is_relative filename && Filename.is_implicit filename then (
785       (* Try current directory. *)
786       try open_in filename
787       with _ ->
788         (* Try OCaml library directory. *)
789         try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
790         with exn -> Loc.raise _loc exn
791     ) else (
792       try open_in filename
793       with exn -> Loc.raise _loc exn
794     ) in
795   let names = ref [] in
796   (try
797      let rec loop () =
798        let name = P.named_from_channel chan in
799        names := name :: !names
800      in
801      loop ()
802    with End_of_file -> ()
803   );
804   close_in chan;
805   let names = List.rev !names in
806   List.iter (
807     function
808     | name, P.Pattern patt -> add_named_pattern _loc name patt
809     | _, P.Constructor _ -> () (* just ignore these for now *)
810   ) names
811
812 EXTEND Gram
813   GLOBAL: expr str_item;
814
815   (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
816    * followed by an optional expression (used in certain cases).  Note
817    * that we are careful not to declare any explicit reserved words.
818    *)
819   qualifiers: [
820     [ LIST0
821         [ q = LIDENT;
822           e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
823         SEP "," ]
824   ];
825
826   (* Field used in the bitmatch operator (a pattern).  This can actually
827    * return multiple fields, in the case where the 'field' is a named
828    * persitent pattern.
829    *)
830   patt_field: [
831     [ fpatt = patt; ":"; len = expr LEVEL "top";
832       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
833         let field = P.create_pattern_field _loc in
834         let field = P.set_patt field fpatt in
835         let field = P.set_length field len in
836         [parse_field _loc field qs]     (* Normal, single field. *)
837     | ":"; name = LIDENT ->
838         expand_named_pattern _loc name (* Named -> list of fields. *)
839     ]
840   ];
841
842   (* Case inside bitmatch operator. *)
843   patt_fields: [
844     [ "{";
845       fields = LIST0 patt_field SEP ";";
846       "}" ->
847         List.concat fields
848     ]
849   ];
850
851   patt_case: [
852     [ fields = patt_fields;
853       bind = OPT [ "as"; name = LIDENT -> name ];
854       whenclause = OPT [ "when"; e = expr -> e ]; "->";
855       code = expr ->
856         (fields, bind, whenclause, code)
857     ]
858   ];
859
860   (* Field used in the BITSTRING constructor (an expression). *)
861   constr_field: [
862     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
863       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
864         let field = P.create_constructor_field _loc in
865         let field = P.set_expr field fexpr in
866         let field = P.set_length field len in
867         parse_field _loc field qs
868     ]
869   ];
870
871   constr_fields: [
872     [ "{";
873       fields = LIST0 constr_field SEP ";";
874       "}" ->
875         fields
876     ]
877   ];
878
879   (* 'bitmatch' expressions. *)
880   expr: LEVEL ";" [
881     [ "bitmatch";
882       bs = expr; "with"; OPT "|";
883       cases = LIST1 patt_case SEP "|" ->
884         output_bitmatch _loc bs cases
885     ]
886
887   (* Constructor. *)
888   | [ "BITSTRING";
889       fields = constr_fields ->
890         output_constructor _loc fields
891     ]
892   ];
893
894   (* Named persistent patterns.
895    *
896    * NB: Currently only allowed at the top level.  We can probably lift
897    * this restriction later if necessary.  We only deal with patterns
898    * at the moment, not constructors, but the infrastructure to do
899    * constructors is in place.
900    *)
901   str_item: LEVEL "top" [
902     [ "let"; "bitmatch";
903       name = LIDENT; "="; fields = patt_fields ->
904         add_named_pattern _loc name fields;
905         (* The statement disappears, but we still need a str_item so ... *)
906         <:str_item< >>
907     | "open"; "bitmatch"; filename = STRING ->
908         load_patterns_from_file _loc filename;
909         <:str_item< >>
910     ]
911   ];
912
913 END