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
29 (* If this is true then we emit some debugging code which can
30 * be useful to tell what is happening during matches. You
31 * also need to do 'Bitmatch.debug := true' in your main program.
33 * If this is false then no extra debugging code is emitted.
37 (* Work out if an expression is an integer constant.
39 * Returns [Some i] if so (where i is the integer value), else [None].
41 * Fairly simplistic algorithm: we can only detect simple constant
42 * expressions such as [k], [k+c], [k-c] etc.
44 let rec expr_is_constant = function
45 | <:expr< $int:i$ >> -> (* Literal integer constant. *)
46 Some (int_of_string i)
47 | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
48 (match expr_is_constant a, expr_is_constant b with
49 | Some a, Some b -> Some (a+b)
51 | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
52 (match expr_is_constant a, expr_is_constant b with
53 | Some a, Some b -> Some (a-b)
55 | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
56 (match expr_is_constant a, expr_is_constant b with
57 | Some a, Some b -> Some (a*b)
59 | <:expr< $a$ / $b$ >> -> (* Division. *)
60 (match expr_is_constant a, expr_is_constant b with
61 | Some a, Some b -> Some (a/b)
63 | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
64 (match expr_is_constant a, expr_is_constant b with
65 | Some a, Some b -> Some (a lsl b)
67 | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
68 (match expr_is_constant a, expr_is_constant b with
69 | Some a, Some b -> Some (a lsr b)
71 | _ -> None (* Anything else is not constant. *)
73 (* Field. In bitmatch (patterns) the type is [patt field]. In
74 * BITSTRING (constructor) the type is [expr field].
77 field : 'a; (* field ('a is either patt or expr) *)
78 flen : expr; (* length in bits, may be non-const *)
79 endian : endian_expr; (* endianness *)
80 signed : bool; (* true if signed, false if unsigned *)
82 _loc : Loc.t; (* location in source code *)
83 printer : 'a -> string; (* turn the field into a string *)
85 and t = Int | String | Bitstring (* field type *)
87 | ConstantEndian of endian (* a constant little/big/nativeendian *)
88 | EndianExpr of expr (* an endian expression *)
90 (* Generate a fresh, unique symbol each time called. *)
95 sprintf "__pabitmatch_%s_%d" name i
97 (* Deal with the qualifiers which appear for a field of both types. *)
98 let parse_field _loc field flen qs printer =
99 let endian, signed, t =
101 | None -> (None, None, None)
104 fun (endian, signed, t) qual_expr ->
106 | "bigendian", None ->
107 if endian <> None then
108 Loc.raise _loc (Failure "an endian flag has been set already")
110 let endian = Some (ConstantEndian BigEndian) in
113 | "littleendian", None ->
114 if endian <> None then
115 Loc.raise _loc (Failure "an endian flag has been set already")
117 let endian = Some (ConstantEndian LittleEndian) in
120 | "nativeendian", None ->
121 if endian <> None then
122 Loc.raise _loc (Failure "an endian flag has been set already")
124 let endian = Some (ConstantEndian NativeEndian) in
127 | "endian", Some expr ->
128 if endian <> None then
129 Loc.raise _loc (Failure "an endian flag has been set already")
131 let endian = Some (EndianExpr expr) in
135 if signed <> None then
136 Loc.raise _loc (Failure "a signed flag has been set already")
138 let signed = Some true in
141 | "unsigned", None ->
142 if signed <> None then
143 Loc.raise _loc (Failure "a signed flag has been set already")
145 let signed = Some false in
150 Loc.raise _loc (Failure "a type flag has been set already")
157 Loc.raise _loc (Failure "a type flag has been set already")
159 let t = Some String in
162 | "bitstring", None ->
164 Loc.raise _loc (Failure "a type flag has been set already")
166 let t = Some Bitstring in
170 Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should not be followed by an expression"))
172 Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should be followed by an expression"))
173 ) (None, None, None) qs in
175 (* If type is set to string or bitstring then endianness and
176 * signedness qualifiers are meaningless and must not be set.
178 if (t = Some Bitstring || t = Some String)
179 && (endian <> None || signed <> None) then
181 Failure "string types and endian or signed qualifiers cannot be mixed"
184 (* Default endianness, signedness, type. *)
186 match endian with None -> ConstantEndian 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
200 let string_of_t = function
203 | Bitstring -> "bitstring"
205 let patt_printer = function
206 | <:patt< $lid:id$ >> -> id
209 let expr_printer = function
210 | <:expr< $lid:id$ >> -> id
211 | _ -> "[expression]"
213 let string_of_field { field = field; flen = flen;
214 endian = endian; signed = signed; t = t;
218 match expr_is_constant flen with
219 | Some i -> string_of_int i
220 | None -> "[non-const-len]" in
223 | ConstantEndian endian -> string_of_endian endian
224 | EndianExpr _ -> "endian [expr]" in
225 let signed = if signed then "signed" else "unsigned" in
226 let t = string_of_t t in
227 let loc_fname = Loc.file_name _loc in
228 let loc_line = Loc.start_line _loc in
229 let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
231 sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)"
232 (printer field) flen t endian signed loc_fname loc_line loc_char
234 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
235 let output_constructor _loc fields =
236 let loc_fname = Loc.file_name _loc in
237 let loc_line = string_of_int (Loc.start_line _loc) in
238 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
240 (* Bitstrings are created like the 'Buffer' module (in fact, using
241 * the Buffer module), by appending snippets to a growing buffer.
242 * This is reasonably efficient and avoids a lot of garbage.
244 let buffer = gensym "buffer" in
246 (* General exception which is raised inside the constructor functions
247 * when an int expression is out of range at runtime.
249 let exn = gensym "exn" in
250 let exn_used = ref false in
252 (* Convert each field to a simple bitstring-generating expression. *)
253 let fields = List.map (
254 fun {field=fexpr; flen=flen; endian=endian; signed=signed;
256 (* Is flen an integer constant? If so, what is it? This
257 * is very simple-minded and only detects simple constants.
259 let flen_is_const = expr_is_constant flen in
261 (* Choose the right constructor function. *)
262 let int_construct_const = function
263 (* XXX The meaning of signed/unsigned breaks down at
264 * 31, 32, 63 and 64 bits.
267 <:expr<Bitmatch.construct_bit>>
268 | ((2|3|4|5|6|7|8), _, false) ->
269 <:expr<Bitmatch.construct_char_unsigned>>
270 | ((2|3|4|5|6|7|8), _, true) ->
271 <:expr<Bitmatch.construct_char_signed>>
272 | (i, ConstantEndian BigEndian, false) when i <= 31 ->
273 <:expr<Bitmatch.construct_int_be_unsigned>>
274 | (i, ConstantEndian BigEndian, true) when i <= 31 ->
275 <:expr<Bitmatch.construct_int_be_signed>>
276 | (i, ConstantEndian LittleEndian, false) when i <= 31 ->
277 <:expr<Bitmatch.construct_int_le_unsigned>>
278 | (i, ConstantEndian LittleEndian, true) when i <= 31 ->
279 <:expr<Bitmatch.construct_int_le_signed>>
280 | (i, ConstantEndian NativeEndian, false) when i <= 31 ->
281 <:expr<Bitmatch.construct_int_ne_unsigned>>
282 | (i, ConstantEndian NativeEndian, true) when i <= 31 ->
283 <:expr<Bitmatch.construct_int_ne_signed>>
284 | (i, EndianExpr expr, false) when i <= 31 ->
285 <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
286 | (i, EndianExpr expr, true) when i <= 31 ->
287 <:expr<Bitmatch.construct_int_ee_signed $expr$>>
288 | (32, ConstantEndian BigEndian, false) ->
289 <:expr<Bitmatch.construct_int32_be_unsigned>>
290 | (32, ConstantEndian BigEndian, true) ->
291 <:expr<Bitmatch.construct_int32_be_signed>>
292 | (32, ConstantEndian LittleEndian, false) ->
293 <:expr<Bitmatch.construct_int32_le_unsigned>>
294 | (32, ConstantEndian LittleEndian, true) ->
295 <:expr<Bitmatch.construct_int32_le_signed>>
296 | (32, ConstantEndian NativeEndian, false) ->
297 <:expr<Bitmatch.construct_int32_ne_unsigned>>
298 | (32, ConstantEndian NativeEndian, true) ->
299 <:expr<Bitmatch.construct_int32_ne_signed>>
300 | (32, EndianExpr expr, false) ->
301 <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
302 | (32, EndianExpr expr, true) ->
303 <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
304 | (_, ConstantEndian BigEndian, false) ->
305 <:expr<Bitmatch.construct_int64_be_unsigned>>
306 | (_, ConstantEndian BigEndian, true) ->
307 <:expr<Bitmatch.construct_int64_be_signed>>
308 | (_, ConstantEndian LittleEndian, false) ->
309 <:expr<Bitmatch.construct_int64_le_unsigned>>
310 | (_, ConstantEndian LittleEndian, true) ->
311 <:expr<Bitmatch.construct_int64_le_signed>>
312 | (_, ConstantEndian NativeEndian, false) ->
313 <:expr<Bitmatch.construct_int64_ne_unsigned>>
314 | (_, ConstantEndian NativeEndian, true) ->
315 <:expr<Bitmatch.construct_int64_ne_signed>>
316 | (_, EndianExpr expr, false) ->
317 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
318 | (_, EndianExpr expr, true) ->
319 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
321 let int_construct = function
322 | (ConstantEndian BigEndian, false) ->
323 <:expr<Bitmatch.construct_int64_be_unsigned>>
324 | (ConstantEndian BigEndian, true) ->
325 <:expr<Bitmatch.construct_int64_be_signed>>
326 | (ConstantEndian LittleEndian, false) ->
327 <:expr<Bitmatch.construct_int64_le_unsigned>>
328 | (ConstantEndian LittleEndian, true) ->
329 <:expr<Bitmatch.construct_int64_le_signed>>
330 | (ConstantEndian NativeEndian, false) ->
331 <:expr<Bitmatch.construct_int64_ne_unsigned>>
332 | (ConstantEndian NativeEndian, true) ->
333 <:expr<Bitmatch.construct_int64_ne_signed>>
334 | (EndianExpr expr, false) ->
335 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
336 | (EndianExpr expr, true) ->
337 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
341 match t, flen_is_const with
342 (* Common case: int field, constant flen.
344 * Range checks are done inside the construction function
345 * because that's a lot simpler w.r.t. types. It might
346 * be better to move them here. XXX
348 | Int, Some i when i > 0 && i <= 64 ->
349 let construct_fn = int_construct_const (i,endian,signed) in
353 $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
357 Loc.raise _loc (Failure "length of int field must be [1..64]")
359 (* Int field, non-constant length. We need to perform a runtime
360 * test to ensure the length is [1..64].
362 * Range checks are done inside the construction function
363 * because that's a lot simpler w.r.t. types. It might
364 * be better to move them here. XXX
367 let construct_fn = int_construct (endian,signed) in
371 if $flen$ >= 1 && $flen$ <= 64 then
372 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
374 raise (Bitmatch.Construct_failure
375 ("length of int field must be [1..64]",
377 $int:loc_line$, $int:loc_char$))
380 (* String, constant length > 0, must be a multiple of 8. *)
381 | String, Some i when i > 0 && i land 7 = 0 ->
382 let bs = gensym "bs" in
385 let $lid:bs$ = $fexpr$ in
386 if String.length $lid:bs$ = $`int:j$ then
387 Bitmatch.construct_string $lid:buffer$ $lid:bs$
389 raise (Bitmatch.Construct_failure
390 ("length of string does not match declaration",
392 $int:loc_line$, $int:loc_char$))
395 (* String, constant length -1, means variable length string
398 | String, Some (-1) ->
399 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
401 (* String, constant length = 0 is probably an error, and so is
405 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
407 (* String, non-constant length.
408 * We check at runtime that the length is > 0, a multiple of 8,
409 * and matches the declared length.
412 let bslen = gensym "bslen" in
413 let bs = gensym "bs" in
415 let $lid:bslen$ = $flen$ in
416 if $lid:bslen$ > 0 then (
417 if $lid:bslen$ land 7 = 0 then (
418 let $lid:bs$ = $fexpr$ in
419 if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
420 Bitmatch.construct_string $lid:buffer$ $lid:bs$
422 raise (Bitmatch.Construct_failure
423 ("length of string does not match declaration",
425 $int:loc_line$, $int:loc_char$))
427 raise (Bitmatch.Construct_failure
428 ("length of string must be a multiple of 8",
430 $int:loc_line$, $int:loc_char$))
432 raise (Bitmatch.Construct_failure
433 ("length of string must be > 0",
435 $int:loc_line$, $int:loc_char$))
438 (* Bitstring, constant length > 0. *)
439 | Bitstring, Some i when i > 0 ->
440 let bs = gensym "bs" in
442 let $lid:bs$ = $fexpr$ in
443 if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
444 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
446 raise (Bitmatch.Construct_failure
447 ("length of bitstring does not match declaration",
449 $int:loc_line$, $int:loc_char$))
452 (* Bitstring, constant length -1, means variable length bitstring
455 | Bitstring, Some (-1) ->
456 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
458 (* Bitstring, constant length = 0 is probably an error, and so is
461 | Bitstring, Some _ ->
464 "length of bitstring must be > 0 or the special value -1")
466 (* Bitstring, non-constant length.
467 * We check at runtime that the length is > 0 and matches
468 * the declared length.
471 let bslen = gensym "bslen" in
472 let bs = gensym "bs" in
474 let $lid:bslen$ = $flen$ in
475 if $lid:bslen$ > 0 then (
476 let $lid:bs$ = $fexpr$ in
477 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
478 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
480 raise (Bitmatch.Construct_failure
481 ("length of bitstring does not match declaration",
483 $int:loc_line$, $int:loc_char$))
485 raise (Bitmatch.Construct_failure
486 ("length of bitstring must be > 0",
488 $int:loc_line$, $int:loc_char$))
493 (* Create the final bitstring. Start by creating an empty buffer
494 * and then evaluate each expression above in turn which will
495 * append some more to the bitstring buffer. Finally extract
498 * XXX We almost have enough information to be able to guess
499 * a good initial size for the buffer.
503 | [] -> <:expr< [] >>
504 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
508 let $lid:buffer$ = Bitmatch.Buffer.create () in
510 Bitmatch.Buffer.contents $lid:buffer$
516 Bitmatch.Construct_failure ("value out of range",
518 $int:loc_line$, $int:loc_char$) in
524 (* Generate the code for a bitmatch statement. '_loc' is the
525 * location, 'bs' is the bitstring parameter, 'cases' are
526 * the list of cases to test against.
528 let output_bitmatch _loc bs cases =
529 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
530 let result = gensym "result" in
532 (* This generates the field extraction code for each
533 * field a single case. Each field must be wider than
534 * the minimum permitted for the type and there must be
535 * enough remaining data in the bitstring to satisfy it.
536 * As we go through the fields, symbols 'data', 'off' and 'len'
537 * track our position and remaining length in the bitstring.
539 * The whole thing is a lot of nested 'if' statements. Code
540 * is generated from the inner-most (last) field outwards.
542 let rec output_field_extraction inner = function
545 let {field=fpatt; flen=flen; endian=endian; signed=signed;
549 (* Is flen an integer constant? If so, what is it? This
550 * is very simple-minded and only detects simple constants.
552 let flen_is_const = expr_is_constant flen in
554 let int_extract_const = function
555 (* XXX The meaning of signed/unsigned breaks down at
556 * 31, 32, 63 and 64 bits.
559 <:expr<Bitmatch.extract_bit>>
560 | ((2|3|4|5|6|7|8), _, false) ->
561 <:expr<Bitmatch.extract_char_unsigned>>
562 | ((2|3|4|5|6|7|8), _, true) ->
563 <:expr<Bitmatch.extract_char_signed>>
564 | (i, ConstantEndian BigEndian, false) when i <= 31 ->
565 <:expr<Bitmatch.extract_int_be_unsigned>>
566 | (i, ConstantEndian BigEndian, true) when i <= 31 ->
567 <:expr<Bitmatch.extract_int_be_signed>>
568 | (i, ConstantEndian LittleEndian, false) when i <= 31 ->
569 <:expr<Bitmatch.extract_int_le_unsigned>>
570 | (i, ConstantEndian LittleEndian, true) when i <= 31 ->
571 <:expr<Bitmatch.extract_int_le_signed>>
572 | (i, ConstantEndian NativeEndian, false) when i <= 31 ->
573 <:expr<Bitmatch.extract_int_ne_unsigned>>
574 | (i, ConstantEndian NativeEndian, true) when i <= 31 ->
575 <:expr<Bitmatch.extract_int_ne_signed>>
576 | (i, EndianExpr expr, false) when i <= 31 ->
577 <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
578 | (i, EndianExpr expr, true) when i <= 31 ->
579 <:expr<Bitmatch.extract_int_ee_signed $expr$>>
580 | (32, ConstantEndian BigEndian, false) ->
581 <:expr<Bitmatch.extract_int32_be_unsigned>>
582 | (32, ConstantEndian BigEndian, true) ->
583 <:expr<Bitmatch.extract_int32_be_signed>>
584 | (32, ConstantEndian LittleEndian, false) ->
585 <:expr<Bitmatch.extract_int32_le_unsigned>>
586 | (32, ConstantEndian LittleEndian, true) ->
587 <:expr<Bitmatch.extract_int32_le_signed>>
588 | (32, ConstantEndian NativeEndian, false) ->
589 <:expr<Bitmatch.extract_int32_ne_unsigned>>
590 | (32, ConstantEndian NativeEndian, true) ->
591 <:expr<Bitmatch.extract_int32_ne_signed>>
592 | (32, EndianExpr expr, false) ->
593 <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
594 | (32, EndianExpr expr, true) ->
595 <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
596 | (_, ConstantEndian BigEndian, false) ->
597 <:expr<Bitmatch.extract_int64_be_unsigned>>
598 | (_, ConstantEndian BigEndian, true) ->
599 <:expr<Bitmatch.extract_int64_be_signed>>
600 | (_, ConstantEndian LittleEndian, false) ->
601 <:expr<Bitmatch.extract_int64_le_unsigned>>
602 | (_, ConstantEndian LittleEndian, true) ->
603 <:expr<Bitmatch.extract_int64_le_signed>>
604 | (_, ConstantEndian NativeEndian, false) ->
605 <:expr<Bitmatch.extract_int64_ne_unsigned>>
606 | (_, ConstantEndian NativeEndian, true) ->
607 <:expr<Bitmatch.extract_int64_ne_signed>>
608 | (_, EndianExpr expr, false) ->
609 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
610 | (_, EndianExpr expr, true) ->
611 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
613 let int_extract = function
614 | (ConstantEndian BigEndian, false) ->
615 <:expr<Bitmatch.extract_int64_be_unsigned>>
616 | (ConstantEndian BigEndian, true) ->
617 <:expr<Bitmatch.extract_int64_be_signed>>
618 | (ConstantEndian LittleEndian, false) ->
619 <:expr<Bitmatch.extract_int64_le_unsigned>>
620 | (ConstantEndian LittleEndian, true) ->
621 <:expr<Bitmatch.extract_int64_le_signed>>
622 | (ConstantEndian NativeEndian, false) ->
623 <:expr<Bitmatch.extract_int64_ne_unsigned>>
624 | (ConstantEndian NativeEndian, true) ->
625 <:expr<Bitmatch.extract_int64_ne_signed>>
626 | (EndianExpr expr, false) ->
627 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
628 | (EndianExpr expr, true) ->
629 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
633 match t, flen_is_const with
634 (* Common case: int field, constant flen *)
635 | Int, Some i when i > 0 && i <= 64 ->
636 let extract_fn = int_extract_const (i,endian,signed) in
637 let v = gensym "val" in
639 if $lid:len$ >= $`int:i$ then (
640 let $lid:v$, $lid:off$, $lid:len$ =
641 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
642 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
647 Loc.raise _loc (Failure "length of int field must be [1..64]")
649 (* Int field, non-const flen. We have to test the range of
650 * the field at runtime. If outside the range it's a no-match
654 let extract_fn = int_extract (endian,signed) in
655 let v = gensym "val" in
657 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
658 let $lid:v$, $lid:off$, $lid:len$ =
659 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
660 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
664 (* String, constant flen > 0. *)
665 | String, Some i when i > 0 && i land 7 = 0 ->
666 let bs = gensym "bs" in
668 if $lid:len$ >= $`int:i$ then (
669 let $lid:bs$, $lid:off$, $lid:len$ =
670 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
672 match Bitmatch.string_of_bitstring $lid:bs$ with
673 | $fpatt$ when true -> $inner$
678 (* String, constant flen = -1, means consume all the
681 | String, Some i when i = -1 ->
682 let bs = gensym "bs" in
684 let $lid:bs$, $lid:off$, $lid:len$ =
685 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
686 match Bitmatch.string_of_bitstring $lid:bs$ with
687 | $fpatt$ when true -> $inner$
692 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
694 (* String field, non-const flen. We check the flen is > 0
695 * and a multiple of 8 (-1 is not allowed here), at runtime.
698 let bs = gensym "bs" in
700 if $flen$ >= 0 && $flen$ <= $lid:len$
701 && $flen$ land 7 = 0 then (
702 let $lid:bs$, $lid:off$, $lid:len$ =
703 Bitmatch.extract_bitstring
704 $lid:data$ $lid:off$ $lid:len$ $flen$ in
705 match Bitmatch.string_of_bitstring $lid:bs$ with
706 | $fpatt$ when true -> $inner$
711 (* Bitstring, constant flen >= 0.
712 * At the moment all we can do is assign the bitstring to an
715 | Bitstring, Some i when i >= 0 ->
718 | <:patt< $lid:ident$ >> -> ident
719 | <:patt< _ >> -> "_"
722 (Failure "cannot compare a bitstring to a constant") in
724 if $lid:len$ >= $`int:i$ then (
725 let $lid:ident$, $lid:off$, $lid:len$ =
726 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
732 (* Bitstring, constant flen = -1, means consume all the
735 | Bitstring, Some i when i = -1 ->
738 | <:patt< $lid:ident$ >> -> ident
739 | <:patt< _ >> -> "_"
742 (Failure "cannot compare a bitstring to a constant") in
744 let $lid:ident$, $lid:off$, $lid:len$ =
745 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
749 | Bitstring, Some _ ->
750 Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
752 (* Bitstring field, non-const flen. We check the flen is >= 0
753 * (-1 is not allowed here) at runtime.
758 | <:patt< $lid:ident$ >> -> ident
759 | <:patt< _ >> -> "_"
762 (Failure "cannot compare a bitstring to a constant") in
764 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
765 let $lid:ident$, $lid:off$, $lid:len$ =
766 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
773 (* Emit extra debugging code. *)
775 if not debug then expr else (
776 let field = string_of_field field in
779 if !Bitmatch.debug then (
780 Printf.eprintf "PA_BITMATCH: TEST:\n";
781 Printf.eprintf " %s\n" $str:field$;
782 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
783 (*Bitmatch.hexdump_bitstring stderr
784 ($lid:data$,$lid:off$,$lid:len$);*)
790 output_field_extraction expr fields
793 (* Convert each case in the match. *)
794 let cases = List.map (
795 fun (fields, bind, whenclause, code) ->
796 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
798 match whenclause with
800 <:expr< if $whenclause$ then $inner$ >>
806 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
810 output_field_extraction inner (List.rev fields)
813 (* Join them into a single expression.
815 * Don't do it with a normal fold_right because that leaves
816 * 'raise Exit; ()' at the end which causes a compiler warning.
817 * Hence a bit of complexity here.
819 * Note that the number of cases is always >= 1 so List.hd is safe.
821 let cases = List.rev cases in
823 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
824 (List.hd cases) (List.tl cases) in
826 (* The final code just wraps the list of cases in a
827 * try/with construct so that each case is tried in
828 * turn until one case matches (that case sets 'result'
829 * and raises 'Exit' to leave the whole statement).
830 * If result isn't set by the end then we will raise
831 * Match_failure with the location of the bitmatch
832 * statement in the original code.
834 let loc_fname = Loc.file_name _loc in
835 let loc_line = string_of_int (Loc.start_line _loc) in
836 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
839 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
840 let $lid:result$ = ref None in
844 match ! $lid:result$ with
846 | None -> raise (Match_failure ($str:loc_fname$,
847 $int:loc_line$, $int:loc_char$))
853 (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
854 * followed by an optional expression (used in certain cases). Note
855 * that we are careful not to declare any explicit reserved words.
860 e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
864 (* Field used in the bitmatch operator (a pattern). *)
866 [ fpatt = patt; ":"; len = expr LEVEL "top";
867 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
868 parse_field _loc fpatt len qs patt_printer
872 (* Case inside bitmatch operator. *)
875 fields = LIST0 patt_field SEP ";";
877 bind = OPT [ "as"; name = LIDENT -> name ];
878 whenclause = OPT [ "when"; e = expr -> e ]; "->";
880 (fields, bind, whenclause, code)
884 (* Field used in the BITSTRING constructor (an expression). *)
886 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
887 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
888 parse_field _loc fexpr len qs expr_printer
892 (* 'bitmatch' expressions. *)
895 bs = expr; "with"; OPT "|";
896 cases = LIST1 match_case SEP "|" ->
897 output_bitmatch _loc bs cases
901 | [ "BITSTRING"; "{";
902 fields = LIST0 constr_field SEP ";";
904 output_constructor _loc fields