1 (* Bitmatch syntax extension.
2 * $Id: pa_bitmatch.ml,v 1.1 2008-03-31 22:52:17 rjones Exp $
11 type m = Fields of f list (* field ; field -> ... *)
12 | Bind of string option (* _ -> ... *)
14 ident : string; (* field name *)
15 flen : expr; (* length in bits, may be non-const *)
16 endian : endian; (* endianness *)
17 signed : bool; (* true if signed, false if unsigned *)
20 and endian = BigEndian | LittleEndian | NativeEndian
21 and t = Int | Bitstring
23 (* Generate a fresh, unique symbol each time called. *)
28 sprintf "__pabitmatch_%s_%d" name i
30 (* Deal with the qualifiers which appear for a field. *)
31 let output_field _loc name flen qs =
32 let endian, signed, t =
34 | None -> (None, None, None)
37 fun (endian, signed, t) q ->
40 if endian <> None then
41 Loc.raise _loc (Failure "an endian flag has been set already")
43 let endian = Some BigEndian in
47 if endian <> None then
48 Loc.raise _loc (Failure "an endian flag has been set already")
50 let endian = Some LittleEndian in
54 if endian <> None then
55 Loc.raise _loc (Failure "an endian flag has been set already")
57 let endian = Some NativeEndian in
61 if signed <> None then
62 Loc.raise _loc (Failure "a signed flag has been set already")
64 let signed = Some true in
68 if signed <> None then
69 Loc.raise _loc (Failure "a signed flag has been set already")
71 let signed = Some false in
76 Loc.raise _loc (Failure "a type flag has been set already")
83 Loc.raise _loc (Failure "a type flag has been set already")
85 let t = Some Bitstring in
89 Loc.raise _loc (Failure (s ^ ": unknown qualifier"))
90 ) (None, None, None) qs in
92 (* If type is set to bitstring then endianness and signedness
93 * qualifiers are meaningless and must not be set.
95 if t = Some Bitstring && (endian <> None || signed <> None) then
97 Failure "bitstring type and endian or signed qualifiers cannot be mixed"
100 (* Default endianness, signedness, type. *)
101 let endian = match endian with None -> BigEndian | Some e -> e in
102 let signed = match signed with None -> false | Some s -> s in
103 let t = match t with None -> Int | Some t -> t in
113 (* Generate the code for a bitmatch statement. '_loc' is the
114 * location, 'bs' is the bitstring parameter, 'cases' are
115 * the list of cases to test against.
117 let output_bitmatch _loc bs cases =
118 let data = gensym "data" and off = gensym "off" and len = gensym "len" in
119 let result = gensym "result" in
121 (* This generates the field extraction code for each
122 * field a single case. Each field must be wider than
123 * the minimum permitted for the type and there must be
124 * enough remaining data in the bitstring to satisfy it.
125 * As we go through the fields, symbols 'data', 'off' and 'len'
126 * track our position and remaining length in the bitstring.
128 * The whole thing is a lot of nested 'if' statements. Code
129 * is generated from the inner-most (last) field outwards.
131 let rec output_field_extraction inner = function
133 | {ident=ident; flen=flen; endian=endian; signed=signed; t=t} :: fields ->
134 (* If length an integer constant? If so, what is it? This
135 * is very simple-minded and only detects simple constants.
139 | <:expr< $int:i$ >> -> Some (int_of_string i)
142 let name_of_int_extract_const = function
143 | (1, _, _) -> "extract_bit"
144 | ((2|3|4|5|6|7), _, false) -> "extract_char_unsigned"
145 | ((2|3|4|5|6|7), _, true) -> "extract_char_signed"
146 | (i, BigEndian, false) when i <= 31 -> "extract_int_be_unsigned"
147 | (i, BigEndian, true) when i <= 31 -> "extract_int_be_signed"
148 | (i, LittleEndian, false) when i <= 31 -> "extract_int_le_unsigned"
149 | (i, LittleEndian, true) when i <= 31 -> "extract_int_le_signed"
150 | (i, NativeEndian, false) when i <= 31 -> "extract_int_ne_unsigned"
151 | (i, NativeEndian, true) when i <= 31 -> "extract_int_ne_signed"
152 | (32, BigEndian, false) -> "extract_int32_be_unsigned"
153 | (32, BigEndian, true) -> "extract_int32_be_signed"
154 | (32, LittleEndian, false) -> "extract_int32_le_unsigned"
155 | (32, LittleEndian, true) -> "extract_int32_le_signed"
156 | (32, NativeEndian, false) -> "extract_int32_ne_unsigned"
157 | (32, NativeEndian, true) -> "extract_int32_ne_signed"
158 | (_, BigEndian, false) -> "extract_int64_be_unsigned"
159 | (_, BigEndian, true) -> "extract_int64_be_signed"
160 | (_, LittleEndian, false) -> "extract_int64_le_unsigned"
161 | (_, LittleEndian, true) -> "extract_int64_le_signed"
162 | (_, NativeEndian, false) -> "extract_int64_ne_unsigned"
163 | (_, NativeEndian, true) -> "extract_int64_ne_signed"
165 let name_of_int_extract = function
166 (* XXX As an enhancement we should allow users to
167 * specify that a field length can fit into a char/int/int32
168 * (of course, this would have to be checked at runtime).
170 | (BigEndian, false) -> "extract_int64_be_unsigned"
171 | (BigEndian, true) -> "extract_int64_be_signed"
172 | (LittleEndian, false) -> "extract_int64_le_unsigned"
173 | (LittleEndian, true) -> "extract_int64_le_signed"
174 | (NativeEndian, false) -> "extract_int64_ne_unsigned"
175 | (NativeEndian, true) -> "extract_int64_ne_signed"
179 match t, flen_is_const with
180 (* Common case: int field, constant flen *)
181 | Int, Some i when i > 0 && i <= 64 ->
182 let extract_func = name_of_int_extract_const (i,endian,signed) in
184 if $lid:len$ >= $flen$ then (
185 let $lid:ident$, $lid:off$, $lid:len$ =
186 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
193 Loc.raise _loc (Failure "length of int field must be [1..64]")
195 (* Int field, non-const flen. We have to test the range of
196 * the field at runtime. If outside the range it's a no-match
200 let extract_func = name_of_int_extract (endian,signed) in
202 if $flen$ >= 1 && $flen$ <= 64 && $flen$ >= $lid:len$ then (
203 let $lid:ident$, $lid:off$, $lid:len$ =
204 Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
210 (* Bitstring, constant flen >= 0. *)
211 | Bitstring, Some i when i >= 0 ->
213 if $lid:len$ >= $flen$ then (
214 let $lid:ident$, $lid:off$, $lid:len$ =
215 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
221 (* Bitstring, constant flen = -1, means consume all the
224 | Bitstring, Some i when i = -1 ->
226 let $lid:ident$, $lid:off$, $lid:len$ =
227 Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
231 | Bitstring, Some _ ->
232 Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
234 (* Bitstring field, non-const flen. We check the flen is >= 0
235 * (-1 is not allowed here) at runtime.
239 if $flen$ >= 0 && $lid:len$ >= $flen$ then (
240 let $lid:ident$, $lid:off$, $lid:len$ =
241 Bitmatch.extract_bitstring $lid:data$ $lid:off$ $lid:len$
248 output_field_extraction expr fields
251 (* Convert each case in the match. *)
252 let cases = List.map (
254 (* field : len ; field : len when .. -> ..*)
255 | (Fields fields, Some whenclause, code) ->
258 if $whenclause$ then (
259 $lid:result$ := Some ($code$);
263 output_field_extraction inner (List.rev fields)
265 (* field : len ; field : len -> ... *)
266 | (Fields fields, None, code) ->
269 $lid:result$ := Some ($code$);
272 output_field_extraction inner (List.rev fields)
274 (* _ as name when ... -> ... *)
275 | (Bind (Some name), Some whenclause, code) ->
277 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
278 if $whenclause$ then (
279 $lid:result$ := Some ($code$);
284 (* _ as name -> ... *)
285 | (Bind (Some name), None, code) ->
287 let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
288 $lid:result$ := Some ($code$);
292 (* _ when ... -> ... *)
293 | (Bind None, Some whenclause, code) ->
295 if $whenclause$ then (
296 $lid:result$ := Some ($code$);
302 | (Bind None, None, code) ->
304 $lid:result$ := Some ($code$);
311 List.fold_right (fun case base -> <:expr< $case$ ; $base$ >>)
312 cases <:expr< () >> in
314 (* The final code just wraps the list of cases in a
315 * try/with construct so that each case is tried in
316 * turn until one case matches (that case sets 'result'
317 * and raises 'Exit' to leave the whole statement).
318 * If result isn't set by the end then we will raise
319 * Match_failure with the location of the bitmatch
320 * statement in the original code.
322 let loc_fname = Loc.file_name _loc in
323 let loc_line = string_of_int (Loc.start_line _loc) in
324 let loc_char = string_of_int (Loc.start_off _loc - Loc.start_bol _loc) in
327 let ($lid:data$, $lid:off$, $lid:len$) = $bs$ in
328 let $lid:result$ = ref None in
332 match ! $lid:result$ with
334 | None -> raise (Match_failure ($str:loc_fname$,
335 $int:loc_line$, $int:loc_char$))
342 [ LIST0 [ q = LIDENT -> q ] SEP "," ]
346 [ name = LIDENT; ":"; len = expr LEVEL "top";
347 qs = OPT [ ":"; qs = qualifiers -> qs ] ->
348 output_field _loc name len qs
353 [ fields = LIST0 field SEP ";";
354 w = OPT [ "when"; e = expr -> e ]; "->";
356 (Fields fields, w, code)
359 bind = OPT [ "as"; name = LIDENT -> name ];
360 w = OPT [ "when"; e = expr -> e ]; "->";
367 [ "bitmatch"; bs = expr; "with"; OPT "|";
368 cases = LIST1 match_case SEP "|" ->
369 output_bitmatch _loc bs cases