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
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 (* Field. In bitmatch (patterns) the type is [patt field]. In
72 * BITSTRING (constructor) the type is [expr field].
75 field : 'a; (* field ('a is either patt or expr) *)
76 flen : expr; (* length in bits, may be non-const *)
77 endian : Bitmatch.endian; (* endianness *)
78 signed : bool; (* true if signed, false if unsigned *)
80 _loc : Loc.t; (* location in source code *)
81 printer : 'a -> string; (* turn the field into a string *)
83 and t = Int | String | Bitstring
85 (* Generate a fresh, unique symbol each time called. *)
90 sprintf "__pabitmatch_%s_%d" name i
92 (* Deal with the qualifiers which appear for a field of both types. *)
93 let parse_field _loc field flen qs printer =
94 let endian, signed, t =
96 | None -> (None, None, None)
99 fun (endian, signed, t) q ->
102 if endian <> None then
103 Loc.raise _loc (Failure "an endian flag has been set already")
105 let endian = Some Bitmatch.BigEndian in
109 if endian <> None then
110 Loc.raise _loc (Failure "an endian flag has been set already")
112 let endian = Some Bitmatch.LittleEndian in
116 if endian <> None then
117 Loc.raise _loc (Failure "an endian flag has been set already")
119 let endian = Some Bitmatch.NativeEndian in
123 if signed <> None then
124 Loc.raise _loc (Failure "a signed flag has been set already")
126 let signed = Some true in
130 if signed <> None then
131 Loc.raise _loc (Failure "a signed flag has been set already")
133 let signed = Some false in
138 Loc.raise _loc (Failure "a type flag has been set already")
145 Loc.raise _loc (Failure "a type flag has been set already")
147 let t = Some String in
152 Loc.raise _loc (Failure "a type flag has been set already")
154 let t = Some Bitstring in
158 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
159 ) (None, None, None) qs in
161 (* If type is set to string or bitstring then endianness and
162 * signedness qualifiers are meaningless and must not be set.
164 if (t = Some Bitstring || t = Some String)
165 && (endian <> None || signed <> None) then
167 Failure "string types and endian or signed qualifiers cannot be mixed"
170 (* Default endianness, signedness, type. *)
171 let endian = match endian with None -> Bitmatch.BigEndian | Some e -> e in
172 let signed = match signed with None -> false | Some s -> s in
173 let t = match t with None -> Int | Some t -> t in
185 let string_of_t = function
188 | Bitstring -> "bitstring"
190 let patt_printer = function
191 | <:patt< $lid:id$ >> -> id
194 let expr_printer = function
195 | <:expr< $lid:id$ >> -> id
196 | _ -> "[expression]"
198 let string_of_field { field = field; flen = flen;
199 endian = endian; signed = signed; t = t;
203 match expr_is_constant flen with
204 | Some i -> string_of_int i
205 | None -> "[non-const-len]" in
206 let endian = Bitmatch.string_of_endian endian in
207 let signed = if signed then "signed" else "unsigned" in
208 let t = string_of_t t in
209 let loc_fname = Loc.file_name _loc in
210 let loc_line = Loc.start_line _loc in
211 let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
213 sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)"
214 (printer field) flen t endian signed loc_fname loc_line loc_char
216 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
217 let output_constructor _loc fields =
218 let loc_fname = Loc.file_name _loc in
219 let loc_line = string_of_int (Loc.start_line _loc) in
220 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
222 (* Bitstrings are created like the 'Buffer' module (in fact, using
223 * the Buffer module), by appending snippets to a growing buffer.
224 * This is reasonably efficient and avoids a lot of garbage.
226 let buffer = gensym "buffer" in
228 (* General exception which is raised inside the constructor functions
229 * when an int expression is out of range at runtime.
231 let exn = gensym "exn" in
232 let exn_used = ref false in
234 (* Convert each field to a simple bitstring-generating expression. *)
235 let fields = List.map (
236 fun {field=fexpr; flen=flen; endian=endian; signed=signed;
238 (* Is flen an integer constant? If so, what is it? This
239 * is very simple-minded and only detects simple constants.
241 let flen_is_const = expr_is_constant flen in
243 let name_of_int_construct_const = function
244 (* XXX As an enhancement we should allow a 64-bit-only
245 * mode which lets us use 'int' up to 63 bits and won't
246 * compile on 32-bit platforms.
248 (* XXX The meaning of signed/unsigned breaks down at
249 * 31, 32, 63 and 64 bits.
251 | (1, _, _) -> "construct_bit"
252 | ((2|3|4|5|6|7|8), _, false) -> "construct_char_unsigned"
253 | ((2|3|4|5|6|7|8), _, true) -> "construct_char_signed"
254 | (i, Bitmatch.BigEndian, false) when i <= 31 ->
255 "construct_int_be_unsigned"
256 | (i, Bitmatch.BigEndian, true) when i <= 31 ->
257 "construct_int_be_signed"
258 | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
259 "construct_int_le_unsigned"
260 | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
261 "construct_int_le_signed"
262 | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
263 "construct_int_ne_unsigned"
264 | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
265 "construct_int_ne_signed"
266 | (32, Bitmatch.BigEndian, false) -> "construct_int32_be_unsigned"
267 | (32, Bitmatch.BigEndian, true) -> "construct_int32_be_signed"
268 | (32, Bitmatch.LittleEndian, false) -> "construct_int32_le_unsigned"
269 | (32, Bitmatch.LittleEndian, true) -> "construct_int32_le_signed"
270 | (32, Bitmatch.NativeEndian, false) -> "construct_int32_ne_unsigned"
271 | (32, Bitmatch.NativeEndian, true) -> "construct_int32_ne_signed"
272 | (_, Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
273 | (_, Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
274 | (_, Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
275 | (_, Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
276 | (_, Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
277 | (_, Bitmatch.NativeEndian, true) -> "construct_int64_ne_signed"
279 let name_of_int_construct = function
280 (* XXX As an enhancement we should allow users to
281 * specify that a field length can fit into a char/int/int32
282 * (of course, this would have to be checked at runtime).
284 | (Bitmatch.BigEndian, false) -> "construct_int64_be_unsigned"
285 | (Bitmatch.BigEndian, true) -> "construct_int64_be_signed"
286 | (Bitmatch.LittleEndian, false) -> "construct_int64_le_unsigned"
287 | (Bitmatch.LittleEndian, true) -> "construct_int64_le_signed"
288 | (Bitmatch.NativeEndian, false) -> "construct_int64_ne_unsigned"
289 | (Bitmatch.NativeEndian, true) -> "construct_int64_ne_signed"
293 match t, flen_is_const with
294 (* Common case: int field, constant flen.
296 * Range checks are done inside the construction function
297 * because that's a lot simpler w.r.t. types. It might
298 * be better to move them here. XXX
300 | Int, Some i when i > 0 && i <= 64 ->
302 name_of_int_construct_const (i,endian,signed) in
306 Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
311 Loc.raise _loc (Failure "length of int field must be [1..64]")
313 (* Int field, non-constant length. We need to perform a runtime
314 * test to ensure the length is [1..64].
316 * Range checks are done inside the construction function
317 * because that's a lot simpler w.r.t. types. It might
318 * be better to move them here. XXX
321 let construct_func = name_of_int_construct (endian,signed) in
325 if $flen$ >= 1 && $flen$ <= 64 then
326 Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
329 raise (Bitmatch.Construct_failure
330 ("length of int field must be [1..64]",
332 $int:loc_line$, $int:loc_char$))
335 (* String, constant length > 0, must be a multiple of 8. *)
336 | String, Some i when i > 0 && i land 7 = 0 ->
337 let bs = gensym "bs" in
339 let $lid:bs$ = $fexpr$ in
340 if String.length $lid:bs$ = ($flen$ lsr 3) then
341 Bitmatch.construct_string $lid:buffer$ $lid:bs$
343 raise (Bitmatch.Construct_failure
344 ("length of string does not match declaration",
346 $int:loc_line$, $int:loc_char$))
349 (* String, constant length -1, means variable length string
352 | String, Some (-1) ->
353 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
355 (* String, constant length = 0 is probably an error, and so is
359 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
361 (* String, non-constant length.
362 * We check at runtime that the length is > 0, a multiple of 8,
363 * and matches the declared length.
366 let bslen = gensym "bslen" in
367 let bs = gensym "bs" in
369 let $lid:bslen$ = $flen$ in
370 if $lid:bslen$ > 0 then (
371 if $lid:bslen$ land 7 = 0 then (
372 let $lid:bs$ = $fexpr$ in
373 if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
374 Bitmatch.construct_string $lid:buffer$ $lid:bs$
376 raise (Bitmatch.Construct_failure
377 ("length of string does not match declaration",
379 $int:loc_line$, $int:loc_char$))
381 raise (Bitmatch.Construct_failure
382 ("length of string must be a multiple of 8",
384 $int:loc_line$, $int:loc_char$))
386 raise (Bitmatch.Construct_failure
387 ("length of string must be > 0",
389 $int:loc_line$, $int:loc_char$))
392 (* Bitstring, constant length > 0. *)
393 | Bitstring, Some i when i > 0 ->
394 let bs = gensym "bs" in
396 let $lid:bs$ = $fexpr$ in
397 if Bitmatch.bitstring_length $lid:bs$ = $flen$ then
398 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
400 raise (Bitmatch.Construct_failure
401 ("length of bitstring does not match declaration",
403 $int:loc_line$, $int:loc_char$))
406 (* Bitstring, constant length -1, means variable length bitstring
409 | Bitstring, Some (-1) ->
410 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
412 (* Bitstring, constant length = 0 is probably an error, and so is
415 | Bitstring, Some _ ->
418 "length of bitstring must be > 0 or the special value -1")
420 (* Bitstring, non-constant length.
421 * We check at runtime that the length is > 0 and matches
422 * the declared length.
425 let bslen = gensym "bslen" in
426 let bs = gensym "bs" in
428 let $lid:bslen$ = $flen$ in
429 if $lid:bslen$ > 0 then (
430 let $lid:bs$ = $fexpr$ in
431 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
432 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
434 raise (Bitmatch.Construct_failure
435 ("length of bitstring does not match declaration",
437 $int:loc_line$, $int:loc_char$))
439 raise (Bitmatch.Construct_failure
440 ("length of bitstring must be > 0",
442 $int:loc_line$, $int:loc_char$))
447 (* Create the final bitstring. Start by creating an empty buffer
448 * and then evaluate each expression above in turn which will
449 * append some more to the bitstring buffer. Finally extract
452 * XXX We almost have enough information to be able to guess
453 * a good initial size for the buffer.
457 | [] -> <:expr< [] >>
458 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
462 let $lid:buffer$ = Bitmatch.Buffer.create () in
464 Bitmatch.Buffer.contents $lid:buffer$
470 Bitmatch.Construct_failure ("value out of range",
472 $int:loc_line$, $int:loc_char$) in
478 (* Generate the code for a bitmatch statement. '_loc' is the
479 * location, 'bs' is the bitstring parameter, 'cases' are
480 * the list of cases to test against.
482 let output_bitmatch _loc bs cases =
483 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
484 let result = gensym "result" in
486 (* This generates the field extraction code for each
487 * field a single case. Each field must be wider than
488 * the minimum permitted for the type and there must be
489 * enough remaining data in the bitstring to satisfy it.
490 * As we go through the fields, symbols 'data', 'off' and 'len'
491 * track our position and remaining length in the bitstring.
493 * The whole thing is a lot of nested 'if' statements. Code
494 * is generated from the inner-most (last) field outwards.
496 let rec output_field_extraction inner = function
499 let {field=fpatt; flen=flen; endian=endian; signed=signed;
503 (* Is flen an integer constant? If so, what is it? This
504 * is very simple-minded and only detects simple constants.
506 let flen_is_const = expr_is_constant flen in
508 let name_of_int_extract_const = function
509 (* XXX As an enhancement we should allow a 64-bit-only
510 * mode which lets us use 'int' up to 63 bits and won't
511 * compile on 32-bit platforms.
513 (* XXX The meaning of signed/unsigned breaks down at
514 * 31, 32, 63 and 64 bits.
516 | (1, _, _) -> "extract_bit"
517 | ((2|3|4|5|6|7|8), _, false) -> "extract_char_unsigned"
518 | ((2|3|4|5|6|7|8), _, true) -> "extract_char_signed"
519 | (i, Bitmatch.BigEndian, false) when i <= 31 ->
520 "extract_int_be_unsigned"
521 | (i, Bitmatch.BigEndian, true) when i <= 31 ->
522 "extract_int_be_signed"
523 | (i, Bitmatch.LittleEndian, false) when i <= 31 ->
524 "extract_int_le_unsigned"
525 | (i, Bitmatch.LittleEndian, true) when i <= 31 ->
526 "extract_int_le_signed"
527 | (i, Bitmatch.NativeEndian, false) when i <= 31 ->
528 "extract_int_ne_unsigned"
529 | (i, Bitmatch.NativeEndian, true) when i <= 31 ->
530 "extract_int_ne_signed"
531 | (32, Bitmatch.BigEndian, false) -> "extract_int32_be_unsigned"
532 | (32, Bitmatch.BigEndian, true) -> "extract_int32_be_signed"
533 | (32, Bitmatch.LittleEndian, false) -> "extract_int32_le_unsigned"
534 | (32, Bitmatch.LittleEndian, true) -> "extract_int32_le_signed"
535 | (32, Bitmatch.NativeEndian, false) -> "extract_int32_ne_unsigned"
536 | (32, Bitmatch.NativeEndian, true) -> "extract_int32_ne_signed"
537 | (_, Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
538 | (_, Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
539 | (_, Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
540 | (_, Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
541 | (_, Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
542 | (_, Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
544 let name_of_int_extract = function
545 (* XXX As an enhancement we should allow users to
546 * specify that a field length can fit into a char/int/int32
547 * (of course, this would have to be checked at runtime).
549 | (Bitmatch.BigEndian, false) -> "extract_int64_be_unsigned"
550 | (Bitmatch.BigEndian, true) -> "extract_int64_be_signed"
551 | (Bitmatch.LittleEndian, false) -> "extract_int64_le_unsigned"
552 | (Bitmatch.LittleEndian, true) -> "extract_int64_le_signed"
553 | (Bitmatch.NativeEndian, false) -> "extract_int64_ne_unsigned"
554 | (Bitmatch.NativeEndian, true) -> "extract_int64_ne_signed"
558 match t, flen_is_const with
559 (* Common case: int field, constant flen *)
560 | Int, Some i when i > 0 && i <= 64 ->
561 let extract_func = name_of_int_extract_const (i,endian,signed) in
562 let v = gensym "val" in
564 if $lid:len$ >= $flen$ then (
565 let $lid:v$, $lid:off$, $lid:len$ =
566 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
568 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
573 Loc.raise _loc (Failure "length of int field must be [1..64]")
575 (* Int field, non-const flen. We have to test the range of
576 * the field at runtime. If outside the range it's a no-match
580 let extract_func = name_of_int_extract (endian,signed) in
581 let v = gensym "val" in
583 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
584 let $lid:v$, $lid:off$, $lid:len$ =
585 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
587 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
591 (* String, constant flen > 0. *)
592 | String, Some i when i > 0 && i land 7 = 0 ->
593 let bs = gensym "bs" in
595 if $lid:len$ >= $flen$ then (
596 let $lid:bs$, $lid:off$, $lid:len$ =
597 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
599 match Bitmatch.string_of_bitstring $lid:bs$ with
600 | $fpatt$ when true -> $inner$
605 (* String, constant flen = -1, means consume all the
608 | String, Some i when i = -1 ->
609 let bs = gensym "bs" in
611 let $lid:bs$, $lid:off$, $lid:len$ =
612 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
613 match Bitmatch.string_of_bitstring $lid:bs$ with
614 | $fpatt$ when true -> $inner$
619 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
621 (* String field, non-const flen. We check the flen is > 0
622 * and a multiple of 8 (-1 is not allowed here), at runtime.
625 let bs = gensym "bs" in
627 if $flen$ >= 0 && $flen$ <= $lid:len$
628 && $flen$ land 7 = 0 then (
629 let $lid:bs$, $lid:off$, $lid:len$ =
630 Bitmatch.extract_bitstring
631 $lid:data$ $lid:off$ $lid:len$ $flen$ in
632 match Bitmatch.string_of_bitstring $lid:bs$ with
633 | $fpatt$ when true -> $inner$
638 (* Bitstring, constant flen >= 0.
639 * At the moment all we can do is assign the bitstring to an
642 | Bitstring, Some i when i >= 0 ->
645 | <:patt< $lid:ident$ >> -> ident
646 | <:patt< _ >> -> "_"
649 (Failure "cannot compare a bitstring to a constant") in
651 if $lid:len$ >= $flen$ then (
652 let $lid:ident$, $lid:off$, $lid:len$ =
653 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
659 (* Bitstring, constant flen = -1, means consume all the
662 | Bitstring, Some i when i = -1 ->
665 | <:patt< $lid:ident$ >> -> ident
666 | <:patt< _ >> -> "_"
669 (Failure "cannot compare a bitstring to a constant") in
671 let $lid:ident$, $lid:off$, $lid:len$ =
672 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
676 | Bitstring, Some _ ->
677 Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
679 (* Bitstring field, non-const flen. We check the flen is >= 0
680 * (-1 is not allowed here) at runtime.
685 | <:patt< $lid:ident$ >> -> ident
686 | <:patt< _ >> -> "_"
689 (Failure "cannot compare a bitstring to a constant") in
691 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
692 let $lid:ident$, $lid:off$, $lid:len$ =
693 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
700 (* Emit extra debugging code. *)
702 if not debug then expr else (
703 let field = string_of_field field in
706 if !Bitmatch.debug then (
707 Printf.eprintf "PA_BITMATCH: TEST:\n";
708 Printf.eprintf " %s\n" $str:field$;
709 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
710 (*Bitmatch.hexdump_bitstring stderr
711 ($lid:data$,$lid:off$,$lid:len$);*)
717 output_field_extraction expr fields
720 (* Convert each case in the match. *)
721 let cases = List.map (
722 fun (fields, bind, whenclause, code) ->
723 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
725 match whenclause with
727 <:expr< if $whenclause$ then $inner$ >>
733 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
737 output_field_extraction inner (List.rev fields)
740 (* Join them into a single expression.
742 * Don't do it with a normal fold_right because that leaves
743 * 'raise Exit; ()' at the end which causes a compiler warning.
744 * Hence a bit of complexity here.
746 * Note that the number of cases is always >= 1 so List.hd is safe.
748 let cases = List.rev cases in
750 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
751 (List.hd cases) (List.tl cases) in
753 (* The final code just wraps the list of cases in a
754 * try/with construct so that each case is tried in
755 * turn until one case matches (that case sets 'result'
756 * and raises 'Exit' to leave the whole statement).
757 * If result isn't set by the end then we will raise
758 * Match_failure with the location of the bitmatch
759 * statement in the original code.
761 let loc_fname = Loc.file_name _loc in
762 let loc_line = string_of_int (Loc.start_line _loc) in
763 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
766 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
767 let $lid:result$ = ref None in
771 match ! $lid:result$ with
773 | None -> raise (Match_failure ($str:loc_fname$,
774 $int:loc_line$, $int:loc_char$))
781 [ LIST0 [ q = LIDENT -> q ] SEP "," ]
784 (* Field used in the bitmatch operator (a pattern). *)
786 [ fpatt = patt; ":"; len = expr LEVEL "top";
787 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
788 parse_field _loc fpatt len qs patt_printer
792 (* Case inside bitmatch operator. *)
795 fields = LIST0 patt_field SEP ";";
797 bind = OPT [ "as"; name = LIDENT -> name ];
798 whenclause = OPT [ "when"; e = expr -> e ]; "->";
800 (fields, bind, whenclause, code)
804 (* Field used in the BITSTRING constructor (an expression). *)
806 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
807 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
808 parse_field _loc fexpr len qs expr_printer
812 (* 'bitmatch' expressions. *)
815 bs = expr; "with"; OPT "|";
816 cases = LIST1 match_case SEP "|" ->
817 output_bitmatch _loc bs cases
821 | [ "BITSTRING"; "{";
822 fields = LIST0 constr_field SEP ";";
824 output_constructor _loc fields