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 let locfail _loc msg = Loc.raise _loc (Failure msg)
43 (* Work out if an expression is an integer constant.
45 * Returns [Some i] if so (where i is the integer value), else [None].
47 * Fairly simplistic algorithm: we can only detect simple constant
48 * expressions such as [k], [k+c], [k-c] etc.
50 let rec expr_is_constant = function
51 | <:expr< $int:i$ >> -> (* Literal integer constant. *)
52 Some (int_of_string i)
53 | <:expr< $lid:op$ $a$ $b$ >> ->
54 (match expr_is_constant a, expr_is_constant b with
55 | Some a, Some b -> (* Integer binary operations. *)
56 let ops = ["+", (+); "-", (-); "*", ( * ); "/", (/);
57 "land", (land); "lor", (lor); "lxor", (lxor);
58 "lsl", (lsl); "lsr", (lsr); "asr", (asr);
60 (try Some ((List.assoc op ops) a b) with Not_found -> None)
64 (* Generate a fresh, unique symbol each time called. *)
69 sprintf "__pabitmatch_%s_%d" name i
71 (* Deal with the qualifiers which appear for a field of both types. *)
72 let parse_field _loc field qs =
73 let fail = locfail _loc in
75 let endian_set, signed_set, type_set, offset_set, field =
77 | None -> (false, false, false, false, field)
79 let check already_set msg = if already_set then fail msg in
81 (endian_set, signed_set, type_set, offset_set, field) =
83 | "endian", Some expr ->
84 check endian_set "an endian flag has been set already";
85 let field = P.set_endian_expr field expr in
86 (true, signed_set, type_set, offset_set, field)
88 fail "qualifier 'endian' should be followed by an expression"
89 | "offset", Some expr ->
90 check offset_set "an offset has been set already";
91 let field = P.set_offset field expr in
92 (endian_set, signed_set, type_set, true, field)
94 fail "qualifier 'offset' should be followed by an expression"
96 fail (s ^ ": unknown qualifier, or qualifier should not be followed by an expression")
98 let endian_quals = ["bigendian", BigEndian;
99 "littleendian", LittleEndian;
100 "nativeendian", NativeEndian] in
101 let sign_quals = ["signed", true; "unsigned", false] in
102 let type_quals = ["int", P.set_type_int;
103 "string", P.set_type_string;
104 "bitstring", P.set_type_bitstring] in
105 if List.mem_assoc qual endian_quals then (
106 check endian_set "an endian flag has been set already";
107 let field = P.set_endian field (List.assoc qual endian_quals) in
108 (true, signed_set, type_set, offset_set, field)
109 ) else if List.mem_assoc qual sign_quals then (
110 check signed_set "a signed flag has been set already";
111 let field = P.set_signed field (List.assoc qual sign_quals) in
112 (endian_set, true, type_set, offset_set, field)
113 ) else if List.mem_assoc qual type_quals then (
114 check type_set "a type flag has been set already";
115 let field = List.assoc qual type_quals field in
116 (endian_set, signed_set, true, offset_set, field)
118 fail (qual ^ ": unknown qualifier, or qualifier should be followed by an expression") in
119 List.fold_left apply_qualifier (false, false, false, false, field) qs in
121 (* If type is set to string or bitstring then endianness and
122 * signedness qualifiers are meaningless and must not be set.
125 let t = P.get_type field in
126 if (t = P.Bitstring || t = P.String) && (endian_set || signed_set) then
127 fail "string types and endian or signed qualifiers cannot be mixed" in
129 (* Default endianness, signedness, type if not set already. *)
130 let field = if endian_set then field else P.set_endian field BigEndian in
131 let field = if signed_set then field else P.set_signed field false in
132 let field = if type_set then field else P.set_type_int field in
136 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
137 let output_constructor _loc fields =
138 let fail = locfail _loc in
140 let loc_fname = Loc.file_name _loc in
141 let loc_line = string_of_int (Loc.start_line _loc) in
142 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
144 (* Bitstrings are created like the 'Buffer' module (in fact, using
145 * the Buffer module), by appending snippets to a growing buffer.
146 * This is reasonably efficient and avoids a lot of garbage.
148 let buffer = gensym "buffer" in
150 (* General exception which is raised inside the constructor functions
151 * when an int expression is out of range at runtime.
153 let exn = gensym "exn" in
154 let exn_used = ref false in
156 (* Convert each field to a simple bitstring-generating expression. *)
157 let fields = List.map (
159 let fexpr = P.get_expr field in
160 let flen = P.get_length field in
161 let endian = P.get_endian field in
162 let signed = P.get_signed field in
163 let t = P.get_type field in
164 let _loc = P.get_location field in
165 let offset = P.get_offset field in
167 (* offset() not supported in constructors. Implementation of
168 * forward-only offsets is fairly straightforward: we would
169 * need to just calculate the length of padding here and add
170 * it to what has been constructed. For general offsets,
171 * including going backwards, that would require a rethink in
172 * how we construct bitstrings.
174 if offset <> None then
175 fail "offset expressions are not supported in BITSTRING constructors";
177 (* Is flen an integer constant? If so, what is it? This
178 * is very simple-minded and only detects simple constants.
180 let flen_is_const = expr_is_constant flen in
182 (* Choose the right constructor function. *)
183 let int_construct_const = function
184 (* XXX The meaning of signed/unsigned breaks down at
185 * 31, 32, 63 and 64 bits.
188 <:expr<Bitmatch.construct_bit>>
189 | ((2|3|4|5|6|7|8), _, false) ->
190 <:expr<Bitmatch.construct_char_unsigned>>
191 | ((2|3|4|5|6|7|8), _, true) ->
192 <:expr<Bitmatch.construct_char_signed>>
193 | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
194 <:expr<Bitmatch.construct_int_be_unsigned>>
195 | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
196 <:expr<Bitmatch.construct_int_be_signed>>
197 | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
198 <:expr<Bitmatch.construct_int_le_unsigned>>
199 | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
200 <:expr<Bitmatch.construct_int_le_signed>>
201 | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
202 <:expr<Bitmatch.construct_int_ne_unsigned>>
203 | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
204 <:expr<Bitmatch.construct_int_ne_signed>>
205 | (i, P.EndianExpr expr, false) when i <= 31 ->
206 <:expr<Bitmatch.construct_int_ee_unsigned $expr$>>
207 | (i, P.EndianExpr expr, true) when i <= 31 ->
208 <:expr<Bitmatch.construct_int_ee_signed $expr$>>
209 | (32, P.ConstantEndian BigEndian, false) ->
210 <:expr<Bitmatch.construct_int32_be_unsigned>>
211 | (32, P.ConstantEndian BigEndian, true) ->
212 <:expr<Bitmatch.construct_int32_be_signed>>
213 | (32, P.ConstantEndian LittleEndian, false) ->
214 <:expr<Bitmatch.construct_int32_le_unsigned>>
215 | (32, P.ConstantEndian LittleEndian, true) ->
216 <:expr<Bitmatch.construct_int32_le_signed>>
217 | (32, P.ConstantEndian NativeEndian, false) ->
218 <:expr<Bitmatch.construct_int32_ne_unsigned>>
219 | (32, P.ConstantEndian NativeEndian, true) ->
220 <:expr<Bitmatch.construct_int32_ne_signed>>
221 | (32, P.EndianExpr expr, false) ->
222 <:expr<Bitmatch.construct_int32_ee_unsigned $expr$>>
223 | (32, P.EndianExpr expr, true) ->
224 <:expr<Bitmatch.construct_int32_ee_signed $expr$>>
225 | (_, P.ConstantEndian BigEndian, false) ->
226 <:expr<Bitmatch.construct_int64_be_unsigned>>
227 | (_, P.ConstantEndian BigEndian, true) ->
228 <:expr<Bitmatch.construct_int64_be_signed>>
229 | (_, P.ConstantEndian LittleEndian, false) ->
230 <:expr<Bitmatch.construct_int64_le_unsigned>>
231 | (_, P.ConstantEndian LittleEndian, true) ->
232 <:expr<Bitmatch.construct_int64_le_signed>>
233 | (_, P.ConstantEndian NativeEndian, false) ->
234 <:expr<Bitmatch.construct_int64_ne_unsigned>>
235 | (_, P.ConstantEndian NativeEndian, true) ->
236 <:expr<Bitmatch.construct_int64_ne_signed>>
237 | (_, P.EndianExpr expr, false) ->
238 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
239 | (_, P.EndianExpr expr, true) ->
240 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
242 let int_construct = function
243 | (P.ConstantEndian BigEndian, false) ->
244 <:expr<Bitmatch.construct_int64_be_unsigned>>
245 | (P.ConstantEndian BigEndian, true) ->
246 <:expr<Bitmatch.construct_int64_be_signed>>
247 | (P.ConstantEndian LittleEndian, false) ->
248 <:expr<Bitmatch.construct_int64_le_unsigned>>
249 | (P.ConstantEndian LittleEndian, true) ->
250 <:expr<Bitmatch.construct_int64_le_signed>>
251 | (P.ConstantEndian NativeEndian, false) ->
252 <:expr<Bitmatch.construct_int64_ne_unsigned>>
253 | (P.ConstantEndian NativeEndian, true) ->
254 <:expr<Bitmatch.construct_int64_ne_signed>>
255 | (P.EndianExpr expr, false) ->
256 <:expr<Bitmatch.construct_int64_ee_unsigned $expr$>>
257 | (P.EndianExpr expr, true) ->
258 <:expr<Bitmatch.construct_int64_ee_signed $expr$>>
262 match t, flen_is_const with
263 (* Common case: int field, constant flen.
265 * Range checks are done inside the construction function
266 * because that's a lot simpler w.r.t. types. It might
267 * be better to move them here. XXX
269 | P.Int, Some i when i > 0 && i <= 64 ->
270 let construct_fn = int_construct_const (i,endian,signed) in
274 $construct_fn$ $lid:buffer$ $fexpr$ $`int:i$ $lid:exn$
278 fail "length of int field must be [1..64]"
280 (* Int field, non-constant length. We need to perform a runtime
281 * test to ensure the length is [1..64].
283 * Range checks are done inside the construction function
284 * because that's a lot simpler w.r.t. types. It might
285 * be better to move them here. XXX
288 let construct_fn = int_construct (endian,signed) in
292 if $flen$ >= 1 && $flen$ <= 64 then
293 $construct_fn$ $lid:buffer$ $fexpr$ $flen$ $lid:exn$
295 raise (Bitmatch.Construct_failure
296 ("length of int field must be [1..64]",
298 $int:loc_line$, $int:loc_char$))
301 (* String, constant length > 0, must be a multiple of 8. *)
302 | P.String, Some i when i > 0 && i land 7 = 0 ->
303 let bs = gensym "bs" in
306 let $lid:bs$ = $fexpr$ in
307 if String.length $lid:bs$ = $`int:j$ then
308 Bitmatch.construct_string $lid:buffer$ $lid:bs$
310 raise (Bitmatch.Construct_failure
311 ("length of string does not match declaration",
313 $int:loc_line$, $int:loc_char$))
316 (* String, constant length -1, means variable length string
319 | P.String, Some (-1) ->
320 <:expr< Bitmatch.construct_string $lid:buffer$ $fexpr$ >>
322 (* String, constant length = 0 is probably an error, and so is
325 | P.String, Some _ ->
326 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
328 (* String, non-constant length.
329 * We check at runtime that the length is > 0, a multiple of 8,
330 * and matches the declared length.
333 let bslen = gensym "bslen" in
334 let bs = gensym "bs" in
336 let $lid:bslen$ = $flen$ in
337 if $lid:bslen$ > 0 then (
338 if $lid:bslen$ land 7 = 0 then (
339 let $lid:bs$ = $fexpr$ in
340 if String.length $lid:bs$ = ($lid:bslen$ 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$))
348 raise (Bitmatch.Construct_failure
349 ("length of string must be a multiple of 8",
351 $int:loc_line$, $int:loc_char$))
353 raise (Bitmatch.Construct_failure
354 ("length of string must be > 0",
356 $int:loc_line$, $int:loc_char$))
359 (* Bitstring, constant length >= 0. *)
360 | P.Bitstring, Some i when i >= 0 ->
361 let bs = gensym "bs" in
363 let $lid:bs$ = $fexpr$ in
364 if Bitmatch.bitstring_length $lid:bs$ = $`int:i$ then
365 Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
367 raise (Bitmatch.Construct_failure
368 ("length of bitstring does not match declaration",
370 $int:loc_line$, $int:loc_char$))
373 (* Bitstring, constant length -1, means variable length bitstring
376 | P.Bitstring, Some (-1) ->
377 <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
379 (* Bitstring, constant length < -1 is an error. *)
380 | P.Bitstring, Some _ ->
381 fail "length of bitstring must be >= 0 or the special value -1"
383 (* Bitstring, non-constant length.
384 * We check at runtime that the length is >= 0 and matches
385 * the declared length.
387 | P.Bitstring, None ->
388 let bslen = gensym "bslen" in
389 let bs = gensym "bs" in
391 let $lid:bslen$ = $flen$ in
392 if $lid:bslen$ >= 0 then (
393 let $lid:bs$ = $fexpr$ in
394 if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ 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$))
402 raise (Bitmatch.Construct_failure
403 ("length of bitstring must be > 0",
405 $int:loc_line$, $int:loc_char$))
410 (* Create the final bitstring. Start by creating an empty buffer
411 * and then evaluate each expression above in turn which will
412 * append some more to the bitstring buffer. Finally extract
415 * XXX We almost have enough information to be able to guess
416 * a good initial size for the buffer.
420 | [] -> <:expr< [] >>
421 | h::t -> List.fold_left (fun h t -> <:expr< $h$; $t$ >>) h t in
425 let $lid:buffer$ = Bitmatch.Buffer.create () in
427 Bitmatch.Buffer.contents $lid:buffer$
433 Bitmatch.Construct_failure ("value out of range",
435 $int:loc_line$, $int:loc_char$) in
441 (* Generate the code for a bitmatch statement. '_loc' is the
442 * location, 'bs' is the bitstring parameter, 'cases' are
443 * the list of cases to test against.
445 let output_bitmatch _loc bs cases =
446 let fail = locfail _loc in
448 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
449 let result = gensym "result" in
451 (* This generates the field extraction code for each
452 * field in a single case. There must be enough remaining data
453 * in the bitstring to satisfy the field.
455 * As we go through the fields, symbols 'data', 'off' and 'len'
456 * track our position and remaining length in the bitstring.
458 * The whole thing is a lot of nested 'if' statements. Code
459 * is generated from the inner-most (last) field outwards.
461 let rec output_field_extraction inner = function
464 let fpatt = P.get_patt field in
465 let flen = P.get_length field in
466 let endian = P.get_endian field in
467 let signed = P.get_signed field in
468 let t = P.get_type field in
469 let _loc = P.get_location field in
470 let offset = P.get_offset field in
472 (* Is flen (field len) an integer constant? If so, what is it?
473 * This will be [Some i] if it's a constant or [None] if it's
474 * non-constant or we couldn't determine.
476 let flen_is_const = expr_is_constant flen in
478 let int_extract_const = function
479 (* XXX The meaning of signed/unsigned breaks down at
480 * 31, 32, 63 and 64 bits.
483 <:expr<Bitmatch.extract_bit>>
484 | ((2|3|4|5|6|7|8), _, false) ->
485 <:expr<Bitmatch.extract_char_unsigned>>
486 | ((2|3|4|5|6|7|8), _, true) ->
487 <:expr<Bitmatch.extract_char_signed>>
488 | (i, P.ConstantEndian BigEndian, false) when i <= 31 ->
489 <:expr<Bitmatch.extract_int_be_unsigned>>
490 | (i, P.ConstantEndian BigEndian, true) when i <= 31 ->
491 <:expr<Bitmatch.extract_int_be_signed>>
492 | (i, P.ConstantEndian LittleEndian, false) when i <= 31 ->
493 <:expr<Bitmatch.extract_int_le_unsigned>>
494 | (i, P.ConstantEndian LittleEndian, true) when i <= 31 ->
495 <:expr<Bitmatch.extract_int_le_signed>>
496 | (i, P.ConstantEndian NativeEndian, false) when i <= 31 ->
497 <:expr<Bitmatch.extract_int_ne_unsigned>>
498 | (i, P.ConstantEndian NativeEndian, true) when i <= 31 ->
499 <:expr<Bitmatch.extract_int_ne_signed>>
500 | (i, P.EndianExpr expr, false) when i <= 31 ->
501 <:expr<Bitmatch.extract_int_ee_unsigned $expr$>>
502 | (i, P.EndianExpr expr, true) when i <= 31 ->
503 <:expr<Bitmatch.extract_int_ee_signed $expr$>>
504 | (32, P.ConstantEndian BigEndian, false) ->
505 <:expr<Bitmatch.extract_int32_be_unsigned>>
506 | (32, P.ConstantEndian BigEndian, true) ->
507 <:expr<Bitmatch.extract_int32_be_signed>>
508 | (32, P.ConstantEndian LittleEndian, false) ->
509 <:expr<Bitmatch.extract_int32_le_unsigned>>
510 | (32, P.ConstantEndian LittleEndian, true) ->
511 <:expr<Bitmatch.extract_int32_le_signed>>
512 | (32, P.ConstantEndian NativeEndian, false) ->
513 <:expr<Bitmatch.extract_int32_ne_unsigned>>
514 | (32, P.ConstantEndian NativeEndian, true) ->
515 <:expr<Bitmatch.extract_int32_ne_signed>>
516 | (32, P.EndianExpr expr, false) ->
517 <:expr<Bitmatch.extract_int32_ee_unsigned $expr$>>
518 | (32, P.EndianExpr expr, true) ->
519 <:expr<Bitmatch.extract_int32_ee_signed $expr$>>
520 | (_, P.ConstantEndian BigEndian, false) ->
521 <:expr<Bitmatch.extract_int64_be_unsigned>>
522 | (_, P.ConstantEndian BigEndian, true) ->
523 <:expr<Bitmatch.extract_int64_be_signed>>
524 | (_, P.ConstantEndian LittleEndian, false) ->
525 <:expr<Bitmatch.extract_int64_le_unsigned>>
526 | (_, P.ConstantEndian LittleEndian, true) ->
527 <:expr<Bitmatch.extract_int64_le_signed>>
528 | (_, P.ConstantEndian NativeEndian, false) ->
529 <:expr<Bitmatch.extract_int64_ne_unsigned>>
530 | (_, P.ConstantEndian NativeEndian, true) ->
531 <:expr<Bitmatch.extract_int64_ne_signed>>
532 | (_, P.EndianExpr expr, false) ->
533 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
534 | (_, P.EndianExpr expr, true) ->
535 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
537 let int_extract = function
538 | (P.ConstantEndian BigEndian, false) ->
539 <:expr<Bitmatch.extract_int64_be_unsigned>>
540 | (P.ConstantEndian BigEndian, true) ->
541 <:expr<Bitmatch.extract_int64_be_signed>>
542 | (P.ConstantEndian LittleEndian, false) ->
543 <:expr<Bitmatch.extract_int64_le_unsigned>>
544 | (P.ConstantEndian LittleEndian, true) ->
545 <:expr<Bitmatch.extract_int64_le_signed>>
546 | (P.ConstantEndian NativeEndian, false) ->
547 <:expr<Bitmatch.extract_int64_ne_unsigned>>
548 | (P.ConstantEndian NativeEndian, true) ->
549 <:expr<Bitmatch.extract_int64_ne_signed>>
550 | (P.EndianExpr expr, false) ->
551 <:expr<Bitmatch.extract_int64_ee_unsigned $expr$>>
552 | (P.EndianExpr expr, true) ->
553 <:expr<Bitmatch.extract_int64_ee_signed $expr$>>
557 match t, flen_is_const with
558 (* Common case: int field, constant flen *)
559 | P.Int, Some i when i > 0 && i <= 64 ->
560 let extract_fn = int_extract_const (i,endian,signed) in
561 let v = gensym "val" in
563 if $lid:len$ >= $`int:i$ then (
564 let $lid:v$, $lid:off$, $lid:len$ =
565 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
566 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
571 fail "length of int field must be [1..64]"
573 (* Int field, non-const flen. We have to test the range of
574 * the field at runtime. If outside the range it's a no-match
578 let extract_fn = int_extract (endian,signed) in
579 let v = gensym "val" in
581 if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
582 let $lid:v$, $lid:off$, $lid:len$ =
583 $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
584 match $lid:v$ with $fpatt$ when true -> $inner$ | _ -> ()
588 (* String, constant flen > 0. *)
589 | P.String, Some i when i > 0 && i land 7 = 0 ->
590 let bs = gensym "bs" in
592 if $lid:len$ >= $`int:i$ then (
593 let $lid:bs$, $lid:off$, $lid:len$ =
594 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
596 match Bitmatch.string_of_bitstring $lid:bs$ with
597 | $fpatt$ when true -> $inner$
602 (* String, constant flen = -1, means consume all the
605 | P.String, Some i when i = -1 ->
606 let bs = gensym "bs" in
608 let $lid:bs$, $lid:off$, $lid:len$ =
609 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
610 match Bitmatch.string_of_bitstring $lid:bs$ with
611 | $fpatt$ when true -> $inner$
615 | P.String, Some _ ->
616 fail "length of string must be > 0 and a multiple of 8, or the special value -1"
618 (* String field, non-const flen. We check the flen is > 0
619 * and a multiple of 8 (-1 is not allowed here), at runtime.
622 let bs = gensym "bs" in
624 if $flen$ >= 0 && $flen$ <= $lid:len$
625 && $flen$ land 7 = 0 then (
626 let $lid:bs$, $lid:off$, $lid:len$ =
627 Bitmatch.extract_bitstring
628 $lid:data$ $lid:off$ $lid:len$ $flen$ in
629 match Bitmatch.string_of_bitstring $lid:bs$ with
630 | $fpatt$ when true -> $inner$
635 (* Bitstring, constant flen >= 0.
636 * At the moment all we can do is assign the bitstring to an
639 | P.Bitstring, Some i when i >= 0 ->
642 | <:patt< $lid:ident$ >> -> ident
643 | <:patt< _ >> -> "_"
645 fail "cannot compare a bitstring to a constant" in
647 if $lid:len$ >= $`int:i$ then (
648 let $lid:ident$, $lid:off$, $lid:len$ =
649 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
655 (* Bitstring, constant flen = -1, means consume all the
658 | P.Bitstring, Some i when i = -1 ->
661 | <:patt< $lid:ident$ >> -> ident
662 | <:patt< _ >> -> "_"
664 fail "cannot compare a bitstring to a constant" in
666 let $lid:ident$, $lid:off$, $lid:len$ =
667 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
671 | P.Bitstring, Some _ ->
672 fail "length of bitstring must be >= 0 or the special value -1"
674 (* Bitstring field, non-const flen. We check the flen is >= 0
675 * (-1 is not allowed here) at runtime.
677 | P.Bitstring, None ->
680 | <:patt< $lid:ident$ >> -> ident
681 | <:patt< _ >> -> "_"
683 fail "cannot compare a bitstring to a constant" in
685 if $flen$ >= 0 && $flen$ <= $lid:len$ then (
686 let $lid:ident$, $lid:off$, $lid:len$ =
687 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
694 (* Computed offset: only offsets forward are supported.
696 * We try hard to optimize this based on what we know. Are
697 * we at a predictable offset now? (Look at the outer 'fields'
698 * list and see if they all have constant field length starting
699 * at some constant offset). Is this offset constant?
701 * Based on this we can do a lot of the computation at
702 * compile time, or defer it to runtime only if necessary.
704 * In all cases, the off and len fields get updated.
708 | None -> expr (* common case: there was no offset expression *)
709 | Some offset_expr ->
710 (* This will be [Some i] if offset is a constant expression
711 * or [None] if it's a non-constant.
713 let requested_offset = expr_is_constant offset_expr in
715 (* This will be [Some i] if our current offset is known
716 * at compile time, or [None] if we can't determine it.
719 let has_constant_offset field =
720 match P.get_offset field with
723 match expr_is_constant expr with
727 let get_constant_offset field =
728 match P.get_offset field with
729 | None -> assert false
731 match expr_is_constant expr with
732 | None -> assert false
736 let has_constant_len field =
737 match expr_is_constant (P.get_length field) with
739 | Some i when i > 0 -> true
742 let get_constant_len field =
743 match expr_is_constant (P.get_length field) with
744 | None -> assert false
745 | Some i when i > 0 -> i
746 | Some _ -> assert false
749 let rec loop = function
750 (* first field has constant offset 0 *)
752 (* field with constant offset & length *)
754 when has_constant_offset field &&
755 has_constant_len field ->
756 Some (get_constant_offset field + get_constant_len field)
757 (* field with no offset & constant length *)
759 when P.get_offset field = None &&
760 has_constant_len field ->
761 (match loop fields with
763 | Some offset -> Some (offset + get_constant_len field))
764 (* else, can't work out the offset *)
769 (* Look at the current offset and requested offset cases and
770 * determine what code to generate.
772 match current_offset, requested_offset with
773 (* This is the good case: both the current offset and
774 * the requested offset are constant, so we can remove
775 * almost all the runtime checks.
777 | Some current_offset, Some requested_offset ->
778 let move = requested_offset - current_offset in
780 fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
781 (* Add some code to move the offset and length by a
782 * constant amount, and a runtime test that len >= 0
783 * (XXX possibly the runtime test is unnecessary?)
786 let $lid:off$ = $lid:off$ + $`int:move$ in
787 let $lid:len$ = $lid:len$ - $`int:move$ in
788 if $lid:len$ >= 0 then $expr$
790 (* In any other case, we need to use runtime checks.
792 * XXX It's not clear if a backwards move detected at runtime
793 * is merely a match failure, or a runtime error. At the
794 * moment it's just a match failure since bitmatch generally
795 * doesn't raise runtime errors.
798 let move = gensym "move" in
800 let $lid:move$ = $offset_expr$ - $lid:off$ in
801 if $lid:move$ >= 0 then (
802 let $lid:off$ = $lid:off$ + $lid:move$ in
803 let $lid:len$ = $lid:len$ - $lid:move$ in
804 if $lid:len$ >= 0 then $expr$
806 >> in (* end of computed offset code *)
808 (* Emit extra debugging code. *)
810 if not debug then expr else (
811 let field = P.string_of_pattern_field field in
814 if !Bitmatch.debug then (
815 Printf.eprintf "PA_BITMATCH: TEST:\n";
816 Printf.eprintf " %s\n" $str:field$;
817 Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
818 (*Bitmatch.hexdump_bitstring stderr
819 ($lid:data$,$lid:off$,$lid:len$);*)
825 output_field_extraction expr fields
828 (* Convert each case in the match. *)
829 let cases = List.map (
830 fun (fields, bind, whenclause, code) ->
831 let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
833 match whenclause with
835 <:expr< if $whenclause$ then $inner$ >>
841 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
845 output_field_extraction inner (List.rev fields)
848 (* Join them into a single expression.
850 * Don't do it with a normal fold_right because that leaves
851 * 'raise Exit; ()' at the end which causes a compiler warning.
852 * Hence a bit of complexity here.
854 * Note that the number of cases is always >= 1 so List.hd is safe.
856 let cases = List.rev cases in
858 List.fold_left (fun base case -> <:expr< $case$ ; $base$ >>)
859 (List.hd cases) (List.tl cases) in
861 (* The final code just wraps the list of cases in a
862 * try/with construct so that each case is tried in
863 * turn until one case matches (that case sets 'result'
864 * and raises 'Exit' to leave the whole statement).
865 * If result isn't set by the end then we will raise
866 * Match_failure with the location of the bitmatch
867 * statement in the original code.
869 let loc_fname = Loc.file_name _loc in
870 let loc_line = string_of_int (Loc.start_line _loc) in
871 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
874 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
875 let $lid:result$ = ref None in
879 match ! $lid:result$ with
881 | None -> raise (Match_failure ($str:loc_fname$,
882 $int:loc_line$, $int:loc_char$))
885 (* Add a named pattern. *)
886 let add_named_pattern _loc name pattern =
887 Hashtbl.add pattern_hash name pattern
889 (* Expand a named pattern from the pattern_hash. *)
890 let expand_named_pattern _loc name =
891 try Hashtbl.find pattern_hash name
893 locfail _loc (sprintf "named pattern not found: %s" name)
895 (* Add named patterns from a file. See the documentation on the
896 * directory search path in bitmatch_persistent.mli
898 let load_patterns_from_file _loc filename =
900 if Filename.is_relative filename && Filename.is_implicit filename then (
901 (* Try current directory. *)
904 (* Try OCaml library directory. *)
905 try open_in (Filename.concat Bitmatch_config.ocamllibdir filename)
906 with exn -> Loc.raise _loc exn
909 with exn -> Loc.raise _loc exn
911 let names = ref [] in
914 let name = P.named_from_channel chan in
915 names := name :: !names
918 with End_of_file -> ()
921 let names = List.rev !names in
924 | name, P.Pattern patt -> add_named_pattern _loc name patt
925 | _, P.Constructor _ -> () (* just ignore these for now *)
929 GLOBAL: expr str_item;
931 (* Qualifiers are a list of identifiers ("string", "bigendian", etc.)
932 * followed by an optional expression (used in certain cases). Note
933 * that we are careful not to declare any explicit reserved words.
938 e = OPT [ "("; e = expr; ")" -> e ] -> (q, e) ]
942 (* Field used in the bitmatch operator (a pattern). This can actually
943 * return multiple fields, in the case where the 'field' is a named
947 [ fpatt = patt; ":"; len = expr LEVEL "top";
948 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
949 let field = P.create_pattern_field _loc in
950 let field = P.set_patt field fpatt in
951 let field = P.set_length field len in
952 [parse_field _loc field qs] (* Normal, single field. *)
953 | ":"; name = LIDENT ->
954 expand_named_pattern _loc name (* Named -> list of fields. *)
958 (* Case inside bitmatch operator. *)
961 fields = LIST0 patt_field SEP ";";
968 [ fields = patt_fields;
969 bind = OPT [ "as"; name = LIDENT -> name ];
970 whenclause = OPT [ "when"; e = expr -> e ]; "->";
972 (fields, bind, whenclause, code)
976 (* Field used in the BITSTRING constructor (an expression). *)
978 [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
979 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
980 let field = P.create_constructor_field _loc in
981 let field = P.set_expr field fexpr in
982 let field = P.set_length field len in
983 parse_field _loc field qs
989 fields = LIST0 constr_field SEP ";";
995 (* 'bitmatch' expressions. *)
998 bs = expr; "with"; OPT "|";
999 cases = LIST1 patt_case SEP "|" ->
1000 output_bitmatch _loc bs cases
1005 fields = constr_fields ->
1006 output_constructor _loc fields
1010 (* Named persistent patterns.
1012 * NB: Currently only allowed at the top level. We can probably lift
1013 * this restriction later if necessary. We only deal with patterns
1014 * at the moment, not constructors, but the infrastructure to do
1015 * constructors is in place.
1017 str_item: LEVEL "top" [
1018 [ "let"; "bitmatch";
1019 name = LIDENT; "="; fields = patt_fields ->
1020 add_named_pattern _loc name fields;
1021 (* The statement disappears, but we still need a str_item so ... *)
1023 | "open"; "bitmatch"; filename = STRING ->
1024 load_patterns_from_file _loc filename;