Persistent patterns, save and load to 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 (* Work out if an expression is an integer constant.
42  *
43  * Returns [Some i] if so (where i is the integer value), else [None].
44  *
45  * Fairly simplistic algorithm: we can only detect simple constant
46  * expressions such as [k], [k+c], [k-c] etc.
47  *)
48 let rec expr_is_constant = function
49   | <:expr< $int:i$ >> ->               (* Literal integer constant. *)
50     Some (int_of_string i)
51   | <:expr< $a$ + $b$ >> ->             (* Addition of constants. *)
52     (match expr_is_constant a, expr_is_constant b with
53      | Some a, Some b -> Some (a+b)
54      | _ -> None)
55   | <:expr< $a$ - $b$ >> ->             (* Subtraction. *)
56     (match expr_is_constant a, expr_is_constant b with
57      | Some a, Some b -> Some (a-b)
58      | _ -> None)
59   | <:expr< $a$ * $b$ >> ->             (* Multiplication. *)
60     (match expr_is_constant a, expr_is_constant b with
61      | Some a, Some b -> Some (a*b)
62      | _ -> None)
63   | <:expr< $a$ / $b$ >> ->             (* Division. *)
64     (match expr_is_constant a, expr_is_constant b with
65      | Some a, Some b -> Some (a/b)
66      | _ -> None)
67   | <:expr< $a$ lsl $b$ >> ->           (* Shift left. *)
68     (match expr_is_constant a, expr_is_constant b with
69      | Some a, Some b -> Some (a lsl b)
70      | _ -> None)
71   | <:expr< $a$ lsr $b$ >> ->           (* Shift right. *)
72     (match expr_is_constant a, expr_is_constant b with
73      | Some a, Some b -> Some (a lsr b)
74      | _ -> None)
75   | _ -> None                           (* Anything else is not constant. *)
76
77 (* Generate a fresh, unique symbol each time called. *)
78 let gensym =
79   let i = ref 1000 in
80   fun name ->
81     incr i; let i = !i in
82     sprintf "__pabitmatch_%s_%d" name i
83
84 (* Deal with the qualifiers which appear for a field of both types. *)
85 let parse_field _loc field qs =
86   let endian_set, signed_set, type_set, field =
87     match qs with
88     | None -> (false, false, false, field)
89     | Some qs ->
90         List.fold_left (
91           fun (endian_set, signed_set, type_set, field) qual_expr ->
92             match qual_expr with
93             | "bigendian", None ->
94                 if endian_set then
95                   Loc.raise _loc (Failure "an endian flag has been set already")
96                 else (
97                   let field = P.set_endian field BigEndian in
98                   (true, signed_set, type_set, field)
99                 )
100             | "littleendian", None ->
101                 if endian_set then
102                   Loc.raise _loc (Failure "an endian flag has been set already")
103                 else (
104                   let field = P.set_endian field LittleEndian in
105                   (true, signed_set, type_set, field)
106                 )
107             | "nativeendian", None ->
108                 if endian_set then
109                   Loc.raise _loc (Failure "an endian flag has been set already")
110                 else (
111                   let field = P.set_endian field NativeEndian in
112                   (true, signed_set, type_set, field)
113                 )
114             | "endian", Some expr ->
115                 if endian_set then
116                   Loc.raise _loc (Failure "an endian flag has been set already")
117                 else (
118                   let field = P.set_endian_expr field expr in
119                   (true, signed_set, type_set, field)
120                 )
121             | "signed", None ->
122                 if signed_set then
123                   Loc.raise _loc (Failure "a signed flag has been set already")
124                 else (
125                   let field = P.set_signed field true in
126                   (endian_set, true, type_set, field)
127                 )
128             | "unsigned", None ->
129                 if signed_set then
130                   Loc.raise _loc (Failure "a signed flag has been set already")
131                 else (
132                   let field = P.set_signed field false in
133                   (endian_set, true, type_set, field)
134                 )
135             | "int", None ->
136                 if type_set then
137                   Loc.raise _loc (Failure "a type flag has been set already")
138                 else (
139                   let field = P.set_type_int field in
140                   (endian_set, signed_set, true, field)
141                 )
142             | "string", None ->
143                 if type_set then
144                   Loc.raise _loc (Failure "a type flag has been set already")
145                 else (
146                   let field = P.set_type_string field in
147                   (endian_set, signed_set, true, field)
148                 )
149             | "bitstring", None ->
150                 if type_set then
151                   Loc.raise _loc (Failure "a type flag has been set already")
152                 else (
153                   let field = P.set_type_bitstring field in
154                   (endian_set, signed_set, true, field)
155                 )
156             | s, Some _ ->
157                 Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should not be followed by an expression"))
158             | s, None ->
159                 Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should be followed by an expression"))
160         ) (false, false, false, field) qs in
161
162   (* If type is set to string or bitstring then endianness and
163    * signedness qualifiers are meaningless and must not be set.
164    *)
165   let () =
166     let t = P.get_type field in
167     if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
168       Loc.raise _loc (
169         Failure "string types and endian or signed qualifiers cannot be mixed"
170       ) in
171
172   (* Default endianness, signedness, type if not set already. *)
173   let field = if endian_set then field else P.set_endian field BigEndian in
174   let field = if signed_set then field else P.set_signed field false in
175   let field = if type_set then field else P.set_type_int field in
176
177   field
178
179 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
180 let output_constructor _loc fields =
181   let loc_fname = Loc.file_name _loc in
182   let loc_line = string_of_int (Loc.start_line _loc) in
183   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
184
185   (* Bitstrings are created like the 'Buffer' module (in fact, using
186    * the Buffer module), by appending snippets to a growing buffer.
187    * This is reasonably efficient and avoids a lot of garbage.
188    *)
189   let buffer = gensym "buffer" in
190
191   (* General exception which is raised inside the constructor functions
192    * when an int expression is out of range at runtime.
193    *)
194   let exn = gensym "exn" in
195   let exn_used = ref false in
196
197   (* Convert each field to a simple bitstring-generating expression. *)
198   let fields = List.map (
199     fun field ->
200       let fexpr = P.get_expr field in
201       let flen = P.get_length field in
202       let endian = P.get_endian field in
203       let signed = P.get_signed field in
204       let t = P.get_type field in
205       let _loc = P.get_location field in
206
207       (* Is flen an integer constant?  If so, what is it?  This
208        * is very simple-minded and only detects simple constants.
209        *)
210       let flen_is_const = expr_is_constant flen in
211
212       (* Choose the right constructor function. *)
213       let int_construct_const = function
214           (* XXX The meaning of signed/unsigned breaks down at
215            * 31, 32, 63 and 64 bits.
216            *)
217         | (1, _, _) ->
218             <:expr<Bitmatch.construct_bit>>
219         | ((2|3|4|5|6|7|8), _, false) ->
220             <:expr<Bitmatch.construct_char_unsigned>>
221         | ((2|3|4|5|6|7|8), _, true) ->
222             <:expr<Bitmatch.construct_char_signed>>
223         | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
224             <:expr<Bitmatch.construct_int_be_unsigned>>
225         | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
226             <:expr<Bitmatch.construct_int_be_signed>>
227         | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
228             <:expr<Bitmatch.construct_int_le_unsigned>>
229         | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
230             <:expr<Bitmatch.construct_int_le_signed>>
231         | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
232             <:expr<Bitmatch.construct_int_ne_unsigned>>
233         | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
234             <:expr<Bitmatch.construct_int_ne_signed>>
235         | (i, P.EndianExpr expr, false) when i <= 31 ->
236             <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
237         | (i, P.EndianExpr expr, true) when i <= 31 ->
238             <:expr<Bitmatch.construct_int_ee_signed $expr$>>
239         | (32, P.ConstantEndian BigEndian, false) ->
240             <:expr<Bitmatch.construct_int32_be_unsigned>>
241         | (32, P.ConstantEndian BigEndian, true) ->
242             <:expr<Bitmatch.construct_int32_be_signed>>
243         | (32, P.ConstantEndian LittleEndian, false) ->
244             <:expr<Bitmatch.construct_int32_le_unsigned>>
245         | (32, P.ConstantEndian LittleEndian, true) ->
246             <:expr<Bitmatch.construct_int32_le_signed>>
247         | (32, P.ConstantEndian NativeEndian, false) ->
248             <:expr<Bitmatch.construct_int32_ne_unsigned>>
249         | (32, P.ConstantEndian NativeEndian, true) ->
250             <:expr<Bitmatch.construct_int32_ne_signed>>
251         | (32, P.EndianExpr expr, false) ->
252             <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
253         | (32, P.EndianExpr expr, true) ->
254             <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
255         | (_, P.ConstantEndian BigEndian, false) ->
256             <:expr<Bitmatch.construct_int64_be_unsigned>>
257         | (_, P.ConstantEndian BigEndian, true) ->
258             <:expr<Bitmatch.construct_int64_be_signed>>
259         | (_, P.ConstantEndian LittleEndian, false) ->
260             <:expr<Bitmatch.construct_int64_le_unsigned>>
261         | (_, P.ConstantEndian LittleEndian, true) ->
262             <:expr<Bitmatch.construct_int64_le_signed>>
263         | (_, P.ConstantEndian NativeEndian, false) ->
264             <:expr<Bitmatch.construct_int64_ne_unsigned>>
265         | (_, P.ConstantEndian NativeEndian, true) ->
266             <:expr<Bitmatch.construct_int64_ne_signed>>
267         | (_, P.EndianExpr expr, false) ->
268             <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
269         | (_, P.EndianExpr expr, true) ->
270             <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
271       in
272       let int_construct = function
273         | (P.ConstantEndian BigEndian, false) ->
274             <:expr<Bitmatch.construct_int64_be_unsigned>>
275         | (P.ConstantEndian BigEndian, true) ->
276             <:expr<Bitmatch.construct_int64_be_signed>>
277         | (P.ConstantEndian LittleEndian, false) ->
278             <:expr<Bitmatch.construct_int64_le_unsigned>>
279         | (P.ConstantEndian LittleEndian, true) ->
280             <:expr<Bitmatch.construct_int64_le_signed>>
281         | (P.ConstantEndian NativeEndian, false) ->
282             <:expr<Bitmatch.construct_int64_ne_unsigned>>
283         | (P.ConstantEndian NativeEndian, true) ->
284             <:expr<Bitmatch.construct_int64_ne_signed>>
285         | (P.EndianExpr expr, false) ->
286             <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
287         | (P.EndianExpr expr, true) ->
288             <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
289       in
290
291       let expr =
292         match t, flen_is_const with
293         (* Common case: int field, constant flen.
294          *
295          * Range checks are done inside the construction function
296          * because that's a lot simpler w.r.t. types.  It might
297          * be better to move them here. XXX
298          *)
299         | P.Int, Some i when i > 0 && i <= 64 ->
300             let construct_fn = int_construct_const (i,endian,signed) in
301             exn_used := true;
302
303             <:expr<
304               $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
305             >>
306
307         | P.Int, Some _ ->
308             Loc.raise _loc (Failure "length of int field must be [1..64]")
309
310         (* Int field, non-constant length.  We need to perform a runtime
311          * test to ensure the length is [1..64].
312          *
313          * Range checks are done inside the construction function
314          * because that's a lot simpler w.r.t. types.  It might
315          * be better to move them here. XXX
316          *)
317         | P.Int, None ->
318             let construct_fn = int_construct (endian,signed) in
319             exn_used := true;
320
321             <:expr<
322               if $flen$ >= 1 && $flen$ <= 64 then
323                 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
324               else
325                 raise (Bitmatch.Construct_failure
326                          ("length of int field must be [1..64]",
327                           $str:loc_fname$,
328                           $int:loc_line$, $int:loc_char$))
329             >>
330
331         (* String, constant length > 0, must be a multiple of 8. *)
332         | P.String, Some i when i > 0 && i land 7 = 0 ->
333             let bs = gensym "bs" in
334             let j = i lsr 3 in
335             <:expr<
336               let $lid:bs$ = $fexpr$ in
337               if String.length $lid:bs$ = $`int:j$ then
338                 Bitmatch.construct_string $lid:buffer$ $lid:bs$
339               else
340                 raise (Bitmatch.Construct_failure
341                          ("length of string does not match declaration",
342                           $str:loc_fname$,
343                           $int:loc_line$, $int:loc_char$))
344             >>
345
346         (* String, constant length -1, means variable length string
347          * with no checks.
348          *)
349         | P.String, Some (-1) ->
350             <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
351
352         (* String, constant length = 0 is probably an error, and so is
353          * any other value.
354          *)
355         | P.String, Some _ ->
356             Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
357
358         (* String, non-constant length.
359          * We check at runtime that the length is > 0, a multiple of 8,
360          * and matches the declared length.
361          *)
362         | P.String, None ->
363             let bslen = gensym "bslen" in
364             let bs = gensym "bs" in
365             <:expr<
366               let $lid:bslen$ = $flen$ in
367               if $lid:bslen$ > 0 then (
368                 if $lid:bslen$ land 7 = 0 then (
369                   let $lid:bs$ = $fexpr$ in
370                   if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
371                     Bitmatch.construct_string $lid:buffer$ $lid:bs$
372                   else
373                     raise (Bitmatch.Construct_failure
374                              ("length of string does not match declaration",
375                               $str:loc_fname$,
376                               $int:loc_line$, $int:loc_char$))
377                 ) else
378                   raise (Bitmatch.Construct_failure
379                            ("length of string must be a multiple of 8",
380                             $str:loc_fname$,
381                             $int:loc_line$, $int:loc_char$))
382               ) else
383                 raise (Bitmatch.Construct_failure
384                          ("length of string must be > 0",
385                           $str:loc_fname$,
386                           $int:loc_line$, $int:loc_char$))
387             >>
388
389         (* Bitstring, constant length > 0. *)
390         | P.Bitstring, Some i when i > 0 ->
391             let bs = gensym "bs" in
392             <:expr<
393               let $lid:bs$ = $fexpr$ in
394               if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
395                 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
396               else
397                 raise (Bitmatch.Construct_failure
398                          ("length of bitstring does not match declaration",
399                           $str:loc_fname$,
400                           $int:loc_line$, $int:loc_char$))
401             >>
402
403         (* Bitstring, constant length -1, means variable length bitstring
404          * with no checks.
405          *)
406         | P.Bitstring, Some (-1) ->
407             <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
408
409         (* Bitstring, constant length = 0 is probably an error, and so is
410          * any other value.
411          *)
412         | P.Bitstring, Some _ ->
413             Loc.raise _loc
414               (Failure
415                  "length of bitstring must be > 0 or the special value -1")
416
417         (* Bitstring, non-constant length.
418          * We check at runtime that the length is > 0 and matches
419          * the declared length.
420          *)
421         | P.Bitstring, None ->
422             let bslen = gensym "bslen" in
423             let bs = gensym "bs" in
424             <:expr<
425               let $lid:bslen$ = $flen$ in
426               if $lid:bslen$ > 0 then (
427                 let $lid:bs$ = $fexpr$ in
428                 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
429                   Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
430                 else
431                   raise (Bitmatch.Construct_failure
432                            ("length of bitstring does not match declaration",
433                             $str:loc_fname$,
434                             $int:loc_line$, $int:loc_char$))
435               ) else
436                 raise (Bitmatch.Construct_failure
437                          ("length of bitstring must be > 0",
438                           $str:loc_fname$,
439                           $int:loc_line$, $int:loc_char$))
440             >> in
441       expr
442   ) fields in
443
444   (* Create the final bitstring.  Start by creating an empty buffer
445    * and then evaluate each expression above in turn which will
446    * append some more to the bitstring buffer.  Finally extract
447    * the bitstring.
448    *
449    * XXX We almost have enough information to be able to guess
450    * a good initial size for the buffer.
451    *)
452   let fields =
453     match fields with
454     | [] -> <:expr< [] >>
455     | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
456
457   let expr =
458     <:expr<
459       let $lid:buffer$ = Bitmatch.Buffer.create () in
460       $fields$;
461       Bitmatch.Buffer.contents $lid:buffer$
462     >> in
463
464   if !exn_used then
465     <:expr<
466       let $lid:exn$ =
467         Bitmatch.Construct_failure ("value out of range",
468                                     $str:loc_fname$,
469                                     $int:loc_line$, $int:loc_char$) in
470         $expr$
471     >>
472   else
473     expr
474
475 (* Generate the code for a bitmatch statement.  '_loc' is the
476  * location, 'bs' is the bitstring parameter, 'cases' are
477  * the list of cases to test against.
478  *)
479 let output_bitmatch _loc bs cases =
480   let data = gensym "data" and off = gensym "off" and len = gensym "len" in
481   let result = gensym "result" in
482
483   (* This generates the field extraction code for each
484    * field a single case.  Each field must be wider than
485    * the minimum permitted for the type and there must be
486    * enough remaining data in the bitstring to satisfy it.
487    * As we go through the fields, symbols 'data', 'off' and 'len'
488    * track our position and remaining length in the bitstring.
489    *
490    * The whole thing is a lot of nested 'if' statements. Code
491    * is generated from the inner-most (last) field outwards.
492    *)
493   let rec output_field_extraction inner = function
494     | [] -> inner
495     | field :: fields ->
496         let fpatt = P.get_patt field in
497         let flen = P.get_length field in
498         let endian = P.get_endian field in
499         let signed = P.get_signed field in
500         let t = P.get_type field in
501         let _loc = P.get_location field in
502
503         (* Is flen an integer constant?  If so, what is it?  This
504          * is very simple-minded and only detects simple constants.
505          *)
506         let flen_is_const = expr_is_constant flen in
507
508         let int_extract_const = function
509             (* XXX The meaning of signed/unsigned breaks down at
510              * 31, 32, 63 and 64 bits.
511              *)
512           | (1, _, _) ->
513               <:expr<Bitmatch.extract_bit>>
514           | ((2|3|4|5|6|7|8), _, false) ->
515               <:expr<Bitmatch.extract_char_unsigned>>
516           | ((2|3|4|5|6|7|8), _, true) ->
517               <:expr<Bitmatch.extract_char_signed>>
518           | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
519               <:expr<Bitmatch.extract_int_be_unsigned>>
520           | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
521               <:expr<Bitmatch.extract_int_be_signed>>
522           | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
523               <:expr<Bitmatch.extract_int_le_unsigned>>
524           | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
525               <:expr<Bitmatch.extract_int_le_signed>>
526           | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
527               <:expr<Bitmatch.extract_int_ne_unsigned>>
528           | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
529               <:expr<Bitmatch.extract_int_ne_signed>>
530           | (i, P.EndianExpr expr, false) when i <= 31 ->
531               <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
532           | (i, P.EndianExpr expr, true) when i <= 31 ->
533               <:expr<Bitmatch.extract_int_ee_signed $expr$>>
534           | (32, P.ConstantEndian BigEndian, false) ->
535               <:expr<Bitmatch.extract_int32_be_unsigned>>
536           | (32, P.ConstantEndian BigEndian, true) ->
537               <:expr<Bitmatch.extract_int32_be_signed>>
538           | (32, P.ConstantEndian LittleEndian, false) ->
539               <:expr<Bitmatch.extract_int32_le_unsigned>>
540           | (32, P.ConstantEndian LittleEndian, true) ->
541               <:expr<Bitmatch.extract_int32_le_signed>>
542           | (32, P.ConstantEndian NativeEndian, false) ->
543               <:expr<Bitmatch.extract_int32_ne_unsigned>>
544           | (32, P.ConstantEndian NativeEndian, true) ->
545               <:expr<Bitmatch.extract_int32_ne_signed>>
546           | (32, P.EndianExpr expr, false) ->
547               <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
548           | (32, P.EndianExpr expr, true) ->
549               <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
550           | (_, P.ConstantEndian BigEndian, false) ->
551               <:expr<Bitmatch.extract_int64_be_unsigned>>
552           | (_, P.ConstantEndian BigEndian, true) ->
553               <:expr<Bitmatch.extract_int64_be_signed>>
554           | (_, P.ConstantEndian LittleEndian, false) ->
555               <:expr<Bitmatch.extract_int64_le_unsigned>>
556           | (_, P.ConstantEndian LittleEndian, true) ->
557               <:expr<Bitmatch.extract_int64_le_signed>>
558           | (_, P.ConstantEndian NativeEndian, false) ->
559               <:expr<Bitmatch.extract_int64_ne_unsigned>>
560           | (_, P.ConstantEndian NativeEndian, true) ->
561               <:expr<Bitmatch.extract_int64_ne_signed>>
562           | (_, P.EndianExpr expr, false) ->
563               <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
564           | (_, P.EndianExpr expr, true) ->
565               <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
566         in
567         let int_extract = function
568           | (P.ConstantEndian BigEndian, false) ->
569               <:expr<Bitmatch.extract_int64_be_unsigned>>
570           | (P.ConstantEndian BigEndian, true) ->
571               <:expr<Bitmatch.extract_int64_be_signed>>
572           | (P.ConstantEndian LittleEndian, false) ->
573               <:expr<Bitmatch.extract_int64_le_unsigned>>
574           | (P.ConstantEndian LittleEndian, true) ->
575               <:expr<Bitmatch.extract_int64_le_signed>>
576           | (P.ConstantEndian NativeEndian, false) ->
577               <:expr<Bitmatch.extract_int64_ne_unsigned>>
578           | (P.ConstantEndian NativeEndian, true) ->
579               <:expr<Bitmatch.extract_int64_ne_signed>>
580           | (P.EndianExpr expr, false) ->
581               <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
582           | (P.EndianExpr expr, true) ->
583               <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
584         in
585
586         let expr =
587           match t, flen_is_const with
588           (* Common case: int field, constant flen *)
589           | P.Int, Some i when i > 0 && i <= 64 ->
590               let extract_fn = int_extract_const (i,endian,signed) in
591               let v = gensym "val" in
592               <:expr<
593                 if $lid:len$ >= $`int:i$ then (
594                   let $lid:v$, $lid:off$, $lid:len$ =
595                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
596                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
597                 )
598               >>
599
600           | P.Int, Some _ ->
601               Loc.raise _loc (Failure "length of int field must be [1..64]")
602
603           (* Int field, non-const flen.  We have to test the range of
604            * the field at runtime.  If outside the range it's a no-match
605            * (not an error).
606            *)
607           | P.Int, None ->
608               let extract_fn = int_extract (endian,signed) in
609               let v = gensym "val" in
610               <:expr<
611                 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
612                   let $lid:v$, $lid:off$, $lid:len$ =
613                     $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
614                   match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
615                 )
616               >>
617
618           (* String, constant flen > 0. *)
619           | P.String, Some i when i > 0 && i land 7 = 0 ->
620               let bs = gensym "bs" in
621               <:expr<
622                 if $lid:len$ >= $`int:i$ then (
623                   let $lid:bs$, $lid:off$, $lid:len$ =
624                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
625                       $`int:i$ in
626                   match Bitmatch.string_of_bitstring $lid:bs$ with
627                   | $fpatt$ when true -> $inner$
628                   | _ -> ()
629                 )
630               >>
631
632           (* String, constant flen = -1, means consume all the
633            * rest of the input.
634            *)
635           | P.String, Some i when i = -1 ->
636               let bs = gensym "bs" in
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$ when true -> $inner$
642                 | _ -> ()
643               >>
644
645           | P.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           | P.String, None ->
652               let bs = gensym "bs" in
653               <:expr<
654                 if $flen$ >= 0 && $flen$ <= $lid:len$
655                   && $flen$ land 7 = 0 then (
656                     let $lid:bs$, $lid:off$, $lid:len$ =
657                       Bitmatch.extract_bitstring
658                         $lid:data$ $lid:off$ $lid:len$ $flen$ in
659                     match Bitmatch.string_of_bitstring $lid:bs$ with
660                     | $fpatt$ when true -> $inner$
661                     | _ -> ()
662                   )
663               >>
664
665           (* Bitstring, constant flen >= 0.
666            * At the moment all we can do is assign the bitstring to an
667            * identifier.
668            *)
669           | P.Bitstring, Some i when i >= 0 ->
670               let ident =
671                 match fpatt with
672                 | <:patt< $lid:ident$ >> -> ident
673                 | <:patt< _ >> -> "_"
674                 | _ ->
675                     Loc.raise _loc
676                       (Failure "cannot compare a bitstring to a constant") in
677               <:expr<
678                 if $lid:len$ >= $`int:i$ then (
679                   let $lid:ident$, $lid:off$, $lid:len$ =
680                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
681                       $`int:i$ in
682                   $inner$
683                 )
684               >>
685
686           (* Bitstring, constant flen = -1, means consume all the
687            * rest of the input.
688            *)
689           | P.Bitstring, Some i when i = -1 ->
690               let ident =
691                 match fpatt with
692                 | <:patt< $lid:ident$ >> -> ident
693                 | <:patt< _ >> -> "_"
694                 | _ ->
695                     Loc.raise _loc
696                       (Failure "cannot compare a bitstring to a constant") in
697               <:expr<
698                 let $lid:ident$, $lid:off$, $lid:len$ =
699                   Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
700                   $inner$
701               >>
702
703           | P.Bitstring, Some _ ->
704               Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
705
706           (* Bitstring field, non-const flen.  We check the flen is >= 0
707            * (-1 is not allowed here) at runtime.
708            *)
709           | P.Bitstring, None ->
710               let ident =
711                 match fpatt with
712                 | <:patt< $lid:ident$ >> -> ident
713                 | <:patt< _ >> -> "_"
714                 | _ ->
715                     Loc.raise _loc
716                       (Failure "cannot compare a bitstring to a constant") in
717               <:expr<
718                 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
719                   let $lid:ident$, $lid:off$, $lid:len$ =
720                     Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
721                       $flen$ in
722                   $inner$
723                 )
724               >>
725         in
726
727         (* Emit extra debugging code. *)
728         let expr =
729           if not debug then expr else (
730             let field = P.string_of_field field in
731
732             <:expr<
733               if !Bitmatch.debug then (
734                 Printf.eprintf "PA_BITMATCH: TEST:\n";
735                 Printf.eprintf "  %s\n" $str:field$;
736                 Printf.eprintf "  off %d len %d\n%!" $lid:off$ $lid:len$;
737                 (*Bitmatch.hexdump_bitstring stderr
738                   ($lid:data$,$lid:off$,$lid:len$);*)
739               );
740               $expr$
741             >>
742           ) in
743
744         output_field_extraction expr fields
745   in
746
747   (* Convert each case in the match. *)
748   let cases = List.map (
749     fun (fields, bind, whenclause, code) ->
750       let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
751       let inner =
752         match whenclause with
753         | Some whenclause ->
754             <:expr< if $whenclause$ then $inner$ >>
755         | None -> inner in
756       let inner =
757         match bind with
758         | Some name ->
759             <:expr<
760               let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
761               $inner$
762               >>
763         | None -> inner in
764       output_field_extraction inner (List.rev fields)
765   ) cases in
766
767   (* Join them into a single expression.
768    *
769    * Don't do it with a normal fold_right because that leaves
770    * 'raise Exit; ()' at the end which causes a compiler warning.
771    * Hence a bit of complexity here.
772    *
773    * Note that the number of cases is always >= 1 so List.hd is safe.
774    *)
775   let cases = List.rev cases in
776   let cases =
777     List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
778       (List.hd cases) (List.tl cases) in
779
780   (* The final code just wraps the list of cases in a
781    * try/with construct so that each case is tried in
782    * turn until one case matches (that case sets 'result'
783    * and raises 'Exit' to leave the whole statement).
784    * If result isn't set by the end then we will raise
785    * Match_failure with the location of the bitmatch
786    * statement in the original code.
787    *)
788   let loc_fname = Loc.file_name _loc in
789   let loc_line = string_of_int (Loc.start_line _loc) in
790   let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
791
792   <:expr<
793     let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
794     let $lid:result$ = ref None in
795     (try
796       $cases$
797     with Exit -> ());
798     match ! $lid:result$ with
799     | Some x -> x
800     | None -> raise (Match_failure ($str:loc_fname$,
801                                     $int:loc_line$, $int:loc_char$))
802   >>
803
804 (* Add a named pattern. *)
805 let add_named_pattern _loc name pattern =
806   Hashtbl.add pattern_hash name pattern
807
808 (* Expand a named pattern from the pattern_hash. *)
809 let expand_named_pattern _loc name =
810   try Hashtbl.find pattern_hash name
811   with Not_found ->
812     Loc.raise _loc (Failure (sprintf "named pattern not found: %s" name))
813
814 (* Add named patterns from a file.  See the documentation on the
815  * directory search path in bitmatch_persistent.mli
816  *)
817 let load_patterns_from_file _loc filename =
818   let chan =
819     if Filename.is_relative filename && Filename.is_implicit filename then (
820       (* Try current directory. *)
821       try open_in filename
822       with _ ->
823         (* Try OCaml library directory. *)
824         try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
825         with exn -> Loc.raise _loc exn
826     ) else (
827       try open_in filename
828       with exn -> Loc.raise _loc exn
829     ) in
830   let names = ref [] in
831   (try
832      let rec loop () =
833        let name = P.named_from_channel chan in
834        names := name :: !names
835      in
836      loop ()
837    with End_of_file -> ()
838   );
839   close_in chan;
840   let names = List.rev !names in
841   List.iter (
842     function
843     | name, P.Pattern patt -> add_named_pattern _loc name patt
844     | _, P.Constructor _ -> () (* just ignore these for now *)
845   ) names
846
847 EXTEND Gram
848   GLOBAL: expr str_item;
849
850   (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
851    * followed by an optional expression (used in certain cases).  Note
852    * that we are careful not to declare any explicit reserved words.
853    *)
854   qualifiers: [
855     [ LIST0
856         [ q = LIDENT;
857           e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
858         SEP "," ]
859   ];
860
861   (* Field used in the bitmatch operator (a pattern).  This can actually
862    * return multiple fields, in the case where the 'field' is a named
863    * persitent pattern.
864    *)
865   patt_field: [
866     [ fpatt = patt; ":"; len = expr LEVEL "top";
867       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
868         let field = P.create_pattern_field _loc in
869         let field = P.set_patt field fpatt in
870         let field = P.set_length field len in
871         [parse_field _loc field qs]     (* Normal, single field. *)
872     | ":"; name = LIDENT ->
873         expand_named_pattern _loc name (* Named -> list of fields. *)
874     ]
875   ];
876
877   (* Case inside bitmatch operator. *)
878   patt_fields: [
879     [ "{";
880       fields = LIST0 patt_field SEP ";";
881       "}" ->
882         List.concat fields
883     ]
884   ];
885
886   patt_case: [
887     [ fields = patt_fields;
888       bind = OPT [ "as"; name = LIDENT -> name ];
889       whenclause = OPT [ "when"; e = expr -> e ]; "->";
890       code = expr ->
891         (fields, bind, whenclause, code)
892     ]
893   ];
894
895   (* Field used in the BITSTRING constructor (an expression). *)
896   constr_field: [
897     [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
898       qs = OPT [ ":"; qs = qualifiers -> qs ] ->
899         let field = P.create_constructor_field _loc in
900         let field = P.set_expr field fexpr in
901         let field = P.set_length field len in
902         parse_field _loc field qs
903     ]
904   ];
905
906   constr_fields: [
907     [ "{";
908       fields = LIST0 constr_field SEP ";";
909       "}" ->
910         fields
911     ]
912   ];
913
914   (* 'bitmatch' expressions. *)
915   expr: LEVEL ";" [
916     [ "bitmatch";
917       bs = expr; "with"; OPT "|";
918       cases = LIST1 patt_case SEP "|" ->
919         output_bitmatch _loc bs cases
920     ]
921
922   (* Constructor. *)
923   | [ "BITSTRING";
924       fields = constr_fields ->
925         output_constructor _loc fields
926     ]
927   ];
928
929   (* Named persistent patterns.
930    *
931    * NB: Currently only allowed at the top level.  We can probably lift
932    * this restriction later if necessary.  We only deal with patterns
933    * at the moment, not constructors, but the infrastructure to do
934    * constructors is in place.
935    *)
936   str_item: LEVEL "top" [
937     [ "let"; "bitmatch";
938       name = LIDENT; "="; fields = patt_fields ->
939         add_named_pattern _loc name fields;
940         (* The statement disappears, but we still need a str_item so ... *)
941         <:str_item< >>
942     | "open"; "bitmatch"; filename = STRING ->
943         load_patterns_from_file _loc filename;
944         <:str_item< >>
945     ]
946   ];
947
948 END