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
18 * $Id: pa_bitmatch.ml,v 1.10 2008-04-25 12:55:39 rjones Exp $
27 (* If this is true then we emit some debugging code which can
28 * be useful to tell what is happening during matches. You
29 * also need to do 'Bitmatch.debug := true' in your main program.
31 * If this is false then no extra debugging code is emitted.
35 (* A field when used in a bitmatch (a pattern). *)
37 fpatt : patt; (* field matching pattern *)
40 (* A field when used in a BITSTRING constructor (an expression). *)
42 fexpr : expr; (* field value *)
47 flen : expr; (* length in bits, may be non-const *)
48 endian : endian; (* endianness *)
49 signed : bool; (* true if signed, false if unsigned *)
51 _loc : Loc.t; (* location in source code *)
53 and endian = BigEndian | LittleEndian | NativeEndian
54 and t = Int | String | Bitstring
56 (* Generate a fresh, unique symbol each time called. *)
61 sprintf "__pabitmatch_%s_%d" name i
63 (* Heuristic test if a pattern is exhaustive. *)
64 let pattern_is_exhaustive = function
65 | <:patt< $lid:_$ >> -> true
68 let rec parse_patt_field _loc fpatt flen qs =
69 let fpc = parse_field_common _loc flen qs in
70 { fpatt = fpatt; fpc = fpc }
72 and parse_constr_field _loc fexpr flen qs =
73 let fec = parse_field_common _loc flen qs in
74 { fexpr = fexpr; fec = fec }
76 (* Deal with the qualifiers which appear for a field of both types. *)
77 and parse_field_common _loc flen qs =
78 let endian, signed, t =
80 | None -> (None, None, None)
83 fun (endian, signed, t) q ->
86 if endian <> None then
87 Loc.raise _loc (Failure "an endian flag has been set already")
89 let endian = Some BigEndian in
93 if endian <> None then
94 Loc.raise _loc (Failure "an endian flag has been set already")
96 let endian = Some LittleEndian in
100 if endian <> None then
101 Loc.raise _loc (Failure "an endian flag has been set already")
103 let endian = Some NativeEndian in
107 if signed <> None then
108 Loc.raise _loc (Failure "a signed flag has been set already")
110 let signed = Some true in
114 if signed <> None then
115 Loc.raise _loc (Failure "a signed flag has been set already")
117 let signed = Some false in
122 Loc.raise _loc (Failure "a type flag has been set already")
129 Loc.raise _loc (Failure "a type flag has been set already")
131 let t = Some String in
136 Loc.raise _loc (Failure "a type flag has been set already")
138 let t = Some Bitstring in
142 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
143 ) (None, None, None) qs in
145 (* If type is set to string or bitstring then endianness and
146 * signedness qualifiers are meaningless and must not be set.
148 if (t = Some Bitstring || t = Some String)
149 && (endian <> None || signed <> None) then
151 Failure "string types and endian or signed qualifiers cannot be mixed"
154 (* Default endianness, signedness, type. *)
155 let endian = match endian with None -> BigEndian | Some e -> e in
156 let signed = match signed with None -> false | Some s -> s in
157 let t = match t with None -> Int | Some t -> t in
167 let string_of_endian = function
168 | BigEndian -> "bigendian"
169 | LittleEndian -> "littleendian"
170 | NativeEndian -> "nativeendian"
172 let string_of_t = function
175 | Bitstring -> "bitstring"
177 let rec string_of_patt_field { fpatt = fpatt; fpc = fpc } =
178 let fpc = string_of_field_common fpc in
181 | <:patt< $lid:id$ >> -> id
182 | _ -> "[pattern]" in
185 and string_of_constr_field { fexpr = fexpr; fec = fec } =
186 let fec = string_of_field_common fec in
189 | <:expr< $lid:id$ >> -> id
190 | _ -> "[expression]" in
193 and string_of_field_common { flen = flen;
194 endian = endian; signed = signed; t = t;
198 | <:expr< $int:i$ >> -> i
199 | _ -> "[non-const-len]" in
200 let endian = string_of_endian endian in
201 let signed = if signed then "signed" else "unsigned" in
202 let t = string_of_t t in
203 let loc_fname = Loc.file_name _loc in
204 let loc_line = Loc.start_line _loc in
205 let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
207 sprintf "%s : %s, %s, %s @ (%S, %d, %d)"
208 flen t endian signed loc_fname loc_line loc_char
210 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
211 let output_constructor _loc fields =
212 let loc_fname = Loc.file_name _loc in
213 let loc_line = string_of_int (Loc.start_line _loc) in
214 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
216 (* Bitstrings are created like the 'Buffer' module (in fact, using
217 * the Buffer module), by appending snippets to a growing buffer.
218 * This is reasonably efficient and avoids a lot of garbage.
220 let buffer = gensym "buffer" in
222 (* General exception which is raised inside the constructor functions
223 * when an int expression is out of range at runtime.
225 let exn = gensym "exn" in
226 let exn_used = ref false in
228 (* Convert each field to a simple bitstring-generating expression. *)
229 let fields = List.map (
230 fun {fexpr=fexpr; fec={flen=flen; endian=endian; signed=signed;
232 (* Is flen an integer constant? If so, what is it? This
233 * is very simple-minded and only detects simple constants.
237 | <:expr< $int:i$ >> -> Some (int_of_string i)
240 let name_of_int_construct_const = function
241 (* XXX As an enhancement we should allow a 64-bit-only
242 * mode which lets us use 'int' up to 63 bits and won't
243 * compile on 32-bit platforms.
245 (* XXX The meaning of signed/unsigned breaks down at
246 * 31, 32, 63 and 64 bits.
248 | (1, _, _) -> "construct_bit"
249 | ((2|3|4|5|6|7|8), _, false) -> "construct_char_unsigned"
250 | ((2|3|4|5|6|7|8), _, true) -> "construct_char_signed"
251 | (i, BigEndian, false) when i <= 31 -> "construct_int_be_unsigned"
252 | (i, BigEndian, true) when i <= 31 -> "construct_int_be_signed"
253 | (i, LittleEndian, false) when i <= 31 -> "construct_int_le_unsigned"
254 | (i, LittleEndian, true) when i <= 31 -> "construct_int_le_signed"
255 | (i, NativeEndian, false) when i <= 31 -> "construct_int_ne_unsigned"
256 | (i, NativeEndian, true) when i <= 31 -> "construct_int_ne_signed"
257 | (32, BigEndian, false) -> "construct_int32_be_unsigned"
258 | (32, BigEndian, true) -> "construct_int32_be_signed"
259 | (32, LittleEndian, false) -> "construct_int32_le_unsigned"
260 | (32, LittleEndian, true) -> "construct_int32_le_signed"
261 | (32, NativeEndian, false) -> "construct_int32_ne_unsigned"
262 | (32, NativeEndian, true) -> "construct_int32_ne_signed"
263 | (_, BigEndian, false) -> "construct_int64_be_unsigned"
264 | (_, BigEndian, true) -> "construct_int64_be_signed"
265 | (_, LittleEndian, false) -> "construct_int64_le_unsigned"
266 | (_, LittleEndian, true) -> "construct_int64_le_signed"
267 | (_, NativeEndian, false) -> "construct_int64_ne_unsigned"
268 | (_, NativeEndian, true) -> "construct_int64_ne_signed"
270 let name_of_int_construct = function
271 (* XXX As an enhancement we should allow users to
272 * specify that a field length can fit into a char/int/int32
273 * (of course, this would have to be checked at runtime).
275 | (BigEndian, false) -> "construct_int64_be_unsigned"
276 | (BigEndian, true) -> "construct_int64_be_signed"
277 | (LittleEndian, false) -> "construct_int64_le_unsigned"
278 | (LittleEndian, true) -> "construct_int64_le_signed"
279 | (NativeEndian, false) -> "construct_int64_ne_unsigned"
280 | (NativeEndian, true) -> "construct_int64_ne_signed"
284 match t, flen_is_const with
285 (* Common case: int field, constant flen.
287 * Range checks are done inside the construction function
288 * because that's a lot simpler w.r.t. types. It might
289 * be better to move them here. XXX
291 | Int, Some i when i > 0 && i <= 64 ->
293 name_of_int_construct_const (i,endian,signed) in
297 Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
302 Loc.raise _loc (Failure "length of int field must be [1..64]")
304 (* Int field, non-constant length. We need to perform a runtime
305 * test to ensure the length is [1..64].
307 * Range checks are done inside the construction function
308 * because that's a lot simpler w.r.t. types. It might
309 * be better to move them here. XXX
312 let construct_func = name_of_int_construct (endian,signed) in
316 if $flen$ >= 1 && $flen$ <= 64 then
317 Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
320 raise (Bitmatch.Construct_failure
321 ("length of int field must be [1..64]",
323 $int:loc_line$, $int:loc_char$))
326 (* String, constant length > 0, must be a multiple of 8. *)
327 | String, Some i when i > 0 && i land 7 = 0 ->
328 let bs = gensym "bs" in
330 let $lid:bs$ = $fexpr$ in
331 if String.length $lid:bs$ = ($flen$ lsr 3) then
332 Bitmatch.construct_string $lid:buffer$ $lid:bs$
334 raise (Bitmatch.Construct_failure
335 ("length of string does not match declaration",
337 $int:loc_line$, $int:loc_char$))
340 (* String, constant length -1, means variable length string
343 | String, Some (-1) ->
344 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
346 (* String, constant length = 0 is probably an error, and so is
350 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
352 (* String, non-constant length.
353 * We check at runtime that the length is > 0, a multiple of 8,
354 * and matches the declared length.
357 let bslen = gensym "bslen" in
358 let bs = gensym "bs" in
360 let $lid:bslen$ = $flen$ in
361 if $lid:bslen$ > 0 then (
362 if $lid:bslen$ land 7 = 0 then (
363 let $lid:bs$ = $fexpr$ in
364 if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
365 Bitmatch.construct_string $lid:buffer$ $lid:bs$
367 raise (Bitmatch.Construct_failure
368 ("length of string does not match declaration",
370 $int:loc_line$, $int:loc_char$))
372 raise (Bitmatch.Construct_failure
373 ("length of string must be a multiple of 8",
375 $int:loc_line$, $int:loc_char$))
377 raise (Bitmatch.Construct_failure
378 ("length of string must be > 0",
380 $int:loc_line$, $int:loc_char$))
383 (* Bitstring, constant length > 0. *)
384 | Bitstring, Some i when i > 0 ->
385 let bs = gensym "bs" in
387 let $lid:bs$ = $fexpr$ in
388 if Bitmatch.bitstring_length $lid:bs$ = $flen$ then
389 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
391 raise (Bitmatch.Construct_failure
392 ("length of bitstring does not match declaration",
394 $int:loc_line$, $int:loc_char$))
397 (* Bitstring, constant length -1, means variable length bitstring
400 | Bitstring, Some (-1) ->
401 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
403 (* Bitstring, constant length = 0 is probably an error, and so is
406 | Bitstring, Some _ ->
409 "length of bitstring must be > 0 or the special value -1")
411 (* Bitstring, non-constant length.
412 * We check at runtime that the length is > 0 and matches
413 * the declared length.
416 let bslen = gensym "bslen" in
417 let bs = gensym "bs" in
419 let $lid:bslen$ = $flen$ in
420 if $lid:bslen$ > 0 then (
421 let $lid:bs$ = $fexpr$ in
422 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
423 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
425 raise (Bitmatch.Construct_failure
426 ("length of bitstring does not match declaration",
428 $int:loc_line$, $int:loc_char$))
430 raise (Bitmatch.Construct_failure
431 ("length of bitstring must be > 0",
433 $int:loc_line$, $int:loc_char$))
438 (* Create the final bitstring. Start by creating an empty buffer
439 * and then evaluate each expression above in turn which will
440 * append some more to the bitstring buffer. Finally extract
443 * XXX We almost have enough information to be able to guess
444 * a good initial size for the buffer.
448 | [] -> <:expr< [] >>
449 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
453 let $lid:buffer$ = Bitmatch.Buffer.create () in
455 Bitmatch.Buffer.contents $lid:buffer$
461 Bitmatch.Construct_failure ("value out of range",
463 $int:loc_line$, $int:loc_char$) in
469 (* Generate the code for a bitmatch statement. '_loc' is the
470 * location, 'bs' is the bitstring parameter, 'cases' are
471 * the list of cases to test against.
473 let output_bitmatch _loc bs cases =
474 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
475 let result = gensym "result" in
477 (* This generates the field extraction code for each
478 * field a single case. Each field must be wider than
479 * the minimum permitted for the type and there must be
480 * enough remaining data in the bitstring to satisfy it.
481 * As we go through the fields, symbols 'data', 'off' and 'len'
482 * track our position and remaining length in the bitstring.
484 * The whole thing is a lot of nested 'if' statements. Code
485 * is generated from the inner-most (last) field outwards.
487 let rec output_field_extraction inner = function
490 let {fpatt=fpatt; fpc={flen=flen; endian=endian; signed=signed;
494 (* Is flen an integer constant? If so, what is it? This
495 * is very simple-minded and only detects simple constants.
499 | <:expr< $int:i$ >> -> Some (int_of_string i)
502 let name_of_int_extract_const = function
503 (* XXX As an enhancement we should allow a 64-bit-only
504 * mode which lets us use 'int' up to 63 bits and won't
505 * compile on 32-bit platforms.
507 (* XXX The meaning of signed/unsigned breaks down at
508 * 31, 32, 63 and 64 bits.
510 | (1, _, _) -> "extract_bit"
511 | ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
512 | ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
513 | (i, BigEndian, false) when i <= 31 -> "extract_int_be_unsigned"
514 | (i, BigEndian, true) when i <= 31 -> "extract_int_be_signed"
515 | (i, LittleEndian, false) when i <= 31 -> "extract_int_le_unsigned"
516 | (i, LittleEndian, true) when i <= 31 -> "extract_int_le_signed"
517 | (i, NativeEndian, false) when i <= 31 -> "extract_int_ne_unsigned"
518 | (i, NativeEndian, true) when i <= 31 -> "extract_int_ne_signed"
519 | (32, BigEndian, false) -> "extract_int32_be_unsigned"
520 | (32, BigEndian, true) -> "extract_int32_be_signed"
521 | (32, LittleEndian, false) -> "extract_int32_le_unsigned"
522 | (32, LittleEndian, true) -> "extract_int32_le_signed"
523 | (32, NativeEndian, false) -> "extract_int32_ne_unsigned"
524 | (32, NativeEndian, true) -> "extract_int32_ne_signed"
525 | (_, BigEndian, false) -> "extract_int64_be_unsigned"
526 | (_, BigEndian, true) -> "extract_int64_be_signed"
527 | (_, LittleEndian, false) -> "extract_int64_le_unsigned"
528 | (_, LittleEndian, true) -> "extract_int64_le_signed"
529 | (_, NativeEndian, false) -> "extract_int64_ne_unsigned"
530 | (_, NativeEndian, true) -> "extract_int64_ne_signed"
532 let name_of_int_extract = function
533 (* XXX As an enhancement we should allow users to
534 * specify that a field length can fit into a char/int/int32
535 * (of course, this would have to be checked at runtime).
537 | (BigEndian, false) -> "extract_int64_be_unsigned"
538 | (BigEndian, true) -> "extract_int64_be_signed"
539 | (LittleEndian, false) -> "extract_int64_le_unsigned"
540 | (LittleEndian, true) -> "extract_int64_le_signed"
541 | (NativeEndian, false) -> "extract_int64_ne_unsigned"
542 | (NativeEndian, true) -> "extract_int64_ne_signed"
546 match t, flen_is_const with
547 (* Common case: int field, constant flen *)
548 | Int, Some i when i > 0 && i <= 64 ->
549 let extract_func = name_of_int_extract_const (i,endian,signed) in
550 let v = gensym "val" in
551 if pattern_is_exhaustive fpatt then
553 if $lid:len$ >= $flen$ then (
554 let $lid:v$, $lid:off$, $lid:len$ =
555 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
557 match $lid:v$ with $fpatt$ -> $inner$
562 if $lid:len$ >= $flen$ then (
563 let $lid:v$, $lid:off$, $lid:len$ =
564 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
566 match $lid:v$ with $fpatt$ -> $inner$ | _ -> ()
571 Loc.raise _loc (Failure "length of int field must be [1..64]")
573 (* Int field, non-const flen. We have to test the range of
574 * the field at runtime. If outside the range it's a no-match
578 let extract_func = name_of_int_extract (endian,signed) in
579 let v = gensym "val" in
580 if pattern_is_exhaustive fpatt then
582 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
583 let $lid:v$, $lid:off$, $lid:len$ =
584 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
586 match $lid:v$ with $fpatt$ -> $inner$
591 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
592 let $lid:v$, $lid:off$, $lid:len$ =
593 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
595 match $lid:v$ with $fpatt$ -> $inner$ | _ -> ()
599 (* String, constant flen > 0. *)
600 | String, Some i when i > 0 && i land 7 = 0 ->
601 let bs = gensym "bs" in
602 if pattern_is_exhaustive fpatt then
604 if $lid:len$ >= $flen$ then (
605 let $lid:bs$, $lid:off$, $lid:len$ =
606 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
608 match Bitmatch.string_of_bitstring $lid:bs$ with
614 if $lid:len$ >= $flen$ then (
615 let $lid:bs$, $lid:off$, $lid:len$ =
616 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
618 match Bitmatch.string_of_bitstring $lid:bs$ with
624 (* String, constant flen = -1, means consume all the
627 | String, Some i when i = -1 ->
628 let bs = gensym "bs" in
629 if pattern_is_exhaustive fpatt then
631 let $lid:bs$, $lid:off$, $lid:len$ =
632 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
633 match Bitmatch.string_of_bitstring $lid:bs$ with
638 let $lid:bs$, $lid:off$, $lid:len$ =
639 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
640 match Bitmatch.string_of_bitstring $lid:bs$ with
646 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
648 (* String field, non-const flen. We check the flen is > 0
649 * and a multiple of 8 (-1 is not allowed here), at runtime.
652 let bs = gensym "bs" in
653 if pattern_is_exhaustive fpatt then
655 if $flen$ >= 0 && $flen$ <= $lid:len$
656 && $flen$ land 7 = 0 then (
657 let $lid:bs$, $lid:off$, $lid:len$ =
658 Bitmatch.extract_bitstring
659 $lid:data$ $lid:off$ $lid:len$ $flen$ in
660 match Bitmatch.string_of_bitstring $lid:bs$ with
666 if $flen$ >= 0 && $flen$ <= $lid:len$
667 && $flen$ land 7 = 0 then (
668 let $lid:bs$, $lid:off$, $lid:len$ =
669 Bitmatch.extract_bitstring
670 $lid:data$ $lid:off$ $lid:len$ $flen$ in
671 match Bitmatch.string_of_bitstring $lid:bs$ with
677 (* Bitstring, constant flen >= 0.
678 * At the moment all we can do is assign the bitstring to an
681 | Bitstring, Some i when i >= 0 ->
684 | <:patt< $lid:ident$ >> -> ident
685 | <:patt< _ >> -> "_"
688 (Failure "cannot compare a bitstring to a constant") in
690 if $lid:len$ >= $flen$ then (
691 let $lid:ident$, $lid:off$, $lid:len$ =
692 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
698 (* Bitstring, constant flen = -1, means consume all the
701 | Bitstring, Some i when i = -1 ->
704 | <:patt< $lid:ident$ >> -> ident
707 (Failure "cannot compare a bitstring to a constant") in
709 let $lid:ident$, $lid:off$, $lid:len$ =
710 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
714 | Bitstring, Some _ ->
715 Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
717 (* Bitstring field, non-const flen. We check the flen is >= 0
718 * (-1 is not allowed here) at runtime.
723 | <:patt< $lid:ident$ >> -> ident
726 (Failure "cannot compare a bitstring to a constant") in
728 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
729 let $lid:ident$, $lid:off$, $lid:len$ =
730 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
737 (* Emit extra debugging code. *)
739 if not debug then expr else (
740 let field = string_of_patt_field field in
743 if !Bitmatch.debug then (
744 Printf.eprintf "PA_BITMATCH: TEST:\n";
745 Printf.eprintf " %s\n" $str:field$;
746 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
747 (*Bitmatch.hexdump_bitstring stderr
748 ($lid:data$,$lid:off$,$lid:len$);*)
754 output_field_extraction expr fields
757 (* Convert each case in the match. *)
758 let cases = List.map (
759 fun (fields, bind, whenclause, code) ->
760 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
762 match whenclause with
764 <:expr< if $whenclause$ then $inner$ >>
770 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
774 output_field_extraction inner (List.rev fields)
777 (* Join them into a single expression.
779 * Don't do it with a normal fold_right because that leaves
780 * 'raise Exit; ()' at the end which causes a compiler warning.
781 * Hence a bit of complexity here.
783 * Note that the number of cases is always >= 1 so List.hd is safe.
785 let cases = List.rev cases in
787 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
788 (List.hd cases) (List.tl cases) in
790 (* The final code just wraps the list of cases in a
791 * try/with construct so that each case is tried in
792 * turn until one case matches (that case sets 'result'
793 * and raises 'Exit' to leave the whole statement).
794 * If result isn't set by the end then we will raise
795 * Match_failure with the location of the bitmatch
796 * statement in the original code.
798 let loc_fname = Loc.file_name _loc in
799 let loc_line = string_of_int (Loc.start_line _loc) in
800 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
803 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
804 let $lid:result$ = ref None in
808 match ! $lid:result$ with
810 | None -> raise (Match_failure ($str:loc_fname$,
811 $int:loc_line$, $int:loc_char$))
818 [ LIST0 [ q = LIDENT -> q ] SEP "," ]
821 (* Field used in the bitmatch operator (a pattern). *)
823 [ fpatt = patt; ":"; len = expr LEVEL "top";
824 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
825 parse_patt_field _loc fpatt len qs
829 (* Case inside bitmatch operator. *)
832 fields = LIST0 patt_field SEP ";";
834 bind = OPT [ "as"; name = LIDENT -> name ];
835 whenclause = OPT [ "when"; e = expr -> e ]; "->";
837 (fields, bind, whenclause, code)
841 (* Field used in the BITSTRING constructor (an expression). *)
843 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
844 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
845 parse_constr_field _loc fexpr len qs
849 (* 'bitmatch' expressions. *)
852 bs = expr; "with"; OPT "|";
853 cases = LIST1 match_case SEP "|" ->
854 output_bitmatch _loc bs cases
858 | [ "BITSTRING"; "{";
859 fields = LIST0 constr_field SEP ";";
861 output_constructor _loc fields