1 (* Bitmatch syntax extension.
2 * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public
6 * License as published by the Free Software Foundation; either
7 * version 2 of the License, or (at your option) any later version.
9 * This library is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
28 module P = Bitmatch_persistent
30 (* If this is true then we emit some debugging code which can
31 * be useful to tell what is happening during matches. You
32 * also need to do 'Bitmatch.debug := true' in your main program.
34 * If this is false then no extra debugging code is emitted.
38 (* Hashtable storing named persistent patterns. *)
39 let pattern_hash : (string, P.pattern) Hashtbl.t = Hashtbl.create 13
41 (* Work out if an expression is an integer constant.
43 * Returns [Some i] if so (where i is the integer value), else [None].
45 * Fairly simplistic algorithm: we can only detect simple constant
46 * expressions such as [k], [k+c], [k-c] etc.
48 let rec expr_is_constant = function
49 | <:expr< $int:i$ >> -> (* Literal integer constant. *)
50 Some (int_of_string i)
51 | <:expr< $a$ + $b$ >> -> (* Addition of constants. *)
52 (match expr_is_constant a, expr_is_constant b with
53 | Some a, Some b -> Some (a+b)
55 | <:expr< $a$ - $b$ >> -> (* Subtraction. *)
56 (match expr_is_constant a, expr_is_constant b with
57 | Some a, Some b -> Some (a-b)
59 | <:expr< $a$ * $b$ >> -> (* Multiplication. *)
60 (match expr_is_constant a, expr_is_constant b with
61 | Some a, Some b -> Some (a*b)
63 | <:expr< $a$ / $b$ >> -> (* Division. *)
64 (match expr_is_constant a, expr_is_constant b with
65 | Some a, Some b -> Some (a/b)
67 | <:expr< $a$ lsl $b$ >> -> (* Shift left. *)
68 (match expr_is_constant a, expr_is_constant b with
69 | Some a, Some b -> Some (a lsl b)
71 | <:expr< $a$ lsr $b$ >> -> (* Shift right. *)
72 (match expr_is_constant a, expr_is_constant b with
73 | Some a, Some b -> Some (a lsr b)
75 | _ -> None (* Anything else is not constant. *)
77 (* Generate a fresh, unique symbol each time called. *)
82 sprintf "__pabitmatch_%s_%d" name i
84 (* Deal with the qualifiers which appear for a field of both types. *)
85 let parse_field _loc field qs =
86 let endian_set, signed_set, type_set, field =
88 | None -> (false, false, false, field)
91 fun (endian_set, signed_set, type_set, field) qual_expr ->
93 | "bigendian", None ->
95 Loc.raise _loc (Failure "an endian flag has been set already")
97 let field = P.set_endian field BigEndian in
98 (true, signed_set, type_set, field)
100 | "littleendian", None ->
102 Loc.raise _loc (Failure "an endian flag has been set already")
104 let field = P.set_endian field LittleEndian in
105 (true, signed_set, type_set, field)
107 | "nativeendian", None ->
109 Loc.raise _loc (Failure "an endian flag has been set already")
111 let field = P.set_endian field NativeEndian in
112 (true, signed_set, type_set, field)
114 | "endian", Some expr ->
116 Loc.raise _loc (Failure "an endian flag has been set already")
118 let field = P.set_endian_expr field expr in
119 (true, signed_set, type_set, field)
123 Loc.raise _loc (Failure "a signed flag has been set already")
125 let field = P.set_signed field true in
126 (endian_set, true, type_set, field)
128 | "unsigned", None ->
130 Loc.raise _loc (Failure "a signed flag has been set already")
132 let field = P.set_signed field false in
133 (endian_set, true, type_set, field)
137 Loc.raise _loc (Failure "a type flag has been set already")
139 let field = P.set_type_int field in
140 (endian_set, signed_set, true, field)
144 Loc.raise _loc (Failure "a type flag has been set already")
146 let field = P.set_type_string field in
147 (endian_set, signed_set, true, field)
149 | "bitstring", None ->
151 Loc.raise _loc (Failure "a type flag has been set already")
153 let field = P.set_type_bitstring field in
154 (endian_set, signed_set, true, field)
157 Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should not be followed by an expression"))
159 Loc.raise _loc (Failure (s ^ ": unknown qualifier, or qualifier should be followed by an expression"))
160 ) (false, false, false, field) qs in
162 (* If type is set to string or bitstring then endianness and
163 * signedness qualifiers are meaningless and must not be set.
166 let t = P.get_type field in
167 if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
169 Failure "string types and endian or signed qualifiers cannot be mixed"
172 (* Default endianness, signedness, type if not set already. *)
173 let field = if endian_set then field else P.set_endian field BigEndian in
174 let field = if signed_set then field else P.set_signed field false in
175 let field = if type_set then field else P.set_type_int field in
179 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
180 let output_constructor _loc fields =
181 let loc_fname = Loc.file_name _loc in
182 let loc_line = string_of_int (Loc.start_line _loc) in
183 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
185 (* Bitstrings are created like the 'Buffer' module (in fact, using
186 * the Buffer module), by appending snippets to a growing buffer.
187 * This is reasonably efficient and avoids a lot of garbage.
189 let buffer = gensym "buffer" in
191 (* General exception which is raised inside the constructor functions
192 * when an int expression is out of range at runtime.
194 let exn = gensym "exn" in
195 let exn_used = ref false in
197 (* Convert each field to a simple bitstring-generating expression. *)
198 let fields = List.map (
200 let fexpr = P.get_expr field in
201 let flen = P.get_length field in
202 let endian = P.get_endian field in
203 let signed = P.get_signed field in
204 let t = P.get_type field in
205 let _loc = P.get_location field in
207 (* Is flen an integer constant? If so, what is it? This
208 * is very simple-minded and only detects simple constants.
210 let flen_is_const = expr_is_constant flen in
212 (* Choose the right constructor function. *)
213 let int_construct_const = function
214 (* XXX The meaning of signed/unsigned breaks down at
215 * 31, 32, 63 and 64 bits.
218 <:expr<Bitmatch.construct_bit>>
219 | ((2|3|4|5|6|7|8), _, false) ->
220 <:expr<Bitmatch.construct_char_unsigned>>
221 | ((2|3|4|5|6|7|8), _, true) ->
222 <:expr<Bitmatch.construct_char_signed>>
223 | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
224 <:expr<Bitmatch.construct_int_be_unsigned>>
225 | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
226 <:expr<Bitmatch.construct_int_be_signed>>
227 | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
228 <:expr<Bitmatch.construct_int_le_unsigned>>
229 | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
230 <:expr<Bitmatch.construct_int_le_signed>>
231 | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
232 <:expr<Bitmatch.construct_int_ne_unsigned>>
233 | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
234 <:expr<Bitmatch.construct_int_ne_signed>>
235 | (i, P.EndianExpr expr, false) when i <= 31 ->
236 <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
237 | (i, P.EndianExpr expr, true) when i <= 31 ->
238 <:expr<Bitmatch.construct_int_ee_signed $expr$>>
239 | (32, P.ConstantEndian BigEndian, false) ->
240 <:expr<Bitmatch.construct_int32_be_unsigned>>
241 | (32, P.ConstantEndian BigEndian, true) ->
242 <:expr<Bitmatch.construct_int32_be_signed>>
243 | (32, P.ConstantEndian LittleEndian, false) ->
244 <:expr<Bitmatch.construct_int32_le_unsigned>>
245 | (32, P.ConstantEndian LittleEndian, true) ->
246 <:expr<Bitmatch.construct_int32_le_signed>>
247 | (32, P.ConstantEndian NativeEndian, false) ->
248 <:expr<Bitmatch.construct_int32_ne_unsigned>>
249 | (32, P.ConstantEndian NativeEndian, true) ->
250 <:expr<Bitmatch.construct_int32_ne_signed>>
251 | (32, P.EndianExpr expr, false) ->
252 <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
253 | (32, P.EndianExpr expr, true) ->
254 <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
255 | (_, P.ConstantEndian BigEndian, false) ->
256 <:expr<Bitmatch.construct_int64_be_unsigned>>
257 | (_, P.ConstantEndian BigEndian, true) ->
258 <:expr<Bitmatch.construct_int64_be_signed>>
259 | (_, P.ConstantEndian LittleEndian, false) ->
260 <:expr<Bitmatch.construct_int64_le_unsigned>>
261 | (_, P.ConstantEndian LittleEndian, true) ->
262 <:expr<Bitmatch.construct_int64_le_signed>>
263 | (_, P.ConstantEndian NativeEndian, false) ->
264 <:expr<Bitmatch.construct_int64_ne_unsigned>>
265 | (_, P.ConstantEndian NativeEndian, true) ->
266 <:expr<Bitmatch.construct_int64_ne_signed>>
267 | (_, P.EndianExpr expr, false) ->
268 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
269 | (_, P.EndianExpr expr, true) ->
270 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
272 let int_construct = function
273 | (P.ConstantEndian BigEndian, false) ->
274 <:expr<Bitmatch.construct_int64_be_unsigned>>
275 | (P.ConstantEndian BigEndian, true) ->
276 <:expr<Bitmatch.construct_int64_be_signed>>
277 | (P.ConstantEndian LittleEndian, false) ->
278 <:expr<Bitmatch.construct_int64_le_unsigned>>
279 | (P.ConstantEndian LittleEndian, true) ->
280 <:expr<Bitmatch.construct_int64_le_signed>>
281 | (P.ConstantEndian NativeEndian, false) ->
282 <:expr<Bitmatch.construct_int64_ne_unsigned>>
283 | (P.ConstantEndian NativeEndian, true) ->
284 <:expr<Bitmatch.construct_int64_ne_signed>>
285 | (P.EndianExpr expr, false) ->
286 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
287 | (P.EndianExpr expr, true) ->
288 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
292 match t, flen_is_const with
293 (* Common case: int field, constant flen.
295 * Range checks are done inside the construction function
296 * because that's a lot simpler w.r.t. types. It might
297 * be better to move them here. XXX
299 | P.Int, Some i when i > 0 && i <= 64 ->
300 let construct_fn = int_construct_const (i,endian,signed) in
304 $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
308 Loc.raise _loc (Failure "length of int field must be [1..64]")
310 (* Int field, non-constant length. We need to perform a runtime
311 * test to ensure the length is [1..64].
313 * Range checks are done inside the construction function
314 * because that's a lot simpler w.r.t. types. It might
315 * be better to move them here. XXX
318 let construct_fn = int_construct (endian,signed) in
322 if $flen$ >= 1 && $flen$ <= 64 then
323 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
325 raise (Bitmatch.Construct_failure
326 ("length of int field must be [1..64]",
328 $int:loc_line$, $int:loc_char$))
331 (* String, constant length > 0, must be a multiple of 8. *)
332 | P.String, Some i when i > 0 && i land 7 = 0 ->
333 let bs = gensym "bs" in
336 let $lid:bs$ = $fexpr$ in
337 if String.length $lid:bs$ = $`int:j$ then
338 Bitmatch.construct_string $lid:buffer$ $lid:bs$
340 raise (Bitmatch.Construct_failure
341 ("length of string does not match declaration",
343 $int:loc_line$, $int:loc_char$))
346 (* String, constant length -1, means variable length string
349 | P.String, Some (-1) ->
350 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
352 (* String, constant length = 0 is probably an error, and so is
355 | P.String, Some _ ->
356 Loc.raise _loc (Failure "length of string must be > 0 and a multiple of 8, or the special value -1")
358 (* String, non-constant length.
359 * We check at runtime that the length is > 0, a multiple of 8,
360 * and matches the declared length.
363 let bslen = gensym "bslen" in
364 let bs = gensym "bs" in
366 let $lid:bslen$ = $flen$ in
367 if $lid:bslen$ > 0 then (
368 if $lid:bslen$ land 7 = 0 then (
369 let $lid:bs$ = $fexpr$ in
370 if String.length $lid:bs$ = ($lid:bslen$ lsr 3) then
371 Bitmatch.construct_string $lid:buffer$ $lid:bs$
373 raise (Bitmatch.Construct_failure
374 ("length of string does not match declaration",
376 $int:loc_line$, $int:loc_char$))
378 raise (Bitmatch.Construct_failure
379 ("length of string must be a multiple of 8",
381 $int:loc_line$, $int:loc_char$))
383 raise (Bitmatch.Construct_failure
384 ("length of string must be > 0",
386 $int:loc_line$, $int:loc_char$))
389 (* Bitstring, constant length > 0. *)
390 | P.Bitstring, Some i when i > 0 ->
391 let bs = gensym "bs" in
393 let $lid:bs$ = $fexpr$ in
394 if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
395 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
397 raise (Bitmatch.Construct_failure
398 ("length of bitstring does not match declaration",
400 $int:loc_line$, $int:loc_char$))
403 (* Bitstring, constant length -1, means variable length bitstring
406 | P.Bitstring, Some (-1) ->
407 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
409 (* Bitstring, constant length = 0 is probably an error, and so is
412 | P.Bitstring, Some _ ->
415 "length of bitstring must be > 0 or the special value -1")
417 (* Bitstring, non-constant length.
418 * We check at runtime that the length is > 0 and matches
419 * the declared length.
421 | P.Bitstring, None ->
422 let bslen = gensym "bslen" in
423 let bs = gensym "bs" in
425 let $lid:bslen$ = $flen$ in
426 if $lid:bslen$ > 0 then (
427 let $lid:bs$ = $fexpr$ in
428 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
429 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
431 raise (Bitmatch.Construct_failure
432 ("length of bitstring does not match declaration",
434 $int:loc_line$, $int:loc_char$))
436 raise (Bitmatch.Construct_failure
437 ("length of bitstring must be > 0",
439 $int:loc_line$, $int:loc_char$))
444 (* Create the final bitstring. Start by creating an empty buffer
445 * and then evaluate each expression above in turn which will
446 * append some more to the bitstring buffer. Finally extract
449 * XXX We almost have enough information to be able to guess
450 * a good initial size for the buffer.
454 | [] -> <:expr< [] >>
455 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
459 let $lid:buffer$ = Bitmatch.Buffer.create () in
461 Bitmatch.Buffer.contents $lid:buffer$
467 Bitmatch.Construct_failure ("value out of range",
469 $int:loc_line$, $int:loc_char$) in
475 (* Generate the code for a bitmatch statement. '_loc' is the
476 * location, 'bs' is the bitstring parameter, 'cases' are
477 * the list of cases to test against.
479 let output_bitmatch _loc bs cases =
480 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
481 let result = gensym "result" in
483 (* This generates the field extraction code for each
484 * field a single case. Each field must be wider than
485 * the minimum permitted for the type and there must be
486 * enough remaining data in the bitstring to satisfy it.
487 * As we go through the fields, symbols 'data', 'off' and 'len'
488 * track our position and remaining length in the bitstring.
490 * The whole thing is a lot of nested 'if' statements. Code
491 * is generated from the inner-most (last) field outwards.
493 let rec output_field_extraction inner = function
496 let fpatt = P.get_patt field in
497 let flen = P.get_length field in
498 let endian = P.get_endian field in
499 let signed = P.get_signed field in
500 let t = P.get_type field in
501 let _loc = P.get_location field in
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 int_extract_const = function
509 (* XXX The meaning of signed/unsigned breaks down at
510 * 31, 32, 63 and 64 bits.
513 <:expr<Bitmatch.extract_bit>>
514 | ((2|3|4|5|6|7|8), _, false) ->
515 <:expr<Bitmatch.extract_char_unsigned>>
516 | ((2|3|4|5|6|7|8), _, true) ->
517 <:expr<Bitmatch.extract_char_signed>>
518 | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
519 <:expr<Bitmatch.extract_int_be_unsigned>>
520 | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
521 <:expr<Bitmatch.extract_int_be_signed>>
522 | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
523 <:expr<Bitmatch.extract_int_le_unsigned>>
524 | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
525 <:expr<Bitmatch.extract_int_le_signed>>
526 | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
527 <:expr<Bitmatch.extract_int_ne_unsigned>>
528 | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
529 <:expr<Bitmatch.extract_int_ne_signed>>
530 | (i, P.EndianExpr expr, false) when i <= 31 ->
531 <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
532 | (i, P.EndianExpr expr, true) when i <= 31 ->
533 <:expr<Bitmatch.extract_int_ee_signed $expr$>>
534 | (32, P.ConstantEndian BigEndian, false) ->
535 <:expr<Bitmatch.extract_int32_be_unsigned>>
536 | (32, P.ConstantEndian BigEndian, true) ->
537 <:expr<Bitmatch.extract_int32_be_signed>>
538 | (32, P.ConstantEndian LittleEndian, false) ->
539 <:expr<Bitmatch.extract_int32_le_unsigned>>
540 | (32, P.ConstantEndian LittleEndian, true) ->
541 <:expr<Bitmatch.extract_int32_le_signed>>
542 | (32, P.ConstantEndian NativeEndian, false) ->
543 <:expr<Bitmatch.extract_int32_ne_unsigned>>
544 | (32, P.ConstantEndian NativeEndian, true) ->
545 <:expr<Bitmatch.extract_int32_ne_signed>>
546 | (32, P.EndianExpr expr, false) ->
547 <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
548 | (32, P.EndianExpr expr, true) ->
549 <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
550 | (_, P.ConstantEndian BigEndian, false) ->
551 <:expr<Bitmatch.extract_int64_be_unsigned>>
552 | (_, P.ConstantEndian BigEndian, true) ->
553 <:expr<Bitmatch.extract_int64_be_signed>>
554 | (_, P.ConstantEndian LittleEndian, false) ->
555 <:expr<Bitmatch.extract_int64_le_unsigned>>
556 | (_, P.ConstantEndian LittleEndian, true) ->
557 <:expr<Bitmatch.extract_int64_le_signed>>
558 | (_, P.ConstantEndian NativeEndian, false) ->
559 <:expr<Bitmatch.extract_int64_ne_unsigned>>
560 | (_, P.ConstantEndian NativeEndian, true) ->
561 <:expr<Bitmatch.extract_int64_ne_signed>>
562 | (_, P.EndianExpr expr, false) ->
563 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
564 | (_, P.EndianExpr expr, true) ->
565 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
567 let int_extract = function
568 | (P.ConstantEndian BigEndian, false) ->
569 <:expr<Bitmatch.extract_int64_be_unsigned>>
570 | (P.ConstantEndian BigEndian, true) ->
571 <:expr<Bitmatch.extract_int64_be_signed>>
572 | (P.ConstantEndian LittleEndian, false) ->
573 <:expr<Bitmatch.extract_int64_le_unsigned>>
574 | (P.ConstantEndian LittleEndian, true) ->
575 <:expr<Bitmatch.extract_int64_le_signed>>
576 | (P.ConstantEndian NativeEndian, false) ->
577 <:expr<Bitmatch.extract_int64_ne_unsigned>>
578 | (P.ConstantEndian NativeEndian, true) ->
579 <:expr<Bitmatch.extract_int64_ne_signed>>
580 | (P.EndianExpr expr, false) ->
581 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
582 | (P.EndianExpr expr, true) ->
583 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
587 match t, flen_is_const with
588 (* Common case: int field, constant flen *)
589 | P.Int, Some i when i > 0 && i <= 64 ->
590 let extract_fn = int_extract_const (i,endian,signed) in
591 let v = gensym "val" in
593 if $lid:len$ >= $`int:i$ then (
594 let $lid:v$, $lid:off$, $lid:len$ =
595 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
596 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
601 Loc.raise _loc (Failure "length of int field must be [1..64]")
603 (* Int field, non-const flen. We have to test the range of
604 * the field at runtime. If outside the range it's a no-match
608 let extract_fn = int_extract (endian,signed) in
609 let v = gensym "val" in
611 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
612 let $lid:v$, $lid:off$, $lid:len$ =
613 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
614 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
618 (* String, constant flen > 0. *)
619 | P.String, Some i when i > 0 && i land 7 = 0 ->
620 let bs = gensym "bs" in
622 if $lid:len$ >= $`int:i$ then (
623 let $lid:bs$, $lid:off$, $lid:len$ =
624 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
626 match Bitmatch.string_of_bitstring $lid:bs$ with
627 | $fpatt$ when true -> $inner$
632 (* String, constant flen = -1, means consume all the
635 | P.String, Some i when i = -1 ->
636 let bs = gensym "bs" in
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
641 | $fpatt$ when true -> $inner$
645 | P.String, Some _ ->
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
654 if $flen$ >= 0 && $flen$ <= $lid:len$
655 && $flen$ land 7 = 0 then (
656 let $lid:bs$, $lid:off$, $lid:len$ =
657 Bitmatch.extract_bitstring
658 $lid:data$ $lid:off$ $lid:len$ $flen$ in
659 match Bitmatch.string_of_bitstring $lid:bs$ with
660 | $fpatt$ when true -> $inner$
665 (* Bitstring, constant flen >= 0.
666 * At the moment all we can do is assign the bitstring to an
669 | P.Bitstring, Some i when i >= 0 ->
672 | <:patt< $lid:ident$ >> -> ident
673 | <:patt< _ >> -> "_"
676 (Failure "cannot compare a bitstring to a constant") in
678 if $lid:len$ >= $`int:i$ then (
679 let $lid:ident$, $lid:off$, $lid:len$ =
680 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
686 (* Bitstring, constant flen = -1, means consume all the
689 | P.Bitstring, Some i when i = -1 ->
692 | <:patt< $lid:ident$ >> -> ident
693 | <:patt< _ >> -> "_"
696 (Failure "cannot compare a bitstring to a constant") in
698 let $lid:ident$, $lid:off$, $lid:len$ =
699 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
703 | P.Bitstring, Some _ ->
704 Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
706 (* Bitstring field, non-const flen. We check the flen is >= 0
707 * (-1 is not allowed here) at runtime.
709 | P.Bitstring, None ->
712 | <:patt< $lid:ident$ >> -> ident
713 | <:patt< _ >> -> "_"
716 (Failure "cannot compare a bitstring to a constant") in
718 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
719 let $lid:ident$, $lid:off$, $lid:len$ =
720 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
727 (* Emit extra debugging code. *)
729 if not debug then expr else (
730 let field = P.string_of_field field in
733 if !Bitmatch.debug then (
734 Printf.eprintf "PA_BITMATCH: TEST:\n";
735 Printf.eprintf " %s\n" $str:field$;
736 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
737 (*Bitmatch.hexdump_bitstring stderr
738 ($lid:data$,$lid:off$,$lid:len$);*)
744 output_field_extraction expr fields
747 (* Convert each case in the match. *)
748 let cases = List.map (
749 fun (fields, bind, whenclause, code) ->
750 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
752 match whenclause with
754 <:expr< if $whenclause$ then $inner$ >>
760 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
764 output_field_extraction inner (List.rev fields)
767 (* Join them into a single expression.
769 * Don't do it with a normal fold_right because that leaves
770 * 'raise Exit; ()' at the end which causes a compiler warning.
771 * Hence a bit of complexity here.
773 * Note that the number of cases is always >= 1 so List.hd is safe.
775 let cases = List.rev cases in
777 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
778 (List.hd cases) (List.tl cases) in
780 (* The final code just wraps the list of cases in a
781 * try/with construct so that each case is tried in
782 * turn until one case matches (that case sets 'result'
783 * and raises 'Exit' to leave the whole statement).
784 * If result isn't set by the end then we will raise
785 * Match_failure with the location of the bitmatch
786 * statement in the original code.
788 let loc_fname = Loc.file_name _loc in
789 let loc_line = string_of_int (Loc.start_line _loc) in
790 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
793 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
794 let $lid:result$ = ref None in
798 match ! $lid:result$ with
800 | None -> raise (Match_failure ($str:loc_fname$,
801 $int:loc_line$, $int:loc_char$))
804 (* Add a named pattern. *)
805 let add_named_pattern _loc name pattern =
806 Hashtbl.add pattern_hash name pattern
808 (* Expand a named pattern from the pattern_hash. *)
809 let expand_named_pattern _loc name =
810 try Hashtbl.find pattern_hash name
812 Loc.raise _loc (Failure (sprintf "named pattern not found: %s" name))
814 (* Add named patterns from a file. See the documentation on the
815 * directory search path in bitmatch_persistent.mli
817 let load_patterns_from_file _loc filename =
819 if Filename.is_relative filename && Filename.is_implicit filename then (
820 (* Try current directory. *)
823 (* Try OCaml library directory. *)
824 try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
825 with exn -> Loc.raise _loc exn
828 with exn -> Loc.raise _loc exn
830 let names = ref [] in
833 let name = P.named_from_channel chan in
834 names := name :: !names
837 with End_of_file -> ()
840 let names = List.rev !names in
843 | name, P.Pattern patt -> add_named_pattern _loc name patt
844 | _, P.Constructor _ -> () (* just ignore these for now *)
848 GLOBAL: expr str_item;
850 (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
851 * followed by an optional expression (used in certain cases). Note
852 * that we are careful not to declare any explicit reserved words.
857 e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
861 (* Field used in the bitmatch operator (a pattern). This can actually
862 * return multiple fields, in the case where the 'field' is a named
866 [ fpatt = patt; ":"; len = expr LEVEL "top";
867 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
868 let field = P.create_pattern_field _loc in
869 let field = P.set_patt field fpatt in
870 let field = P.set_length field len in
871 [parse_field _loc field qs] (* Normal, single field. *)
872 | ":"; name = LIDENT ->
873 expand_named_pattern _loc name (* Named -> list of fields. *)
877 (* Case inside bitmatch operator. *)
880 fields = LIST0 patt_field SEP ";";
887 [ fields = patt_fields;
888 bind = OPT [ "as"; name = LIDENT -> name ];
889 whenclause = OPT [ "when"; e = expr -> e ]; "->";
891 (fields, bind, whenclause, code)
895 (* Field used in the BITSTRING constructor (an expression). *)
897 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
898 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
899 let field = P.create_constructor_field _loc in
900 let field = P.set_expr field fexpr in
901 let field = P.set_length field len in
902 parse_field _loc field qs
908 fields = LIST0 constr_field SEP ";";
914 (* 'bitmatch' expressions. *)
917 bs = expr; "with"; OPT "|";
918 cases = LIST1 patt_case SEP "|" ->
919 output_bitmatch _loc bs cases
924 fields = constr_fields ->
925 output_constructor _loc fields
929 (* Named persistent patterns.
931 * NB: Currently only allowed at the top level. We can probably lift
932 * this restriction later if necessary. We only deal with patterns
933 * at the moment, not constructors, but the infrastructure to do
934 * constructors is in place.
936 str_item: LEVEL "top" [
938 name = LIDENT; "="; fields = patt_fields ->
939 add_named_pattern _loc name fields;
940 (* The statement disappears, but we still need a str_item so ... *)
942 | "open"; "bitmatch"; filename = STRING ->
943 load_patterns_from_file _loc filename;