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,
8 * with the OCaml linking exception described in COPYING.LIB.
10 * This library is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
29 module P = Bitmatch_persistent
31 (* If this is true then we emit some debugging code which can
32 * be useful to tell what is happening during matches. You
33 * also need to do 'Bitmatch.debug := true' in your main program.
35 * If this is false then no extra debugging code is emitted.
39 (* Hashtable storing named persistent patterns. *)
40 let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
42 let locfail _loc msg = Loc.raise _loc (Failure msg)
44 (* Work out if an expression is an integer constant.
46 * Returns [Some i] if so (where i is the integer value), else [None].
48 * Fairly simplistic algorithm: we can only detect simple constant
49 * expressions such as [k], [k+c], [k-c] etc.
51 let rec expr_is_constant = function
52 | <:expr< $int:i$ >> -> (* Literal integer constant. *)
53 Some (int_of_string i)
54 | <:expr< $lid:op$ $a$ $b$ >> ->
55 (match expr_is_constant a, expr_is_constant b with
56 | Some a, Some b -> (* Integer binary operations. *)
57 let ops = ["+", (+); "-", (-); "*", ( * ); "/", (/);
58 "land", (land); "lor", (lor); "lxor", (lxor);
59 "lsl", (lsl); "lsr", (lsr); "asr", (asr);
61 (try Some ((List.assoc op ops) a b) with Not_found -> None)
65 (* Generate a fresh, unique symbol each time called. *)
70 sprintf "__pabitmatch_%s_%d" name i
72 (* Used to keep track of which qualifiers we've seen in parse_field. *)
74 endian_set : bool; signed_set : bool; type_set : bool;
75 offset_set : bool; check_set : bool; bind_set : bool;
76 save_offset_to_set : bool;
79 endian_set = false; signed_set = false; type_set = false;
80 offset_set = false; check_set = false; bind_set = false;
81 save_offset_to_set = false
84 (* Deal with the qualifiers which appear for a field of both types. *)
85 let parse_field _loc field qs =
86 let fail = locfail _loc in
90 | None -> noneset, field
92 let check already_set msg = if already_set then fail msg in
93 let apply_qualifier (whatset, field) =
95 | "endian", Some expr ->
96 check whatset.endian_set "an endian flag has been set already";
97 let field = P.set_endian_expr field expr in
98 { whatset with endian_set = true }, field
100 fail "qualifier 'endian' should be followed by an expression"
101 | "offset", Some expr ->
102 check whatset.offset_set "an offset has been set already";
103 let field = P.set_offset field expr in
104 { whatset with offset_set = true }, field
106 fail "qualifier 'offset' should be followed by an expression"
107 | "check", Some expr ->
108 check whatset.check_set "a check-qualifier has been set already";
109 let field = P.set_check field expr in
110 { whatset with check_set = true }, field
112 fail "qualifier 'check' should be followed by an expression"
113 | "bind", Some expr ->
114 check whatset.bind_set "a bind expression has been set already";
115 let field = P.set_bind field expr in
116 { whatset with bind_set = true }, field
118 fail "qualifier 'bind' should be followed by an expression"
119 | "save_offset_to", Some expr (* XXX should be a pattern *) ->
120 check whatset.save_offset_to_set
121 "a save_offset_to-qualifier has been set already";
124 | <:expr< $lid:id$ >> -> id
126 failwith "pa_bitmatch: internal error: save_offset_to only supports simple identifiers at the moment. In future we should support full patterns." in
127 let field = P.set_save_offset_to_lident field id in
128 { whatset with save_offset_to_set = true }, field
129 | "save_offset_to", None ->
130 fail "qualifier 'save_offset_to' should be followed by a binding expression"
132 fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
134 let endian_quals = ["bigendian", BigEndian;
135 "littleendian", LittleEndian;
136 "nativeendian", NativeEndian] in
137 let sign_quals = ["signed", true; "unsigned", false] in
138 let type_quals = ["int", P.set_type_int;
139 "string", P.set_type_string;
140 "bitstring", P.set_type_bitstring] in
141 if List.mem_assoc qual endian_quals then (
142 check whatset.endian_set "an endian flag has been set already";
143 let field = P.set_endian field (List.assoc qual endian_quals) in
144 { whatset with endian_set = true }, field
145 ) else if List.mem_assoc qual sign_quals then (
146 check whatset.signed_set "a signed flag has been set already";
147 let field = P.set_signed field (List.assoc qual sign_quals) in
148 { whatset with signed_set = true }, field
149 ) else if List.mem_assoc qual type_quals then (
150 check whatset.type_set "a type flag has been set already";
151 let field = (List.assoc qual type_quals) field in
152 { whatset with type_set = true }, field
154 fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in
155 List.fold_left apply_qualifier (noneset, field) qs in
157 (* If type is set to string or bitstring then endianness and
158 * signedness qualifiers are meaningless and must not be set.
161 let t = P.get_type field in
162 if (t = P.Bitstring || t = P.String) &&
163 (whatset.endian_set || whatset.signed_set) then
164 fail "string types and endian or signed qualifiers cannot be mixed" in
166 (* Default endianness, signedness, type if not set already. *)
168 if whatset.endian_set then field else P.set_endian field BigEndian in
170 if whatset.signed_set then field else P.set_signed field false in
172 if whatset.type_set then field else P.set_type_int field in
176 (* Choose the right constructor function. *)
177 let build_bitmatch_call _loc funcname length endian signed =
178 match length, endian, signed with
179 (* XXX The meaning of signed/unsigned breaks down at
180 * 31, 32, 63 and 64 bits.
182 | (Some 1, _, _) -> <:expr< Bitmatch.$lid:funcname ^ "_bit"$ >>
183 | (Some (2|3|4|5|6|7|8), _, sign) ->
184 let call = Printf.sprintf "%s_char_%s"
185 funcname (if sign then "signed" else "unsigned") in
186 <:expr< Bitmatch.$lid:call$ >>
187 | (len, endian, signed) ->
188 let t = match len with
189 | Some i when i <= 31 -> "int"
192 let sign = if signed then "signed" else "unsigned" in
194 | P.ConstantEndian constant ->
195 let endianness = match constant with
197 | LittleEndian -> "le"
198 | NativeEndian -> "ne" in
199 let call = Printf.sprintf "%s_%s_%s_%s"
200 funcname t endianness sign in
201 <:expr< Bitmatch.$lid:call$ >>
202 | P.EndianExpr expr ->
203 let call = Printf.sprintf "%s_%s_%s_%s"
204 funcname t "ee" sign in
205 <:expr< Bitmatch.$lid:call$ $expr$ >>
207 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
208 let output_constructor _loc fields =
209 (* This function makes code to raise a Bitmatch.Construct_failure exception
210 * containing a message and the current _loc context.
211 * (Thanks to Bluestorm for suggesting this).
213 let construct_failure _loc msg =
215 Bitmatch.Construct_failure
217 $`str:Loc.file_name _loc$,
218 $`int:Loc.start_line _loc$,
219 $`int:Loc.start_off _loc - Loc.start_bol _loc$)
222 let raise_construct_failure _loc msg =
223 <:expr< raise $construct_failure _loc msg$ >>
226 (* Bitstrings are created like the 'Buffer' module (in fact, using
227 * the Buffer module), by appending snippets to a growing buffer.
228 * This is reasonably efficient and avoids a lot of garbage.
230 let buffer = gensym "buffer" in
232 (* General exception which is raised inside the constructor functions
233 * when an int expression is out of range at runtime.
235 let exn = gensym "exn" in
236 let exn_used = ref false in
238 (* Convert each field to a simple bitstring-generating expression. *)
239 let fields = List.map (
241 let fexpr = P.get_expr field in
242 let flen = P.get_length field in
243 let endian = P.get_endian field in
244 let signed = P.get_signed field in
245 let t = P.get_type field in
246 let _loc = P.get_location field in
248 let fail = locfail _loc in
250 (* offset(), check(), bind(), save_offset_to() not supported in
253 * Implementation of forward-only offsets is fairly
254 * straightforward: we would need to just calculate the length of
255 * padding here and add it to what has been constructed. For
256 * general offsets, including going backwards, that would require
257 * a rethink in how we construct bitstrings.
259 if P.get_offset field <> None then
260 fail "offset expressions are not supported in BITSTRING constructors";
261 if P.get_check field <> None then
262 fail "check expressions are not supported in BITSTRING constructors";
263 if P.get_bind field <> None then
264 fail "bind expressions are not supported in BITSTRING constructors";
265 if P.get_save_offset_to field <> None then
266 fail "save_offset_to is not supported in BITSTRING constructors";
268 (* Is flen an integer constant? If so, what is it? This
269 * is very simple-minded and only detects simple constants.
271 let flen_is_const = expr_is_constant flen in
273 let int_construct_const (i, endian, signed) =
274 build_bitmatch_call _loc "construct" (Some i) endian signed in
275 let int_construct (endian, signed) =
276 build_bitmatch_call _loc "construct" None endian signed in
279 match t, flen_is_const with
280 (* Common case: int field, constant flen.
282 * Range checks are done inside the construction function
283 * because that's a lot simpler w.r.t. types. It might
284 * be better to move them here. XXX
286 | P.Int, Some i when i > 0 && i <= 64 ->
287 let construct_fn = int_construct_const (i,endian,signed) in
291 $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
295 fail "length of int field must be [1..64]"
297 (* Int field, non-constant length. We need to perform a runtime
298 * test to ensure the length is [1..64].
300 * Range checks are done inside the construction function
301 * because that's a lot simpler w.r.t. types. It might
302 * be better to move them here. XXX
305 let construct_fn = int_construct (endian,signed) in
309 if $flen$ >= 1 && $flen$ <= 64 then
310 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
312 $raise_construct_failure _loc "length of int field must be [1..64]"$
315 (* String, constant length > 0, must be a multiple of 8. *)
316 | P.String, Some i when i > 0 && i land 7 = 0 ->
317 let bs = gensym "bs" in
320 let $lid:bs$ = $fexpr$ in
321 if String.length $lid:bs$ = $`int:j$ then
322 Bitmatch.construct_string $lid:buffer$ $lid:bs$
324 $raise_construct_failure _loc "length of string does not match declaration"$
327 (* String, constant length -1, means variable length string
330 | P.String, Some (-1) ->
331 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
333 (* String, constant length = 0 is probably an error, and so is
336 | P.String, Some _ ->
337 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
339 (* String, non-constant length.
340 * We check at runtime that the length is > 0, a multiple of 8,
341 * and matches the declared length.
344 let bslen = gensym "bslen" in
345 let bs = gensym "bs" in
347 let $lid:bslen$ = $flen$ in
348 if $lid:bslen$ > 0 then (
349 if $lid:bslen$ land 7 = 0 then (
350 let $lid:bs$ = $fexpr$ in
351 if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
352 Bitmatch.construct_string $lid:buffer$ $lid:bs$
354 $raise_construct_failure _loc "length of string does not match declaration"$
356 $raise_construct_failure _loc "length of string must be a multiple of 8"$
358 $raise_construct_failure _loc "length of string must be > 0"$
361 (* Bitstring, constant length >= 0. *)
362 | P.Bitstring, Some i when i >= 0 ->
363 let bs = gensym "bs" in
365 let $lid:bs$ = $fexpr$ in
366 if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
367 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
369 $raise_construct_failure _loc "length of bitstring does not match declaration"$
372 (* Bitstring, constant length -1, means variable length bitstring
375 | P.Bitstring, Some (-1) ->
376 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
378 (* Bitstring, constant length < -1 is an error. *)
379 | P.Bitstring, Some _ ->
380 fail "length of bitstring must be >= 0 or the special value -1"
382 (* Bitstring, non-constant length.
383 * We check at runtime that the length is >= 0 and matches
384 * the declared length.
386 | P.Bitstring, None ->
387 let bslen = gensym "bslen" in
388 let bs = gensym "bs" in
390 let $lid:bslen$ = $flen$ in
391 if $lid:bslen$ >= 0 then (
392 let $lid:bs$ = $fexpr$ in
393 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
394 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
396 $raise_construct_failure _loc "length of bitstring does not match declaration"$
398 $raise_construct_failure _loc "length of bitstring must be > 0"$
403 (* Create the final bitstring. Start by creating an empty buffer
404 * and then evaluate each expression above in turn which will
405 * append some more to the bitstring buffer. Finally extract
408 * XXX We almost have enough information to be able to guess
409 * a good initial size for the buffer.
413 | [] -> <:expr< [] >>
414 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
418 let $lid:buffer$ = Bitmatch.Buffer.create () in
420 Bitmatch.Buffer.contents $lid:buffer$
425 let $lid:exn$ = $construct_failure _loc "value out of range"$ in
431 (* Generate the code for a bitmatch statement. '_loc' is the
432 * location, 'bs' is the bitstring parameter, 'cases' are
433 * the list of cases to test against.
435 let output_bitmatch _loc bs cases =
436 (* These symbols are used through the generated code to record our
437 * current position within the bitstring:
439 * data - original bitstring data (string, never changes)
441 * off - current offset within data (int, increments as we move through
443 * len - current remaining length within data (int, decrements as
444 * we move through the bitstring)
446 * original_off - saved offset at the start of the match (never changes)
447 * original_len - saved length at the start of the match (never changes)
449 let data = gensym "data"
450 and off = gensym "off"
451 and len = gensym "len"
452 and original_off = gensym "original_off"
453 and original_len = gensym "original_len"
454 (* This is where the result will be stored (a reference). *)
455 and result = gensym "result" in
457 (* This generates the field extraction code for each
458 * field in a single case. There must be enough remaining data
459 * in the bitstring to satisfy the field.
461 * As we go through the fields, symbols 'data', 'off' and 'len'
462 * track our position and remaining length in the bitstring.
464 * The whole thing is a lot of nested 'if'/'match' statements.
465 * Code is generated from the inner-most (last) field outwards.
467 let rec output_field_extraction inner = function
470 let fpatt = P.get_patt field in
471 let flen = P.get_length field in
472 let endian = P.get_endian field in
473 let signed = P.get_signed field in
474 let t = P.get_type field in
475 let _loc = P.get_location field in
477 let fail = locfail _loc in
479 (* Is flen (field len) an integer constant? If so, what is it?
480 * This will be [Some i] if it's a constant or [None] if it's
481 * non-constant or we couldn't determine.
483 let flen_is_const = expr_is_constant flen in
485 (* Surround the inner expression by check and bind clauses, so:
489 * where the check and bind are switched on only if they are
490 * present in the field. (In the common case when neither
491 * clause is present, expr = inner). Note the order of the
492 * check & bind is visible to the user and defined in the
493 * documentation, so it must not change.
497 match P.get_bind field with
500 <:expr< let $fpatt$ = $bind_expr$ in $expr$ >> in
502 match P.get_check field with
505 <:expr< if $check_expr$ then $expr$ >> in
507 (* Now build the code which matches a field. *)
508 let int_extract_const (i, endian, signed) =
509 build_bitmatch_call _loc "extract" (Some i) endian signed in
510 let int_extract (endian, signed) =
511 build_bitmatch_call _loc "extract" None endian signed in
514 match t, flen_is_const with
515 (* Common case: int field, constant flen *)
516 | P.Int, Some i when i > 0 && i <= 64 ->
517 let extract_fn = int_extract_const (i,endian,signed) in
518 let v = gensym "val" in
520 if $lid:len$ >= $`int:i$ then (
521 let $lid:v$, $lid:off$, $lid:len$ =
522 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
523 match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> ()
528 fail "length of int field must be [1..64]"
530 (* Int field, non-const flen. We have to test the range of
531 * the field at runtime. If outside the range it's a no-match
535 let extract_fn = int_extract (endian,signed) in
536 let v = gensym "val" in
538 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
539 let $lid:v$, $lid:off$, $lid:len$ =
540 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
541 match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> ()
545 (* String, constant flen > 0. *)
546 | P.String, Some i when i > 0 && i land 7 = 0 ->
547 let bs = gensym "bs" in
549 if $lid:len$ >= $`int:i$ then (
550 let $lid:bs$, $lid:off$, $lid:len$ =
551 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
553 match Bitmatch.string_of_bitstring $lid:bs$ with
554 | $fpatt$ when true -> $expr$
559 (* String, constant flen = -1, means consume all the
562 | P.String, Some i when i = -1 ->
563 let bs = gensym "bs" in
565 let $lid:bs$, $lid:off$, $lid:len$ =
566 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
567 match Bitmatch.string_of_bitstring $lid:bs$ with
568 | $fpatt$ when true -> $expr$
572 | P.String, Some _ ->
573 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
575 (* String field, non-const flen. We check the flen is > 0
576 * and a multiple of 8 (-1 is not allowed here), at runtime.
579 let bs = gensym "bs" in
581 if $flen$ >= 0 && $flen$ <= $lid:len$
582 && $flen$ land 7 = 0 then (
583 let $lid:bs$, $lid:off$, $lid:len$ =
584 Bitmatch.extract_bitstring
585 $lid:data$ $lid:off$ $lid:len$ $flen$ in
586 match Bitmatch.string_of_bitstring $lid:bs$ with
587 | $fpatt$ when true -> $expr$
592 (* Bitstring, constant flen >= 0.
593 * At the moment all we can do is assign the bitstring to an
596 | P.Bitstring, Some i when i >= 0 ->
599 | <:patt< $lid:ident$ >> -> ident
600 | <:patt< _ >> -> "_"
602 fail "cannot compare a bitstring to a constant" in
604 if $lid:len$ >= $`int:i$ then (
605 let $lid:ident$, $lid:off$, $lid:len$ =
606 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
612 (* Bitstring, constant flen = -1, means consume all the
615 | P.Bitstring, Some i when i = -1 ->
618 | <:patt< $lid:ident$ >> -> ident
619 | <:patt< _ >> -> "_"
621 fail "cannot compare a bitstring to a constant" in
623 let $lid:ident$, $lid:off$, $lid:len$ =
624 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
628 | P.Bitstring, Some _ ->
629 fail "length of bitstring must be >= 0 or the special value -1"
631 (* Bitstring field, non-const flen. We check the flen is >= 0
632 * (-1 is not allowed here) at runtime.
634 | P.Bitstring, None ->
637 | <:patt< $lid:ident$ >> -> ident
638 | <:patt< _ >> -> "_"
640 fail "cannot compare a bitstring to a constant" in
642 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
643 let $lid:ident$, $lid:off$, $lid:len$ =
644 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
651 (* Computed offset: only offsets forward are supported.
653 * We try hard to optimize this based on what we know. Are
654 * we at a predictable offset now? (Look at the outer 'fields'
655 * list and see if they all have constant field length starting
656 * at some constant offset). Is this offset constant?
658 * Based on this we can do a lot of the computation at
659 * compile time, or defer it to runtime only if necessary.
661 * In all cases, the off and len fields get updated.
664 match P.get_offset field with
665 | None -> expr (* common case: there was no offset expression *)
666 | Some offset_expr ->
667 (* This will be [Some i] if offset is a constant expression
668 * or [None] if it's a non-constant.
670 let requested_offset = expr_is_constant offset_expr in
672 (* This will be [Some i] if our current offset is known
673 * at compile time, or [None] if we can't determine it.
676 let has_constant_offset field =
677 match P.get_offset field with
680 match expr_is_constant expr with
684 let get_constant_offset field =
685 match P.get_offset field with
686 | None -> assert false
688 match expr_is_constant expr with
689 | None -> assert false
693 let has_constant_len field =
694 match expr_is_constant (P.get_length field) with
696 | Some i when i > 0 -> true
699 let get_constant_len field =
700 match expr_is_constant (P.get_length field) with
701 | None -> assert false
702 | Some i when i > 0 -> i
703 | Some _ -> assert false
706 let rec loop = function
707 (* first field has constant offset 0 *)
709 (* field with constant offset & length *)
711 when has_constant_offset field &&
712 has_constant_len field ->
713 Some (get_constant_offset field + get_constant_len field)
714 (* field with no offset & constant length *)
716 when P.get_offset field = None &&
717 has_constant_len field ->
718 (match loop fields with
720 | Some offset -> Some (offset + get_constant_len field))
721 (* else, can't work out the offset *)
726 (* Look at the current offset and requested offset cases and
727 * determine what code to generate.
729 match current_offset, requested_offset with
730 (* This is the good case: both the current offset and
731 * the requested offset are constant, so we can remove
732 * almost all the runtime checks.
734 | Some current_offset, Some requested_offset ->
735 let move = requested_offset - current_offset in
737 fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
738 (* Add some code to move the offset and length by a
739 * constant amount, and a runtime test that len >= 0
740 * (XXX possibly the runtime test is unnecessary?)
743 let $lid:off$ = $lid:off$ + $`int:move$ in
744 let $lid:len$ = $lid:len$ - $`int:move$ in
745 if $lid:len$ >= 0 then $expr$
747 (* In any other case, we need to use runtime checks.
749 * XXX It's not clear if a backwards move detected at runtime
750 * is merely a match failure, or a runtime error. At the
751 * moment it's just a match failure since bitmatch generally
752 * doesn't raise runtime errors.
755 let move = gensym "move" in
758 $offset_expr$ - ($lid:off$ - $lid:original_off$) in
759 if $lid:move$ >= 0 then (
760 let $lid:off$ = $lid:off$ + $lid:move$ in
761 let $lid:len$ = $lid:len$ - $lid:move$ in
762 if $lid:len$ >= 0 then $expr$
764 >> in (* end of computed offset code *)
766 (* save_offset_to(patt) saves the current offset into a variable. *)
768 match P.get_save_offset_to field with
769 | None -> expr (* no save_offset_to *)
772 let $patt$ = $lid:off$ - $lid:original_off$ in
776 (* Emit extra debugging code. *)
778 if not debug then expr else (
779 let field = P.string_of_pattern_field field in
782 if !Bitmatch.debug then (
783 Printf.eprintf "PA_BITMATCH: TEST:\n";
784 Printf.eprintf " %s\n" $str:field$;
785 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
786 (*Bitmatch.hexdump_bitstring stderr
787 ($lid:data$,$lid:off$,$lid:len$);*)
793 output_field_extraction expr fields
796 (* Convert each case in the match. *)
797 let cases = List.map (
798 fun (fields, bind, whenclause, code) ->
799 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
801 match whenclause with
803 <:expr< if $whenclause$ then $inner$ >>
809 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
813 output_field_extraction inner (List.rev fields)
816 (* Join them into a single expression.
818 * Don't do it with a normal fold_right because that leaves
819 * 'raise Exit; ()' at the end which causes a compiler warning.
820 * Hence a bit of complexity here.
822 * Note that the number of cases is always >= 1 so List.hd is safe.
824 let cases = List.rev cases in
826 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
827 (List.hd cases) (List.tl cases) in
829 (* The final code just wraps the list of cases in a
830 * try/with construct so that each case is tried in
831 * turn until one case matches (that case sets 'result'
832 * and raises 'Exit' to leave the whole statement).
833 * If result isn't set by the end then we will raise
834 * Match_failure with the location of the bitmatch
835 * statement in the original code.
837 let loc_fname = Loc.file_name _loc in
838 let loc_line = string_of_int (Loc.start_line _loc) in
839 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
842 (* Note we save the original offset/length at the start of the match
843 * in 'original_off'/'original_len' symbols. 'data' never changes.
845 let ($lid:data$, $lid:original_off$, $lid:original_len$) = $bs$ in
846 let $lid:off$ = $lid:original_off$ and $lid:len$ = $lid:original_len$ in
847 let $lid:result$ = ref None in
851 match ! $lid:result$ with
853 | None -> raise (Match_failure ($str:loc_fname$,
854 $int:loc_line$, $int:loc_char$))
857 (* Add a named pattern. *)
858 let add_named_pattern _loc name pattern =
859 Hashtbl.add pattern_hash name pattern
861 (* Expand a named pattern from the pattern_hash. *)
862 let expand_named_pattern _loc name =
863 try Hashtbl.find pattern_hash name
865 locfail _loc (sprintf "named pattern not found: %s" name)
867 (* Add named patterns from a file. See the documentation on the
868 * directory search path in bitmatch_persistent.mli
870 let load_patterns_from_file _loc filename =
872 if Filename.is_relative filename && Filename.is_implicit filename then (
873 (* Try current directory. *)
876 (* Try OCaml library directory. *)
877 try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
878 with exn -> Loc.raise _loc exn
881 with exn -> Loc.raise _loc exn
883 let names = ref [] in
886 let name = P.named_from_channel chan in
887 names := name :: !names
890 with End_of_file -> ()
893 let names = List.rev !names in
896 | name, P.Pattern patt ->
898 locfail _loc (sprintf "pattern %s: no fields" name);
899 add_named_pattern _loc name patt
900 | _, P.Constructor _ -> () (* just ignore these for now *)
904 GLOBAL: expr str_item;
906 (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
907 * followed by an optional expression (used in certain cases). Note
908 * that we are careful not to declare any explicit reserved words.
913 e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
917 (* Field used in the bitmatch operator (a pattern). This can actually
918 * return multiple fields, in the case where the 'field' is a named
922 [ fpatt = patt; ":"; len = expr LEVEL "top";
923 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
924 let field = P.create_pattern_field _loc in
925 let field = P.set_patt field fpatt in
926 let field = P.set_length field len in
927 [parse_field _loc field qs] (* Normal, single field. *)
928 | ":"; name = LIDENT ->
929 expand_named_pattern _loc name (* Named -> list of fields. *)
933 (* Case inside bitmatch operator. *)
936 fields = LIST0 patt_field SEP ";";
943 [ fields = patt_fields;
944 bind = OPT [ "as"; name = LIDENT -> name ];
945 whenclause = OPT [ "when"; e = expr -> e ]; "->";
947 (fields, bind, whenclause, code)
951 (* Field used in the BITSTRING constructor (an expression). *)
953 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
954 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
955 let field = P.create_constructor_field _loc in
956 let field = P.set_expr field fexpr in
957 let field = P.set_length field len in
958 parse_field _loc field qs
964 fields = LIST0 constr_field SEP ";";
970 (* 'bitmatch' expressions. *)
973 bs = expr; "with"; OPT "|";
974 cases = LIST1 patt_case SEP "|" ->
975 output_bitmatch _loc bs cases
980 fields = constr_fields ->
981 output_constructor _loc fields
985 (* Named persistent patterns.
987 * NB: Currently only allowed at the top level. We can probably lift
988 * this restriction later if necessary. We only deal with patterns
989 * at the moment, not constructors, but the infrastructure to do
990 * constructors is in place.
992 str_item: LEVEL "top" [
994 name = LIDENT; "="; fields = patt_fields ->
995 add_named_pattern _loc name fields;
996 (* The statement disappears, but we still need a str_item so ... *)
998 | "open"; "bitmatch"; filename = STRING ->
999 load_patterns_from_file _loc filename;