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.11 2008-04-25 14:57:11 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 (* Work out if an expression is an integer constant.
37 * Returns [Some i] if so (where i is the integer value), else [None].
39 * Fairly simplistic algorithm: we can only detect simple constant
40 * expressions such as [k], [k+c], [k-c] etc.
42 let rec expr_is_constant = function
43 | <:expr< $int:i$ >> -> (* Literal integer constant. *)
44 Some (int_of_string i)
45 | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
46 (match expr_is_constant a, expr_is_constant b with
47 | Some a, Some b -> Some (a+b)
49 | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
50 (match expr_is_constant a, expr_is_constant b with
51 | Some a, Some b -> Some (a-b)
53 | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
54 (match expr_is_constant a, expr_is_constant b with
55 | Some a, Some b -> Some (a*b)
57 | <:expr< $a$ / $b$ >> -> (* Division. *)
58 (match expr_is_constant a, expr_is_constant b with
59 | Some a, Some b -> Some (a/b)
61 | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
62 (match expr_is_constant a, expr_is_constant b with
63 | Some a, Some b -> Some (a lsl b)
65 | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
66 (match expr_is_constant a, expr_is_constant b with
67 | Some a, Some b -> Some (a lsr b)
69 | _ -> None (* Anything else is not constant. *)
71 (* A field when used in a bitmatch (a pattern). *)
73 fpatt : patt; (* field matching pattern *)
76 (* A field when used in a BITSTRING constructor (an expression). *)
78 fexpr : expr; (* field value *)
83 flen : expr; (* length in bits, may be non-const *)
84 endian : endian; (* endianness *)
85 signed : bool; (* true if signed, false if unsigned *)
87 _loc : Loc.t; (* location in source code *)
89 and endian = BigEndian | LittleEndian | NativeEndian
90 and t = Int | String | Bitstring
92 (* Generate a fresh, unique symbol each time called. *)
97 sprintf "__pabitmatch_%s_%d" name i
99 let rec parse_patt_field _loc fpatt flen qs =
100 let fpc = parse_field_common _loc flen qs in
101 { fpatt = fpatt; fpc = fpc }
103 and parse_constr_field _loc fexpr flen qs =
104 let fec = parse_field_common _loc flen qs in
105 { fexpr = fexpr; fec = fec }
107 (* Deal with the qualifiers which appear for a field of both types. *)
108 and parse_field_common _loc flen qs =
109 let endian, signed, t =
111 | None -> (None, None, None)
114 fun (endian, signed, t) q ->
117 if endian <> None then
118 Loc.raise _loc (Failure "an endian flag has been set already")
120 let endian = Some BigEndian in
124 if endian <> None then
125 Loc.raise _loc (Failure "an endian flag has been set already")
127 let endian = Some LittleEndian in
131 if endian <> None then
132 Loc.raise _loc (Failure "an endian flag has been set already")
134 let endian = Some NativeEndian in
138 if signed <> None then
139 Loc.raise _loc (Failure "a signed flag has been set already")
141 let signed = Some true in
145 if signed <> None then
146 Loc.raise _loc (Failure "a signed flag has been set already")
148 let signed = Some false in
153 Loc.raise _loc (Failure "a type flag has been set already")
160 Loc.raise _loc (Failure "a type flag has been set already")
162 let t = Some String in
167 Loc.raise _loc (Failure "a type flag has been set already")
169 let t = Some Bitstring in
173 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
174 ) (None, None, None) qs in
176 (* If type is set to string or bitstring then endianness and
177 * signedness qualifiers are meaningless and must not be set.
179 if (t = Some Bitstring || t = Some String)
180 && (endian <> None || signed <> None) then
182 Failure "string types and endian or signed qualifiers cannot be mixed"
185 (* Default endianness, signedness, type. *)
186 let endian = match endian with None -> BigEndian | Some e -> e in
187 let signed = match signed with None -> false | Some s -> s in
188 let t = match t with None -> Int | Some t -> t in
198 let string_of_endian = function
199 | BigEndian -> "bigendian"
200 | LittleEndian -> "littleendian"
201 | NativeEndian -> "nativeendian"
203 let string_of_t = function
206 | Bitstring -> "bitstring"
208 let rec string_of_patt_field { fpatt = fpatt; fpc = fpc } =
209 let fpc = string_of_field_common fpc in
212 | <:patt< $lid:id$ >> -> id
213 | _ -> "[pattern]" in
216 and string_of_constr_field { fexpr = fexpr; fec = fec } =
217 let fec = string_of_field_common fec in
220 | <:expr< $lid:id$ >> -> id
221 | _ -> "[expression]" in
224 and string_of_field_common { flen = flen;
225 endian = endian; signed = signed; t = t;
228 match expr_is_constant flen with
229 | Some i -> string_of_int i
230 | None -> "[non-const-len]" in
231 let endian = string_of_endian endian in
232 let signed = if signed then "signed" else "unsigned" in
233 let t = string_of_t t in
234 let loc_fname = Loc.file_name _loc in
235 let loc_line = Loc.start_line _loc in
236 let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
238 sprintf "%s : %s, %s, %s @ (%S, %d, %d)"
239 flen t endian signed loc_fname loc_line loc_char
241 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
242 let output_constructor _loc fields =
243 let loc_fname = Loc.file_name _loc in
244 let loc_line = string_of_int (Loc.start_line _loc) in
245 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
247 (* Bitstrings are created like the 'Buffer' module (in fact, using
248 * the Buffer module), by appending snippets to a growing buffer.
249 * This is reasonably efficient and avoids a lot of garbage.
251 let buffer = gensym "buffer" in
253 (* General exception which is raised inside the constructor functions
254 * when an int expression is out of range at runtime.
256 let exn = gensym "exn" in
257 let exn_used = ref false in
259 (* Convert each field to a simple bitstring-generating expression. *)
260 let fields = List.map (
261 fun {fexpr=fexpr; fec={flen=flen; endian=endian; signed=signed;
263 (* Is flen an integer constant? If so, what is it? This
264 * is very simple-minded and only detects simple constants.
266 let flen_is_const = expr_is_constant flen in
268 let name_of_int_construct_const = function
269 (* XXX As an enhancement we should allow a 64-bit-only
270 * mode which lets us use 'int' up to 63 bits and won't
271 * compile on 32-bit platforms.
273 (* XXX The meaning of signed/unsigned breaks down at
274 * 31, 32, 63 and 64 bits.
276 | (1, _, _) -> "construct_bit"
277 | ((2|3|4|5|6|7|8), _, false) -> "construct_char_unsigned"
278 | ((2|3|4|5|6|7|8), _, true) -> "construct_char_signed"
279 | (i, BigEndian, false) when i <= 31 -> "construct_int_be_unsigned"
280 | (i, BigEndian, true) when i <= 31 -> "construct_int_be_signed"
281 | (i, LittleEndian, false) when i <= 31 -> "construct_int_le_unsigned"
282 | (i, LittleEndian, true) when i <= 31 -> "construct_int_le_signed"
283 | (i, NativeEndian, false) when i <= 31 -> "construct_int_ne_unsigned"
284 | (i, NativeEndian, true) when i <= 31 -> "construct_int_ne_signed"
285 | (32, BigEndian, false) -> "construct_int32_be_unsigned"
286 | (32, BigEndian, true) -> "construct_int32_be_signed"
287 | (32, LittleEndian, false) -> "construct_int32_le_unsigned"
288 | (32, LittleEndian, true) -> "construct_int32_le_signed"
289 | (32, NativeEndian, false) -> "construct_int32_ne_unsigned"
290 | (32, NativeEndian, true) -> "construct_int32_ne_signed"
291 | (_, BigEndian, false) -> "construct_int64_be_unsigned"
292 | (_, BigEndian, true) -> "construct_int64_be_signed"
293 | (_, LittleEndian, false) -> "construct_int64_le_unsigned"
294 | (_, LittleEndian, true) -> "construct_int64_le_signed"
295 | (_, NativeEndian, false) -> "construct_int64_ne_unsigned"
296 | (_, NativeEndian, true) -> "construct_int64_ne_signed"
298 let name_of_int_construct = function
299 (* XXX As an enhancement we should allow users to
300 * specify that a field length can fit into a char/int/int32
301 * (of course, this would have to be checked at runtime).
303 | (BigEndian, false) -> "construct_int64_be_unsigned"
304 | (BigEndian, true) -> "construct_int64_be_signed"
305 | (LittleEndian, false) -> "construct_int64_le_unsigned"
306 | (LittleEndian, true) -> "construct_int64_le_signed"
307 | (NativeEndian, false) -> "construct_int64_ne_unsigned"
308 | (NativeEndian, true) -> "construct_int64_ne_signed"
312 match t, flen_is_const with
313 (* Common case: int field, constant flen.
315 * Range checks are done inside the construction function
316 * because that's a lot simpler w.r.t. types. It might
317 * be better to move them here. XXX
319 | Int, Some i when i > 0 && i <= 64 ->
321 name_of_int_construct_const (i,endian,signed) in
325 Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
330 Loc.raise _loc (Failure "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_func = name_of_int_construct (endian,signed) in
344 if $flen$ >= 1 && $flen$ <= 64 then
345 Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
348 raise (Bitmatch.Construct_failure
349 ("length of int field must be [1..64]",
351 $int:loc_line$, $int:loc_char$))
354 (* String, constant length > 0, must be a multiple of 8. *)
355 | String, Some i when i > 0 && i land 7 = 0 ->
356 let bs = gensym "bs" in
358 let $lid:bs$ = $fexpr$ in
359 if String.length $lid:bs$ = ($flen$ lsr 3) 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 | String, Some (-1) ->
372 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
374 (* String, constant length = 0 is probably an error, and so is
378 Loc.raise _loc (Failure "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 | 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$ = $flen$ 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 | Bitstring, Some (-1) ->
429 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
431 (* Bitstring, constant length = 0 is probably an error, and so is
434 | Bitstring, Some _ ->
437 "length of bitstring must be > 0 or the special value -1")
439 (* Bitstring, non-constant length.
440 * We check at runtime that the length is > 0 and matches
441 * the declared length.
444 let bslen = gensym "bslen" in
445 let bs = gensym "bs" in
447 let $lid:bslen$ = $flen$ in
448 if $lid:bslen$ > 0 then (
449 let $lid:bs$ = $fexpr$ in
450 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
451 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
453 raise (Bitmatch.Construct_failure
454 ("length of bitstring does not match declaration",
456 $int:loc_line$, $int:loc_char$))
458 raise (Bitmatch.Construct_failure
459 ("length of bitstring must be > 0",
461 $int:loc_line$, $int:loc_char$))
466 (* Create the final bitstring. Start by creating an empty buffer
467 * and then evaluate each expression above in turn which will
468 * append some more to the bitstring buffer. Finally extract
471 * XXX We almost have enough information to be able to guess
472 * a good initial size for the buffer.
476 | [] -> <:expr< [] >>
477 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
481 let $lid:buffer$ = Bitmatch.Buffer.create () in
483 Bitmatch.Buffer.contents $lid:buffer$
489 Bitmatch.Construct_failure ("value out of range",
491 $int:loc_line$, $int:loc_char$) in
497 (* Generate the code for a bitmatch statement. '_loc' is the
498 * location, 'bs' is the bitstring parameter, 'cases' are
499 * the list of cases to test against.
501 let output_bitmatch _loc bs cases =
502 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
503 let result = gensym "result" in
505 (* This generates the field extraction code for each
506 * field a single case. Each field must be wider than
507 * the minimum permitted for the type and there must be
508 * enough remaining data in the bitstring to satisfy it.
509 * As we go through the fields, symbols 'data', 'off' and 'len'
510 * track our position and remaining length in the bitstring.
512 * The whole thing is a lot of nested 'if' statements. Code
513 * is generated from the inner-most (last) field outwards.
515 let rec output_field_extraction inner = function
518 let {fpatt=fpatt; fpc={flen=flen; endian=endian; signed=signed;
522 (* Is flen an integer constant? If so, what is it? This
523 * is very simple-minded and only detects simple constants.
525 let flen_is_const = expr_is_constant flen in
527 let name_of_int_extract_const = function
528 (* XXX As an enhancement we should allow a 64-bit-only
529 * mode which lets us use 'int' up to 63 bits and won't
530 * compile on 32-bit platforms.
532 (* XXX The meaning of signed/unsigned breaks down at
533 * 31, 32, 63 and 64 bits.
535 | (1, _, _) -> "extract_bit"
536 | ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
537 | ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
538 | (i, BigEndian, false) when i <= 31 -> "extract_int_be_unsigned"
539 | (i, BigEndian, true) when i <= 31 -> "extract_int_be_signed"
540 | (i, LittleEndian, false) when i <= 31 -> "extract_int_le_unsigned"
541 | (i, LittleEndian, true) when i <= 31 -> "extract_int_le_signed"
542 | (i, NativeEndian, false) when i <= 31 -> "extract_int_ne_unsigned"
543 | (i, NativeEndian, true) when i <= 31 -> "extract_int_ne_signed"
544 | (32, BigEndian, false) -> "extract_int32_be_unsigned"
545 | (32, BigEndian, true) -> "extract_int32_be_signed"
546 | (32, LittleEndian, false) -> "extract_int32_le_unsigned"
547 | (32, LittleEndian, true) -> "extract_int32_le_signed"
548 | (32, NativeEndian, false) -> "extract_int32_ne_unsigned"
549 | (32, NativeEndian, true) -> "extract_int32_ne_signed"
550 | (_, BigEndian, false) -> "extract_int64_be_unsigned"
551 | (_, BigEndian, true) -> "extract_int64_be_signed"
552 | (_, LittleEndian, false) -> "extract_int64_le_unsigned"
553 | (_, LittleEndian, true) -> "extract_int64_le_signed"
554 | (_, NativeEndian, false) -> "extract_int64_ne_unsigned"
555 | (_, NativeEndian, true) -> "extract_int64_ne_signed"
557 let name_of_int_extract = function
558 (* XXX As an enhancement we should allow users to
559 * specify that a field length can fit into a char/int/int32
560 * (of course, this would have to be checked at runtime).
562 | (BigEndian, false) -> "extract_int64_be_unsigned"
563 | (BigEndian, true) -> "extract_int64_be_signed"
564 | (LittleEndian, false) -> "extract_int64_le_unsigned"
565 | (LittleEndian, true) -> "extract_int64_le_signed"
566 | (NativeEndian, false) -> "extract_int64_ne_unsigned"
567 | (NativeEndian, true) -> "extract_int64_ne_signed"
571 match t, flen_is_const with
572 (* Common case: int field, constant flen *)
573 | Int, Some i when i > 0 && i <= 64 ->
574 let extract_func = name_of_int_extract_const (i,endian,signed) in
575 let v = gensym "val" in
577 if $lid:len$ >= $flen$ then (
578 let $lid:v$, $lid:off$, $lid:len$ =
579 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
581 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
586 Loc.raise _loc (Failure "length of int field must be [1..64]")
588 (* Int field, non-const flen. We have to test the range of
589 * the field at runtime. If outside the range it's a no-match
593 let extract_func = name_of_int_extract (endian,signed) in
594 let v = gensym "val" in
596 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
597 let $lid:v$, $lid:off$, $lid:len$ =
598 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
600 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
604 (* String, constant flen > 0. *)
605 | String, Some i when i > 0 && i land 7 = 0 ->
606 let bs = gensym "bs" in
608 if $lid:len$ >= $flen$ then (
609 let $lid:bs$, $lid:off$, $lid:len$ =
610 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
612 match Bitmatch.string_of_bitstring $lid:bs$ with
613 | $fpatt$ when true -> $inner$
618 (* String, constant flen = -1, means consume all the
621 | String, Some i when i = -1 ->
622 let bs = gensym "bs" in
624 let $lid:bs$, $lid:off$, $lid:len$ =
625 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
626 match Bitmatch.string_of_bitstring $lid:bs$ with
627 | $fpatt$ when true -> $inner$
632 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
634 (* String field, non-const flen. We check the flen is > 0
635 * and a multiple of 8 (-1 is not allowed here), at runtime.
638 let bs = gensym "bs" in
640 if $flen$ >= 0 && $flen$ <= $lid:len$
641 && $flen$ land 7 = 0 then (
642 let $lid:bs$, $lid:off$, $lid:len$ =
643 Bitmatch.extract_bitstring
644 $lid:data$ $lid:off$ $lid:len$ $flen$ in
645 match Bitmatch.string_of_bitstring $lid:bs$ with
646 | $fpatt$ when true -> $inner$
651 (* Bitstring, constant flen >= 0.
652 * At the moment all we can do is assign the bitstring to an
655 | Bitstring, Some i when i >= 0 ->
658 | <:patt< $lid:ident$ >> -> ident
659 | <:patt< _ >> -> "_"
662 (Failure "cannot compare a bitstring to a constant") in
664 if $lid:len$ >= $flen$ then (
665 let $lid:ident$, $lid:off$, $lid:len$ =
666 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
672 (* Bitstring, constant flen = -1, means consume all the
675 | Bitstring, Some i when i = -1 ->
678 | <:patt< $lid:ident$ >> -> ident
681 (Failure "cannot compare a bitstring to a constant") in
683 let $lid:ident$, $lid:off$, $lid:len$ =
684 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
688 | Bitstring, Some _ ->
689 Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
691 (* Bitstring field, non-const flen. We check the flen is >= 0
692 * (-1 is not allowed here) at runtime.
697 | <:patt< $lid:ident$ >> -> ident
700 (Failure "cannot compare a bitstring to a constant") in
702 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
703 let $lid:ident$, $lid:off$, $lid:len$ =
704 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
711 (* Emit extra debugging code. *)
713 if not debug then expr else (
714 let field = string_of_patt_field field in
717 if !Bitmatch.debug then (
718 Printf.eprintf "PA_BITMATCH: TEST:\n";
719 Printf.eprintf " %s\n" $str:field$;
720 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
721 (*Bitmatch.hexdump_bitstring stderr
722 ($lid:data$,$lid:off$,$lid:len$);*)
728 output_field_extraction expr fields
731 (* Convert each case in the match. *)
732 let cases = List.map (
733 fun (fields, bind, whenclause, code) ->
734 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
736 match whenclause with
738 <:expr< if $whenclause$ then $inner$ >>
744 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
748 output_field_extraction inner (List.rev fields)
751 (* Join them into a single expression.
753 * Don't do it with a normal fold_right because that leaves
754 * 'raise Exit; ()' at the end which causes a compiler warning.
755 * Hence a bit of complexity here.
757 * Note that the number of cases is always >= 1 so List.hd is safe.
759 let cases = List.rev cases in
761 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
762 (List.hd cases) (List.tl cases) in
764 (* The final code just wraps the list of cases in a
765 * try/with construct so that each case is tried in
766 * turn until one case matches (that case sets 'result'
767 * and raises 'Exit' to leave the whole statement).
768 * If result isn't set by the end then we will raise
769 * Match_failure with the location of the bitmatch
770 * statement in the original code.
772 let loc_fname = Loc.file_name _loc in
773 let loc_line = string_of_int (Loc.start_line _loc) in
774 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
777 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
778 let $lid:result$ = ref None in
782 match ! $lid:result$ with
784 | None -> raise (Match_failure ($str:loc_fname$,
785 $int:loc_line$, $int:loc_char$))
792 [ LIST0 [ q = LIDENT -> q ] SEP "," ]
795 (* Field used in the bitmatch operator (a pattern). *)
797 [ fpatt = patt; ":"; len = expr LEVEL "top";
798 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
799 parse_patt_field _loc fpatt len qs
803 (* Case inside bitmatch operator. *)
806 fields = LIST0 patt_field SEP ";";
808 bind = OPT [ "as"; name = LIDENT -> name ];
809 whenclause = OPT [ "when"; e = expr -> e ]; "->";
811 (fields, bind, whenclause, code)
815 (* Field used in the BITSTRING constructor (an expression). *)
817 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
818 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
819 parse_constr_field _loc fexpr len qs
823 (* 'bitmatch' expressions. *)
826 bs = expr; "with"; OPT "|";
827 cases = LIST1 match_case SEP "|" ->
828 output_bitmatch _loc bs cases
832 | [ "BITSTRING"; "{";
833 fields = LIST0 constr_field SEP ";";
835 output_constructor _loc fields