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