1 (* Bitmatch syntax extension.
2 * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
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.
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.
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
28 module P = Bitmatch_persistent
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.
34 * If this is false then no extra debugging code is emitted.
38 (* Hashtable storing named persistent patterns. *)
39 let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
41 let locfail _loc msg = Loc.raise _loc (Failure msg)
43 (* Work out if an expression is an integer constant.
45 * Returns [Some i] if so (where i is the integer value), else [None].
47 * Fairly simplistic algorithm: we can only detect simple constant
48 * expressions such as [k], [k+c], [k-c] etc.
50 let rec expr_is_constant = function
51 | <:expr< $int:i$ >> -> (* Literal integer constant. *)
52 Some (int_of_string i)
53 | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
54 (match expr_is_constant a, expr_is_constant b with
55 | Some a, Some b -> Some (a+b)
57 | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
58 (match expr_is_constant a, expr_is_constant b with
59 | Some a, Some b -> Some (a-b)
61 | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
62 (match expr_is_constant a, expr_is_constant b with
63 | Some a, Some b -> Some (a*b)
65 | <:expr< $a$ / $b$ >> -> (* Division. *)
66 (match expr_is_constant a, expr_is_constant b with
67 | Some a, Some b -> Some (a/b)
69 | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
70 (match expr_is_constant a, expr_is_constant b with
71 | Some a, Some b -> Some (a lsl b)
73 | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
74 (match expr_is_constant a, expr_is_constant b with
75 | Some a, Some b -> Some (a lsr b)
77 | _ -> None (* Anything else is not constant. *)
79 (* Generate a fresh, unique symbol each time called. *)
84 sprintf "__pabitmatch_%s_%d" name i
86 (* Deal with the qualifiers which appear for a field of both types. *)
87 let parse_field _loc field qs =
88 let fail = locfail _loc in
90 let endian_set, signed_set, type_set, offset_set, field =
92 | None -> (false, false, false, false, field)
95 fun (endian_set, signed_set, type_set, offset_set, field) qual_expr ->
97 | "bigendian", None ->
99 fail "an endian flag has been set already"
101 let field = P.set_endian field BigEndian in
102 (true, signed_set, type_set, offset_set, field)
104 | "littleendian", None ->
106 fail "an endian flag has been set already"
108 let field = P.set_endian field LittleEndian in
109 (true, signed_set, type_set, offset_set, field)
111 | "nativeendian", None ->
113 fail "an endian flag has been set already"
115 let field = P.set_endian field NativeEndian in
116 (true, signed_set, type_set, offset_set, field)
118 | "endian", Some expr ->
120 fail "an endian flag has been set already"
122 let field = P.set_endian_expr field expr in
123 (true, signed_set, type_set, offset_set, field)
127 fail "a signed flag has been set already"
129 let field = P.set_signed field true in
130 (endian_set, true, type_set, offset_set, field)
132 | "unsigned", None ->
134 fail "a signed flag has been set already"
136 let field = P.set_signed field false in
137 (endian_set, true, type_set, offset_set, field)
141 fail "a type flag has been set already"
143 let field = P.set_type_int field in
144 (endian_set, signed_set, true, offset_set, field)
148 fail "a type flag has been set already"
150 let field = P.set_type_string field in
151 (endian_set, signed_set, true, offset_set, field)
153 | "bitstring", None ->
155 fail "a type flag has been set already"
157 let field = P.set_type_bitstring field in
158 (endian_set, signed_set, true, offset_set, field)
160 | "offset", Some expr ->
162 fail "an offset has been set already"
164 let field = P.set_offset field expr in
165 (endian_set, signed_set, type_set, true, field)
168 fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
170 fail (s ^ ": unknown qualifier, or qualifier should be followed by an expression")
171 ) (false, false, false, false, field) qs in
173 (* If type is set to string or bitstring then endianness and
174 * signedness qualifiers are meaningless and must not be set.
177 let t = P.get_type field in
178 if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
179 fail "string types and endian or signed qualifiers cannot be mixed" in
181 (* Default endianness, signedness, type if not set already. *)
182 let field = if endian_set then field else P.set_endian field BigEndian in
183 let field = if signed_set then field else P.set_signed field false in
184 let field = if type_set then field else P.set_type_int field in
188 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
189 let output_constructor _loc fields =
190 let fail = locfail _loc in
192 let loc_fname = Loc.file_name _loc in
193 let loc_line = string_of_int (Loc.start_line _loc) in
194 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
196 (* Bitstrings are created like the 'Buffer' module (in fact, using
197 * the Buffer module), by appending snippets to a growing buffer.
198 * This is reasonably efficient and avoids a lot of garbage.
200 let buffer = gensym "buffer" in
202 (* General exception which is raised inside the constructor functions
203 * when an int expression is out of range at runtime.
205 let exn = gensym "exn" in
206 let exn_used = ref false in
208 (* Convert each field to a simple bitstring-generating expression. *)
209 let fields = List.map (
211 let fexpr = P.get_expr field in
212 let flen = P.get_length field in
213 let endian = P.get_endian field in
214 let signed = P.get_signed field in
215 let t = P.get_type field in
216 let _loc = P.get_location field in
217 let offset = P.get_offset field in
219 (* offset() not supported in constructors. Implementation of
220 * forward-only offsets is fairly straightforward: we would
221 * need to just calculate the length of padding here and add
222 * it to what has been constructed. For general offsets,
223 * including going backwards, that would require a rethink in
224 * how we construct bitstrings.
226 if offset <> None then
227 fail "offset expressions are not supported in BITSTRING constructors";
229 (* Is flen an integer constant? If so, what is it? This
230 * is very simple-minded and only detects simple constants.
232 let flen_is_const = expr_is_constant flen in
234 (* Choose the right constructor function. *)
235 let int_construct_const = function
236 (* XXX The meaning of signed/unsigned breaks down at
237 * 31, 32, 63 and 64 bits.
240 <:expr<Bitmatch.construct_bit>>
241 | ((2|3|4|5|6|7|8), _, false) ->
242 <:expr<Bitmatch.construct_char_unsigned>>
243 | ((2|3|4|5|6|7|8), _, true) ->
244 <:expr<Bitmatch.construct_char_signed>>
245 | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
246 <:expr<Bitmatch.construct_int_be_unsigned>>
247 | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
248 <:expr<Bitmatch.construct_int_be_signed>>
249 | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
250 <:expr<Bitmatch.construct_int_le_unsigned>>
251 | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
252 <:expr<Bitmatch.construct_int_le_signed>>
253 | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
254 <:expr<Bitmatch.construct_int_ne_unsigned>>
255 | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
256 <:expr<Bitmatch.construct_int_ne_signed>>
257 | (i, P.EndianExpr expr, false) when i <= 31 ->
258 <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
259 | (i, P.EndianExpr expr, true) when i <= 31 ->
260 <:expr<Bitmatch.construct_int_ee_signed $expr$>>
261 | (32, P.ConstantEndian BigEndian, false) ->
262 <:expr<Bitmatch.construct_int32_be_unsigned>>
263 | (32, P.ConstantEndian BigEndian, true) ->
264 <:expr<Bitmatch.construct_int32_be_signed>>
265 | (32, P.ConstantEndian LittleEndian, false) ->
266 <:expr<Bitmatch.construct_int32_le_unsigned>>
267 | (32, P.ConstantEndian LittleEndian, true) ->
268 <:expr<Bitmatch.construct_int32_le_signed>>
269 | (32, P.ConstantEndian NativeEndian, false) ->
270 <:expr<Bitmatch.construct_int32_ne_unsigned>>
271 | (32, P.ConstantEndian NativeEndian, true) ->
272 <:expr<Bitmatch.construct_int32_ne_signed>>
273 | (32, P.EndianExpr expr, false) ->
274 <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
275 | (32, P.EndianExpr expr, true) ->
276 <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
277 | (_, P.ConstantEndian BigEndian, false) ->
278 <:expr<Bitmatch.construct_int64_be_unsigned>>
279 | (_, P.ConstantEndian BigEndian, true) ->
280 <:expr<Bitmatch.construct_int64_be_signed>>
281 | (_, P.ConstantEndian LittleEndian, false) ->
282 <:expr<Bitmatch.construct_int64_le_unsigned>>
283 | (_, P.ConstantEndian LittleEndian, true) ->
284 <:expr<Bitmatch.construct_int64_le_signed>>
285 | (_, P.ConstantEndian NativeEndian, false) ->
286 <:expr<Bitmatch.construct_int64_ne_unsigned>>
287 | (_, P.ConstantEndian NativeEndian, true) ->
288 <:expr<Bitmatch.construct_int64_ne_signed>>
289 | (_, P.EndianExpr expr, false) ->
290 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
291 | (_, P.EndianExpr expr, true) ->
292 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
294 let int_construct = function
295 | (P.ConstantEndian BigEndian, false) ->
296 <:expr<Bitmatch.construct_int64_be_unsigned>>
297 | (P.ConstantEndian BigEndian, true) ->
298 <:expr<Bitmatch.construct_int64_be_signed>>
299 | (P.ConstantEndian LittleEndian, false) ->
300 <:expr<Bitmatch.construct_int64_le_unsigned>>
301 | (P.ConstantEndian LittleEndian, true) ->
302 <:expr<Bitmatch.construct_int64_le_signed>>
303 | (P.ConstantEndian NativeEndian, false) ->
304 <:expr<Bitmatch.construct_int64_ne_unsigned>>
305 | (P.ConstantEndian NativeEndian, true) ->
306 <:expr<Bitmatch.construct_int64_ne_signed>>
307 | (P.EndianExpr expr, false) ->
308 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
309 | (P.EndianExpr expr, true) ->
310 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
314 match t, flen_is_const with
315 (* Common case: int field, constant flen.
317 * Range checks are done inside the construction function
318 * because that's a lot simpler w.r.t. types. It might
319 * be better to move them here. XXX
321 | P.Int, Some i when i > 0 && i <= 64 ->
322 let construct_fn = int_construct_const (i,endian,signed) in
326 $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
330 fail "length of int field must be [1..64]"
332 (* Int field, non-constant length. We need to perform a runtime
333 * test to ensure the length is [1..64].
335 * Range checks are done inside the construction function
336 * because that's a lot simpler w.r.t. types. It might
337 * be better to move them here. XXX
340 let construct_fn = int_construct (endian,signed) in
344 if $flen$ >= 1 && $flen$ <= 64 then
345 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
347 raise (Bitmatch.Construct_failure
348 ("length of int field must be [1..64]",
350 $int:loc_line$, $int:loc_char$))
353 (* String, constant length > 0, must be a multiple of 8. *)
354 | P.String, Some i when i > 0 && i land 7 = 0 ->
355 let bs = gensym "bs" in
358 let $lid:bs$ = $fexpr$ in
359 if String.length $lid:bs$ = $`int:j$ then
360 Bitmatch.construct_string $lid:buffer$ $lid:bs$
362 raise (Bitmatch.Construct_failure
363 ("length of string does not match declaration",
365 $int:loc_line$, $int:loc_char$))
368 (* String, constant length -1, means variable length string
371 | P.String, Some (-1) ->
372 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
374 (* String, constant length = 0 is probably an error, and so is
377 | P.String, Some _ ->
378 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
380 (* String, non-constant length.
381 * We check at runtime that the length is > 0, a multiple of 8,
382 * and matches the declared length.
385 let bslen = gensym "bslen" in
386 let bs = gensym "bs" in
388 let $lid:bslen$ = $flen$ in
389 if $lid:bslen$ > 0 then (
390 if $lid:bslen$ land 7 = 0 then (
391 let $lid:bs$ = $fexpr$ in
392 if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
393 Bitmatch.construct_string $lid:buffer$ $lid:bs$
395 raise (Bitmatch.Construct_failure
396 ("length of string does not match declaration",
398 $int:loc_line$, $int:loc_char$))
400 raise (Bitmatch.Construct_failure
401 ("length of string must be a multiple of 8",
403 $int:loc_line$, $int:loc_char$))
405 raise (Bitmatch.Construct_failure
406 ("length of string must be > 0",
408 $int:loc_line$, $int:loc_char$))
411 (* Bitstring, constant length >= 0. *)
412 | P.Bitstring, Some i when i >= 0 ->
413 let bs = gensym "bs" in
415 let $lid:bs$ = $fexpr$ in
416 if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
417 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
419 raise (Bitmatch.Construct_failure
420 ("length of bitstring does not match declaration",
422 $int:loc_line$, $int:loc_char$))
425 (* Bitstring, constant length -1, means variable length bitstring
428 | P.Bitstring, Some (-1) ->
429 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
431 (* Bitstring, constant length < -1 is an error. *)
432 | P.Bitstring, Some _ ->
433 fail "length of bitstring must be >= 0 or the special value -1"
435 (* Bitstring, non-constant length.
436 * We check at runtime that the length is >= 0 and matches
437 * the declared length.
439 | P.Bitstring, None ->
440 let bslen = gensym "bslen" in
441 let bs = gensym "bs" in
443 let $lid:bslen$ = $flen$ in
444 if $lid:bslen$ >= 0 then (
445 let $lid:bs$ = $fexpr$ in
446 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
447 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
449 raise (Bitmatch.Construct_failure
450 ("length of bitstring does not match declaration",
452 $int:loc_line$, $int:loc_char$))
454 raise (Bitmatch.Construct_failure
455 ("length of bitstring must be > 0",
457 $int:loc_line$, $int:loc_char$))
462 (* Create the final bitstring. Start by creating an empty buffer
463 * and then evaluate each expression above in turn which will
464 * append some more to the bitstring buffer. Finally extract
467 * XXX We almost have enough information to be able to guess
468 * a good initial size for the buffer.
472 | [] -> <:expr< [] >>
473 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
477 let $lid:buffer$ = Bitmatch.Buffer.create () in
479 Bitmatch.Buffer.contents $lid:buffer$
485 Bitmatch.Construct_failure ("value out of range",
487 $int:loc_line$, $int:loc_char$) in
493 (* Generate the code for a bitmatch statement. '_loc' is the
494 * location, 'bs' is the bitstring parameter, 'cases' are
495 * the list of cases to test against.
497 let output_bitmatch _loc bs cases =
498 let fail = locfail _loc in
500 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
501 let result = gensym "result" in
503 (* This generates the field extraction code for each
504 * field in a single case. There must be enough remaining data
505 * in the bitstring to satisfy the field.
507 * As we go through the fields, symbols 'data', 'off' and 'len'
508 * track our position and remaining length in the bitstring.
510 * The whole thing is a lot of nested 'if' statements. Code
511 * is generated from the inner-most (last) field outwards.
513 let rec output_field_extraction inner = function
516 let fpatt = P.get_patt field in
517 let flen = P.get_length field in
518 let endian = P.get_endian field in
519 let signed = P.get_signed field in
520 let t = P.get_type field in
521 let _loc = P.get_location field in
522 let offset = P.get_offset field in
524 (* Is flen (field len) an integer constant? If so, what is it?
525 * This will be [Some i] if it's a constant or [None] if it's
526 * non-constant or we couldn't determine.
528 let flen_is_const = expr_is_constant flen in
530 let int_extract_const = function
531 (* XXX The meaning of signed/unsigned breaks down at
532 * 31, 32, 63 and 64 bits.
535 <:expr<Bitmatch.extract_bit>>
536 | ((2|3|4|5|6|7|8), _, false) ->
537 <:expr<Bitmatch.extract_char_unsigned>>
538 | ((2|3|4|5|6|7|8), _, true) ->
539 <:expr<Bitmatch.extract_char_signed>>
540 | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
541 <:expr<Bitmatch.extract_int_be_unsigned>>
542 | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
543 <:expr<Bitmatch.extract_int_be_signed>>
544 | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
545 <:expr<Bitmatch.extract_int_le_unsigned>>
546 | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
547 <:expr<Bitmatch.extract_int_le_signed>>
548 | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
549 <:expr<Bitmatch.extract_int_ne_unsigned>>
550 | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
551 <:expr<Bitmatch.extract_int_ne_signed>>
552 | (i, P.EndianExpr expr, false) when i <= 31 ->
553 <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
554 | (i, P.EndianExpr expr, true) when i <= 31 ->
555 <:expr<Bitmatch.extract_int_ee_signed $expr$>>
556 | (32, P.ConstantEndian BigEndian, false) ->
557 <:expr<Bitmatch.extract_int32_be_unsigned>>
558 | (32, P.ConstantEndian BigEndian, true) ->
559 <:expr<Bitmatch.extract_int32_be_signed>>
560 | (32, P.ConstantEndian LittleEndian, false) ->
561 <:expr<Bitmatch.extract_int32_le_unsigned>>
562 | (32, P.ConstantEndian LittleEndian, true) ->
563 <:expr<Bitmatch.extract_int32_le_signed>>
564 | (32, P.ConstantEndian NativeEndian, false) ->
565 <:expr<Bitmatch.extract_int32_ne_unsigned>>
566 | (32, P.ConstantEndian NativeEndian, true) ->
567 <:expr<Bitmatch.extract_int32_ne_signed>>
568 | (32, P.EndianExpr expr, false) ->
569 <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
570 | (32, P.EndianExpr expr, true) ->
571 <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
572 | (_, P.ConstantEndian BigEndian, false) ->
573 <:expr<Bitmatch.extract_int64_be_unsigned>>
574 | (_, P.ConstantEndian BigEndian, true) ->
575 <:expr<Bitmatch.extract_int64_be_signed>>
576 | (_, P.ConstantEndian LittleEndian, false) ->
577 <:expr<Bitmatch.extract_int64_le_unsigned>>
578 | (_, P.ConstantEndian LittleEndian, true) ->
579 <:expr<Bitmatch.extract_int64_le_signed>>
580 | (_, P.ConstantEndian NativeEndian, false) ->
581 <:expr<Bitmatch.extract_int64_ne_unsigned>>
582 | (_, P.ConstantEndian NativeEndian, true) ->
583 <:expr<Bitmatch.extract_int64_ne_signed>>
584 | (_, P.EndianExpr expr, false) ->
585 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
586 | (_, P.EndianExpr expr, true) ->
587 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
589 let int_extract = function
590 | (P.ConstantEndian BigEndian, false) ->
591 <:expr<Bitmatch.extract_int64_be_unsigned>>
592 | (P.ConstantEndian BigEndian, true) ->
593 <:expr<Bitmatch.extract_int64_be_signed>>
594 | (P.ConstantEndian LittleEndian, false) ->
595 <:expr<Bitmatch.extract_int64_le_unsigned>>
596 | (P.ConstantEndian LittleEndian, true) ->
597 <:expr<Bitmatch.extract_int64_le_signed>>
598 | (P.ConstantEndian NativeEndian, false) ->
599 <:expr<Bitmatch.extract_int64_ne_unsigned>>
600 | (P.ConstantEndian NativeEndian, true) ->
601 <:expr<Bitmatch.extract_int64_ne_signed>>
602 | (P.EndianExpr expr, false) ->
603 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
604 | (P.EndianExpr expr, true) ->
605 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
609 match t, flen_is_const with
610 (* Common case: int field, constant flen *)
611 | P.Int, Some i when i > 0 && i <= 64 ->
612 let extract_fn = int_extract_const (i,endian,signed) in
613 let v = gensym "val" in
615 if $lid:len$ >= $`int:i$ then (
616 let $lid:v$, $lid:off$, $lid:len$ =
617 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
618 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
623 fail "length of int field must be [1..64]"
625 (* Int field, non-const flen. We have to test the range of
626 * the field at runtime. If outside the range it's a no-match
630 let extract_fn = int_extract (endian,signed) in
631 let v = gensym "val" in
633 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
634 let $lid:v$, $lid:off$, $lid:len$ =
635 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
636 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
640 (* String, constant flen > 0. *)
641 | P.String, Some i when i > 0 && i land 7 = 0 ->
642 let bs = gensym "bs" in
644 if $lid:len$ >= $`int:i$ then (
645 let $lid:bs$, $lid:off$, $lid:len$ =
646 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
648 match Bitmatch.string_of_bitstring $lid:bs$ with
649 | $fpatt$ when true -> $inner$
654 (* String, constant flen = -1, means consume all the
657 | P.String, Some i when i = -1 ->
658 let bs = gensym "bs" in
660 let $lid:bs$, $lid:off$, $lid:len$ =
661 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
662 match Bitmatch.string_of_bitstring $lid:bs$ with
663 | $fpatt$ when true -> $inner$
667 | P.String, Some _ ->
668 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
670 (* String field, non-const flen. We check the flen is > 0
671 * and a multiple of 8 (-1 is not allowed here), at runtime.
674 let bs = gensym "bs" in
676 if $flen$ >= 0 && $flen$ <= $lid:len$
677 && $flen$ land 7 = 0 then (
678 let $lid:bs$, $lid:off$, $lid:len$ =
679 Bitmatch.extract_bitstring
680 $lid:data$ $lid:off$ $lid:len$ $flen$ in
681 match Bitmatch.string_of_bitstring $lid:bs$ with
682 | $fpatt$ when true -> $inner$
687 (* Bitstring, constant flen >= 0.
688 * At the moment all we can do is assign the bitstring to an
691 | P.Bitstring, Some i when i >= 0 ->
694 | <:patt< $lid:ident$ >> -> ident
695 | <:patt< _ >> -> "_"
697 fail "cannot compare a bitstring to a constant" in
699 if $lid:len$ >= $`int:i$ then (
700 let $lid:ident$, $lid:off$, $lid:len$ =
701 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
707 (* Bitstring, constant flen = -1, means consume all the
710 | P.Bitstring, Some i when i = -1 ->
713 | <:patt< $lid:ident$ >> -> ident
714 | <:patt< _ >> -> "_"
716 fail "cannot compare a bitstring to a constant" in
718 let $lid:ident$, $lid:off$, $lid:len$ =
719 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
723 | P.Bitstring, Some _ ->
724 fail "length of bitstring must be >= 0 or the special value -1"
726 (* Bitstring field, non-const flen. We check the flen is >= 0
727 * (-1 is not allowed here) at runtime.
729 | P.Bitstring, None ->
732 | <:patt< $lid:ident$ >> -> ident
733 | <:patt< _ >> -> "_"
735 fail "cannot compare a bitstring to a constant" in
737 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
738 let $lid:ident$, $lid:off$, $lid:len$ =
739 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
746 (* Computed offset: only offsets forward are supported.
748 * We try hard to optimize this based on what we know. Are
749 * we at a predictable offset now? (Look at the outer 'fields'
750 * list and see if they all have constant field length starting
751 * at some constant offset). Is this offset constant?
753 * Based on this we can do a lot of the computation at
754 * compile time, or defer it to runtime only if necessary.
756 * In all cases, the off and len fields get updated.
760 | None -> expr (* common case: there was no offset expression *)
761 | Some offset_expr ->
762 (* This will be [Some i] if offset is a constant expression
763 * or [None] if it's a non-constant.
765 let requested_offset = expr_is_constant offset_expr in
767 (* This will be [Some i] if our current offset is known
768 * at compile time, or [None] if we can't determine it.
771 let has_constant_offset field =
772 match P.get_offset field with
775 match expr_is_constant expr with
779 let get_constant_offset field =
780 match P.get_offset field with
781 | None -> assert false
783 match expr_is_constant expr with
784 | None -> assert false
788 let has_constant_len field =
789 match expr_is_constant (P.get_length field) with
791 | Some i when i > 0 -> true
794 let get_constant_len field =
795 match expr_is_constant (P.get_length field) with
796 | None -> assert false
797 | Some i when i > 0 -> i
798 | Some _ -> assert false
801 let rec loop = function
802 (* first field has constant offset 0 *)
804 (* field with constant offset & length *)
806 when has_constant_offset field &&
807 has_constant_len field ->
808 Some (get_constant_offset field + get_constant_len field)
809 (* field with no offset & constant length *)
811 when P.get_offset field = None &&
812 has_constant_len field ->
813 (match loop fields with
815 | Some offset -> Some (offset + get_constant_len field))
816 (* else, can't work out the offset *)
821 (* Look at the current offset and requested offset cases and
822 * determine what code to generate.
824 match current_offset, requested_offset with
825 (* This is the good case: both the current offset and
826 * the requested offset are constant, so we can remove
827 * almost all the runtime checks.
829 | Some current_offset, Some requested_offset ->
830 let move = requested_offset - current_offset in
832 fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
833 (* Add some code to move the offset and length by a
834 * constant amount, and a runtime test that len >= 0
835 * (XXX possibly the runtime test is unnecessary?)
838 let $lid:off$ = $lid:off$ + $`int:move$ in
839 let $lid:len$ = $lid:len$ - $`int:move$ in
840 if $lid:len$ >= 0 then $expr$
842 (* In any other case, we need to use runtime checks.
844 * XXX It's not clear if a backwards move detected at runtime
845 * is merely a match failure, or a runtime error. At the
846 * moment it's just a match failure since bitmatch generally
847 * doesn't raise runtime errors.
850 let move = gensym "move" in
852 let $lid:move$ = $offset_expr$ - $lid:off$ in
853 if $lid:move$ >= 0 then (
854 let $lid:off$ = $lid:off$ + $lid:move$ in
855 let $lid:len$ = $lid:len$ - $lid:move$ in
856 if $lid:len$ >= 0 then $expr$
858 >> in (* end of computed offset code *)
860 (* Emit extra debugging code. *)
862 if not debug then expr else (
863 let field = P.string_of_pattern_field field in
866 if !Bitmatch.debug then (
867 Printf.eprintf "PA_BITMATCH: TEST:\n";
868 Printf.eprintf " %s\n" $str:field$;
869 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
870 (*Bitmatch.hexdump_bitstring stderr
871 ($lid:data$,$lid:off$,$lid:len$);*)
877 output_field_extraction expr fields
880 (* Convert each case in the match. *)
881 let cases = List.map (
882 fun (fields, bind, whenclause, code) ->
883 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
885 match whenclause with
887 <:expr< if $whenclause$ then $inner$ >>
893 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
897 output_field_extraction inner (List.rev fields)
900 (* Join them into a single expression.
902 * Don't do it with a normal fold_right because that leaves
903 * 'raise Exit; ()' at the end which causes a compiler warning.
904 * Hence a bit of complexity here.
906 * Note that the number of cases is always >= 1 so List.hd is safe.
908 let cases = List.rev cases in
910 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
911 (List.hd cases) (List.tl cases) in
913 (* The final code just wraps the list of cases in a
914 * try/with construct so that each case is tried in
915 * turn until one case matches (that case sets 'result'
916 * and raises 'Exit' to leave the whole statement).
917 * If result isn't set by the end then we will raise
918 * Match_failure with the location of the bitmatch
919 * statement in the original code.
921 let loc_fname = Loc.file_name _loc in
922 let loc_line = string_of_int (Loc.start_line _loc) in
923 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
926 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
927 let $lid:result$ = ref None in
931 match ! $lid:result$ with
933 | None -> raise (Match_failure ($str:loc_fname$,
934 $int:loc_line$, $int:loc_char$))
937 (* Add a named pattern. *)
938 let add_named_pattern _loc name pattern =
939 Hashtbl.add pattern_hash name pattern
941 (* Expand a named pattern from the pattern_hash. *)
942 let expand_named_pattern _loc name =
943 try Hashtbl.find pattern_hash name
945 locfail _loc (sprintf "named pattern not found: %s" name)
947 (* Add named patterns from a file. See the documentation on the
948 * directory search path in bitmatch_persistent.mli
950 let load_patterns_from_file _loc filename =
952 if Filename.is_relative filename && Filename.is_implicit filename then (
953 (* Try current directory. *)
956 (* Try OCaml library directory. *)
957 try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
958 with exn -> Loc.raise _loc exn
961 with exn -> Loc.raise _loc exn
963 let names = ref [] in
966 let name = P.named_from_channel chan in
967 names := name :: !names
970 with End_of_file -> ()
973 let names = List.rev !names in
976 | name, P.Pattern patt -> add_named_pattern _loc name patt
977 | _, P.Constructor _ -> () (* just ignore these for now *)
981 GLOBAL: expr str_item;
983 (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
984 * followed by an optional expression (used in certain cases). Note
985 * that we are careful not to declare any explicit reserved words.
990 e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
994 (* Field used in the bitmatch operator (a pattern). This can actually
995 * return multiple fields, in the case where the 'field' is a named
999 [ fpatt = patt; ":"; len = expr LEVEL "top";
1000 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
1001 let field = P.create_pattern_field _loc in
1002 let field = P.set_patt field fpatt in
1003 let field = P.set_length field len in
1004 [parse_field _loc field qs] (* Normal, single field. *)
1005 | ":"; name = LIDENT ->
1006 expand_named_pattern _loc name (* Named -> list of fields. *)
1010 (* Case inside bitmatch operator. *)
1013 fields = LIST0 patt_field SEP ";";
1020 [ fields = patt_fields;
1021 bind = OPT [ "as"; name = LIDENT -> name ];
1022 whenclause = OPT [ "when"; e = expr -> e ]; "->";
1024 (fields, bind, whenclause, code)
1028 (* Field used in the BITSTRING constructor (an expression). *)
1030 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
1031 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
1032 let field = P.create_constructor_field _loc in
1033 let field = P.set_expr field fexpr in
1034 let field = P.set_length field len in
1035 parse_field _loc field qs
1041 fields = LIST0 constr_field SEP ";";
1047 (* 'bitmatch' expressions. *)
1050 bs = expr; "with"; OPT "|";
1051 cases = LIST1 patt_case SEP "|" ->
1052 output_bitmatch _loc bs cases
1057 fields = constr_fields ->
1058 output_constructor _loc fields
1062 (* Named persistent patterns.
1064 * NB: Currently only allowed at the top level. We can probably lift
1065 * this restriction later if necessary. We only deal with patterns
1066 * at the moment, not constructors, but the infrastructure to do
1067 * constructors is in place.
1069 str_item: LEVEL "top" [
1070 [ "let"; "bitmatch";
1071 name = LIDENT; "="; fields = patt_fields ->
1072 add_named_pattern _loc name fields;
1073 (* The statement disappears, but we still need a str_item so ... *)
1075 | "open"; "bitmatch"; filename = STRING ->
1076 load_patterns_from_file _loc filename;