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< $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);
60 (try Some ((List.assoc op ops) a b) with Not_found -> None)
64 (* Generate a fresh, unique symbol each time called. *)
69 sprintf "__pabitmatch_%s_%d" name i
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
75 let endian_set, signed_set, type_set, offset_set, field =
77 | None -> (false, false, false, false, field)
79 let check already_set msg = if already_set then fail msg in
81 (endian_set, signed_set, type_set, offset_set, field) =
83 | "endian", Some expr ->
84 check endian_set "an endian flag has been set already";
85 let field = P.set_endian_expr field expr in
86 (true, signed_set, type_set, offset_set, field)
88 fail "qualifier 'endian' should be followed by an expression"
89 | "offset", Some expr ->
90 check offset_set "an offset has been set already";
91 let field = P.set_offset field expr in
92 (endian_set, signed_set, type_set, true, field)
94 fail "qualifier 'offset' should be followed by an expression"
96 fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
98 let endian_quals = ["bigendian", BigEndian;
99 "littleendian", LittleEndian;
100 "nativeendian", NativeEndian] in
101 let sign_quals = ["signed", true; "unsigned", false] in
102 let type_quals = ["int", P.set_type_int;
103 "string", P.set_type_string;
104 "bitstring", P.set_type_bitstring] in
105 if List.mem_assoc qual endian_quals then (
106 check endian_set "an endian flag has been set already";
107 let field = P.set_endian field (List.assoc qual endian_quals) in
108 (true, signed_set, type_set, offset_set, field)
109 ) else if List.mem_assoc qual sign_quals then (
110 check signed_set "a signed flag has been set already";
111 let field = P.set_signed field (List.assoc qual sign_quals) in
112 (endian_set, true, type_set, offset_set, field)
113 ) else if List.mem_assoc qual type_quals then (
114 check type_set "a type flag has been set already";
115 let field = List.assoc qual type_quals field in
116 (endian_set, signed_set, true, offset_set, field)
118 fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in
119 List.fold_left apply_qualifier (false, false, false, false, field) qs in
121 (* If type is set to string or bitstring then endianness and
122 * signedness qualifiers are meaningless and must not be set.
125 let t = P.get_type field in
126 if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
127 fail "string types and endian or signed qualifiers cannot be mixed" in
129 (* Default endianness, signedness, type if not set already. *)
130 let field = if endian_set then field else P.set_endian field BigEndian in
131 let field = if signed_set then field else P.set_signed field false in
132 let field = if type_set then field else P.set_type_int field in
136 (* Choose the right constructor function. *)
137 let build_bitmatch_call _loc funcname length endian signed =
138 match length, endian, signed with
139 (* XXX The meaning of signed/unsigned breaks down at
140 * 31, 32, 63 and 64 bits.
142 | (Some 1, _, _) -> <:expr<Bitmatch.$lid:funcname ^ "_bit"$ >>
143 | (Some (2|3|4|5|6|7|8), _, sign) ->
144 let call = Printf.sprintf "%s_char_%s"
145 funcname (if sign then "signed" else "unsigned") in
146 <:expr< Bitmatch.$lid:call$ >>
147 | (len, endian, signed) ->
148 let t = match len with
149 | Some i when i <= 31 -> "int"
152 let sign = if signed then "signed" else "unsigned" in
154 | P.ConstantEndian constant ->
155 let endianness = match constant with
157 | LittleEndian -> "le"
158 | NativeEndian -> "ne" in
159 let call = Printf.sprintf "%s_%s_%s_%s"
160 funcname t endianness sign in
161 <:expr< Bitmatch.$lid:call$ >>
162 | P.EndianExpr expr ->
163 let call = Printf.sprintf "%s_%s_%s_%s"
164 funcname t "ee" sign in
165 <:expr< Bitmatch.$lid:call$ $expr$ >>
167 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
168 let output_constructor _loc fields =
169 let fail = locfail _loc in
171 let loc_fname = Loc.file_name _loc in
172 let loc_line = string_of_int (Loc.start_line _loc) in
173 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
175 (* Bitstrings are created like the 'Buffer' module (in fact, using
176 * the Buffer module), by appending snippets to a growing buffer.
177 * This is reasonably efficient and avoids a lot of garbage.
179 let buffer = gensym "buffer" in
181 (* General exception which is raised inside the constructor functions
182 * when an int expression is out of range at runtime.
184 let exn = gensym "exn" in
185 let exn_used = ref false in
187 (* Convert each field to a simple bitstring-generating expression. *)
188 let fields = List.map (
190 let fexpr = P.get_expr field in
191 let flen = P.get_length field in
192 let endian = P.get_endian field in
193 let signed = P.get_signed field in
194 let t = P.get_type field in
195 let _loc = P.get_location field in
196 let offset = P.get_offset field in
198 (* offset() not supported in constructors. Implementation of
199 * forward-only offsets is fairly straightforward: we would
200 * need to just calculate the length of padding here and add
201 * it to what has been constructed. For general offsets,
202 * including going backwards, that would require a rethink in
203 * how we construct bitstrings.
205 if offset <> None then
206 fail "offset expressions are not supported in BITSTRING constructors";
208 (* Is flen an integer constant? If so, what is it? This
209 * is very simple-minded and only detects simple constants.
211 let flen_is_const = expr_is_constant flen in
213 let int_construct_const (i, endian, signed) =
214 build_bitmatch_call _loc "construct" (Some i) endian signed in
215 let int_construct (endian, signed) =
216 build_bitmatch_call _loc "construct" None endian signed in
219 match t, flen_is_const with
220 (* Common case: int field, constant flen.
222 * Range checks are done inside the construction function
223 * because that's a lot simpler w.r.t. types. It might
224 * be better to move them here. XXX
226 | P.Int, Some i when i > 0 && i <= 64 ->
227 let construct_fn = int_construct_const (i,endian,signed) in
231 $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
235 fail "length of int field must be [1..64]"
237 (* Int field, non-constant length. We need to perform a runtime
238 * test to ensure the length is [1..64].
240 * Range checks are done inside the construction function
241 * because that's a lot simpler w.r.t. types. It might
242 * be better to move them here. XXX
245 let construct_fn = int_construct (endian,signed) in
249 if $flen$ >= 1 && $flen$ <= 64 then
250 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
252 raise (Bitmatch.Construct_failure
253 ("length of int field must be [1..64]",
255 $int:loc_line$, $int:loc_char$))
258 (* String, constant length > 0, must be a multiple of 8. *)
259 | P.String, Some i when i > 0 && i land 7 = 0 ->
260 let bs = gensym "bs" in
263 let $lid:bs$ = $fexpr$ in
264 if String.length $lid:bs$ = $`int:j$ then
265 Bitmatch.construct_string $lid:buffer$ $lid:bs$
267 raise (Bitmatch.Construct_failure
268 ("length of string does not match declaration",
270 $int:loc_line$, $int:loc_char$))
273 (* String, constant length -1, means variable length string
276 | P.String, Some (-1) ->
277 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
279 (* String, constant length = 0 is probably an error, and so is
282 | P.String, Some _ ->
283 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
285 (* String, non-constant length.
286 * We check at runtime that the length is > 0, a multiple of 8,
287 * and matches the declared length.
290 let bslen = gensym "bslen" in
291 let bs = gensym "bs" in
293 let $lid:bslen$ = $flen$ in
294 if $lid:bslen$ > 0 then (
295 if $lid:bslen$ land 7 = 0 then (
296 let $lid:bs$ = $fexpr$ in
297 if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
298 Bitmatch.construct_string $lid:buffer$ $lid:bs$
300 raise (Bitmatch.Construct_failure
301 ("length of string does not match declaration",
303 $int:loc_line$, $int:loc_char$))
305 raise (Bitmatch.Construct_failure
306 ("length of string must be a multiple of 8",
308 $int:loc_line$, $int:loc_char$))
310 raise (Bitmatch.Construct_failure
311 ("length of string must be > 0",
313 $int:loc_line$, $int:loc_char$))
316 (* Bitstring, constant length >= 0. *)
317 | P.Bitstring, Some i when i >= 0 ->
318 let bs = gensym "bs" in
320 let $lid:bs$ = $fexpr$ in
321 if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
322 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
324 raise (Bitmatch.Construct_failure
325 ("length of bitstring does not match declaration",
327 $int:loc_line$, $int:loc_char$))
330 (* Bitstring, constant length -1, means variable length bitstring
333 | P.Bitstring, Some (-1) ->
334 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
336 (* Bitstring, constant length < -1 is an error. *)
337 | P.Bitstring, Some _ ->
338 fail "length of bitstring must be >= 0 or the special value -1"
340 (* Bitstring, non-constant length.
341 * We check at runtime that the length is >= 0 and matches
342 * the declared length.
344 | P.Bitstring, None ->
345 let bslen = gensym "bslen" in
346 let bs = gensym "bs" in
348 let $lid:bslen$ = $flen$ in
349 if $lid:bslen$ >= 0 then (
350 let $lid:bs$ = $fexpr$ in
351 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
352 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
354 raise (Bitmatch.Construct_failure
355 ("length of bitstring does not match declaration",
357 $int:loc_line$, $int:loc_char$))
359 raise (Bitmatch.Construct_failure
360 ("length of bitstring must be > 0",
362 $int:loc_line$, $int:loc_char$))
367 (* Create the final bitstring. Start by creating an empty buffer
368 * and then evaluate each expression above in turn which will
369 * append some more to the bitstring buffer. Finally extract
372 * XXX We almost have enough information to be able to guess
373 * a good initial size for the buffer.
377 | [] -> <:expr< [] >>
378 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
382 let $lid:buffer$ = Bitmatch.Buffer.create () in
384 Bitmatch.Buffer.contents $lid:buffer$
390 Bitmatch.Construct_failure ("value out of range",
392 $int:loc_line$, $int:loc_char$) in
398 (* Generate the code for a bitmatch statement. '_loc' is the
399 * location, 'bs' is the bitstring parameter, 'cases' are
400 * the list of cases to test against.
402 let output_bitmatch _loc bs cases =
403 let fail = locfail _loc in
405 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
406 let result = gensym "result" in
408 (* This generates the field extraction code for each
409 * field in a single case. There must be enough remaining data
410 * in the bitstring to satisfy the field.
412 * As we go through the fields, symbols 'data', 'off' and 'len'
413 * track our position and remaining length in the bitstring.
415 * The whole thing is a lot of nested 'if' statements. Code
416 * is generated from the inner-most (last) field outwards.
418 let rec output_field_extraction inner = function
421 let fpatt = P.get_patt field in
422 let flen = P.get_length field in
423 let endian = P.get_endian field in
424 let signed = P.get_signed field in
425 let t = P.get_type field in
426 let _loc = P.get_location field in
427 let offset = P.get_offset field in
429 (* Is flen (field len) an integer constant? If so, what is it?
430 * This will be [Some i] if it's a constant or [None] if it's
431 * non-constant or we couldn't determine.
433 let flen_is_const = expr_is_constant flen in
435 let int_extract_const (i, endian, signed) =
436 build_bitmatch_call _loc "extract" (Some i) endian signed in
437 let int_extract (endian, signed) =
438 build_bitmatch_call _loc "extract" None endian signed in
441 match t, flen_is_const with
442 (* Common case: int field, constant flen *)
443 | P.Int, Some i when i > 0 && i <= 64 ->
444 let extract_fn = int_extract_const (i,endian,signed) in
445 let v = gensym "val" in
447 if $lid:len$ >= $`int:i$ then (
448 let $lid:v$, $lid:off$, $lid:len$ =
449 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
450 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
455 fail "length of int field must be [1..64]"
457 (* Int field, non-const flen. We have to test the range of
458 * the field at runtime. If outside the range it's a no-match
462 let extract_fn = int_extract (endian,signed) in
463 let v = gensym "val" in
465 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
466 let $lid:v$, $lid:off$, $lid:len$ =
467 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
468 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
472 (* String, constant flen > 0. *)
473 | P.String, Some i when i > 0 && i land 7 = 0 ->
474 let bs = gensym "bs" in
476 if $lid:len$ >= $`int:i$ then (
477 let $lid:bs$, $lid:off$, $lid:len$ =
478 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
480 match Bitmatch.string_of_bitstring $lid:bs$ with
481 | $fpatt$ when true -> $inner$
486 (* String, constant flen = -1, means consume all the
489 | P.String, Some i when i = -1 ->
490 let bs = gensym "bs" in
492 let $lid:bs$, $lid:off$, $lid:len$ =
493 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
494 match Bitmatch.string_of_bitstring $lid:bs$ with
495 | $fpatt$ when true -> $inner$
499 | P.String, Some _ ->
500 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
502 (* String field, non-const flen. We check the flen is > 0
503 * and a multiple of 8 (-1 is not allowed here), at runtime.
506 let bs = gensym "bs" in
508 if $flen$ >= 0 && $flen$ <= $lid:len$
509 && $flen$ land 7 = 0 then (
510 let $lid:bs$, $lid:off$, $lid:len$ =
511 Bitmatch.extract_bitstring
512 $lid:data$ $lid:off$ $lid:len$ $flen$ in
513 match Bitmatch.string_of_bitstring $lid:bs$ with
514 | $fpatt$ when true -> $inner$
519 (* Bitstring, constant flen >= 0.
520 * At the moment all we can do is assign the bitstring to an
523 | P.Bitstring, Some i when i >= 0 ->
526 | <:patt< $lid:ident$ >> -> ident
527 | <:patt< _ >> -> "_"
529 fail "cannot compare a bitstring to a constant" in
531 if $lid:len$ >= $`int:i$ then (
532 let $lid:ident$, $lid:off$, $lid:len$ =
533 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
539 (* Bitstring, constant flen = -1, means consume all the
542 | P.Bitstring, Some i when i = -1 ->
545 | <:patt< $lid:ident$ >> -> ident
546 | <:patt< _ >> -> "_"
548 fail "cannot compare a bitstring to a constant" in
550 let $lid:ident$, $lid:off$, $lid:len$ =
551 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
555 | P.Bitstring, Some _ ->
556 fail "length of bitstring must be >= 0 or the special value -1"
558 (* Bitstring field, non-const flen. We check the flen is >= 0
559 * (-1 is not allowed here) at runtime.
561 | P.Bitstring, None ->
564 | <:patt< $lid:ident$ >> -> ident
565 | <:patt< _ >> -> "_"
567 fail "cannot compare a bitstring to a constant" in
569 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
570 let $lid:ident$, $lid:off$, $lid:len$ =
571 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
578 (* Computed offset: only offsets forward are supported.
580 * We try hard to optimize this based on what we know. Are
581 * we at a predictable offset now? (Look at the outer 'fields'
582 * list and see if they all have constant field length starting
583 * at some constant offset). Is this offset constant?
585 * Based on this we can do a lot of the computation at
586 * compile time, or defer it to runtime only if necessary.
588 * In all cases, the off and len fields get updated.
592 | None -> expr (* common case: there was no offset expression *)
593 | Some offset_expr ->
594 (* This will be [Some i] if offset is a constant expression
595 * or [None] if it's a non-constant.
597 let requested_offset = expr_is_constant offset_expr in
599 (* This will be [Some i] if our current offset is known
600 * at compile time, or [None] if we can't determine it.
603 let has_constant_offset field =
604 match P.get_offset field with
607 match expr_is_constant expr with
611 let get_constant_offset field =
612 match P.get_offset field with
613 | None -> assert false
615 match expr_is_constant expr with
616 | None -> assert false
620 let has_constant_len field =
621 match expr_is_constant (P.get_length field) with
623 | Some i when i > 0 -> true
626 let get_constant_len field =
627 match expr_is_constant (P.get_length field) with
628 | None -> assert false
629 | Some i when i > 0 -> i
630 | Some _ -> assert false
633 let rec loop = function
634 (* first field has constant offset 0 *)
636 (* field with constant offset & length *)
638 when has_constant_offset field &&
639 has_constant_len field ->
640 Some (get_constant_offset field + get_constant_len field)
641 (* field with no offset & constant length *)
643 when P.get_offset field = None &&
644 has_constant_len field ->
645 (match loop fields with
647 | Some offset -> Some (offset + get_constant_len field))
648 (* else, can't work out the offset *)
653 (* Look at the current offset and requested offset cases and
654 * determine what code to generate.
656 match current_offset, requested_offset with
657 (* This is the good case: both the current offset and
658 * the requested offset are constant, so we can remove
659 * almost all the runtime checks.
661 | Some current_offset, Some requested_offset ->
662 let move = requested_offset - current_offset in
664 fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
665 (* Add some code to move the offset and length by a
666 * constant amount, and a runtime test that len >= 0
667 * (XXX possibly the runtime test is unnecessary?)
670 let $lid:off$ = $lid:off$ + $`int:move$ in
671 let $lid:len$ = $lid:len$ - $`int:move$ in
672 if $lid:len$ >= 0 then $expr$
674 (* In any other case, we need to use runtime checks.
676 * XXX It's not clear if a backwards move detected at runtime
677 * is merely a match failure, or a runtime error. At the
678 * moment it's just a match failure since bitmatch generally
679 * doesn't raise runtime errors.
682 let move = gensym "move" in
684 let $lid:move$ = $offset_expr$ - $lid:off$ in
685 if $lid:move$ >= 0 then (
686 let $lid:off$ = $lid:off$ + $lid:move$ in
687 let $lid:len$ = $lid:len$ - $lid:move$ in
688 if $lid:len$ >= 0 then $expr$
690 >> in (* end of computed offset code *)
692 (* Emit extra debugging code. *)
694 if not debug then expr else (
695 let field = P.string_of_pattern_field field in
698 if !Bitmatch.debug then (
699 Printf.eprintf "PA_BITMATCH: TEST:\n";
700 Printf.eprintf " %s\n" $str:field$;
701 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
702 (*Bitmatch.hexdump_bitstring stderr
703 ($lid:data$,$lid:off$,$lid:len$);*)
709 output_field_extraction expr fields
712 (* Convert each case in the match. *)
713 let cases = List.map (
714 fun (fields, bind, whenclause, code) ->
715 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
717 match whenclause with
719 <:expr< if $whenclause$ then $inner$ >>
725 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
729 output_field_extraction inner (List.rev fields)
732 (* Join them into a single expression.
734 * Don't do it with a normal fold_right because that leaves
735 * 'raise Exit; ()' at the end which causes a compiler warning.
736 * Hence a bit of complexity here.
738 * Note that the number of cases is always >= 1 so List.hd is safe.
740 let cases = List.rev cases in
742 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
743 (List.hd cases) (List.tl cases) in
745 (* The final code just wraps the list of cases in a
746 * try/with construct so that each case is tried in
747 * turn until one case matches (that case sets 'result'
748 * and raises 'Exit' to leave the whole statement).
749 * If result isn't set by the end then we will raise
750 * Match_failure with the location of the bitmatch
751 * statement in the original code.
753 let loc_fname = Loc.file_name _loc in
754 let loc_line = string_of_int (Loc.start_line _loc) in
755 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
758 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
759 let $lid:result$ = ref None in
763 match ! $lid:result$ with
765 | None -> raise (Match_failure ($str:loc_fname$,
766 $int:loc_line$, $int:loc_char$))
769 (* Add a named pattern. *)
770 let add_named_pattern _loc name pattern =
771 Hashtbl.add pattern_hash name pattern
773 (* Expand a named pattern from the pattern_hash. *)
774 let expand_named_pattern _loc name =
775 try Hashtbl.find pattern_hash name
777 locfail _loc (sprintf "named pattern not found: %s" name)
779 (* Add named patterns from a file. See the documentation on the
780 * directory search path in bitmatch_persistent.mli
782 let load_patterns_from_file _loc filename =
784 if Filename.is_relative filename && Filename.is_implicit filename then (
785 (* Try current directory. *)
788 (* Try OCaml library directory. *)
789 try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
790 with exn -> Loc.raise _loc exn
793 with exn -> Loc.raise _loc exn
795 let names = ref [] in
798 let name = P.named_from_channel chan in
799 names := name :: !names
802 with End_of_file -> ()
805 let names = List.rev !names in
808 | name, P.Pattern patt -> add_named_pattern _loc name patt
809 | _, P.Constructor _ -> () (* just ignore these for now *)
813 GLOBAL: expr str_item;
815 (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
816 * followed by an optional expression (used in certain cases). Note
817 * that we are careful not to declare any explicit reserved words.
822 e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
826 (* Field used in the bitmatch operator (a pattern). This can actually
827 * return multiple fields, in the case where the 'field' is a named
831 [ fpatt = patt; ":"; len = expr LEVEL "top";
832 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
833 let field = P.create_pattern_field _loc in
834 let field = P.set_patt field fpatt in
835 let field = P.set_length field len in
836 [parse_field _loc field qs] (* Normal, single field. *)
837 | ":"; name = LIDENT ->
838 expand_named_pattern _loc name (* Named -> list of fields. *)
842 (* Case inside bitmatch operator. *)
845 fields = LIST0 patt_field SEP ";";
852 [ fields = patt_fields;
853 bind = OPT [ "as"; name = LIDENT -> name ];
854 whenclause = OPT [ "when"; e = expr -> e ]; "->";
856 (fields, bind, whenclause, code)
860 (* Field used in the BITSTRING constructor (an expression). *)
862 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
863 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
864 let field = P.create_constructor_field _loc in
865 let field = P.set_expr field fexpr in
866 let field = P.set_length field len in
867 parse_field _loc field qs
873 fields = LIST0 constr_field SEP ";";
879 (* 'bitmatch' expressions. *)
882 bs = expr; "with"; OPT "|";
883 cases = LIST1 patt_case SEP "|" ->
884 output_bitmatch _loc bs cases
889 fields = constr_fields ->
890 output_constructor _loc fields
894 (* Named persistent patterns.
896 * NB: Currently only allowed at the top level. We can probably lift
897 * this restriction later if necessary. We only deal with patterns
898 * at the moment, not constructors, but the infrastructure to do
899 * constructors is in place.
901 str_item: LEVEL "top" [
903 name = LIDENT; "="; fields = patt_fields ->
904 add_named_pattern _loc name fields;
905 (* The statement disappears, but we still need a str_item so ... *)
907 | "open"; "bitmatch"; filename = STRING ->
908 load_patterns_from_file _loc filename;