(* Bitmatch syntax extension.
- * $Id: pa_bitmatch.ml,v 1.4 2008-04-01 17:05:37 rjones Exp $
+ * Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ *
+ * $Id: pa_bitmatch.ml,v 1.9 2008-04-25 12:08:51 rjones Exp $
*)
open Printf
*
* If this is false then no extra debugging code is emitted.
*)
-let debug = true
+let debug = false
+
+(* A field when used in a bitmatch (a pattern). *)
+type fpatt = {
+ fpatt : patt; (* field matching pattern *)
+ fpc : fcommon;
+}
+(* A field when used in a BITSTRING constructor (an expression). *)
+and fexpr = {
+ fexpr : expr; (* field value *)
+ fec : fcommon;
+}
-type m = Fields of f list (* field ; field -> ... *)
- | Bind of string option (* _ -> ... *)
-and f = {
- (* XXX fval should be a patt, not an expr *)
- fval : expr; (* field binding or value *)
+and fcommon = {
flen : expr; (* length in bits, may be non-const *)
endian : endian; (* endianness *)
signed : bool; (* true if signed, false if unsigned *)
incr i; let i = !i in
sprintf "__pabitmatch_%s_%d" name i
-(* Deal with the qualifiers which appear for a field. *)
-let parse_field _loc fval flen qs =
+(* Heuristic test if a pattern is exhaustive. *)
+let pattern_is_exhaustive = function
+ | <:patt< $lid:_$ >> -> true
+ | _ -> false
+
+let rec parse_patt_field _loc fpatt flen qs =
+ let fpc = parse_field_common _loc flen qs in
+ { fpatt = fpatt; fpc = fpc }
+
+and parse_constr_field _loc fexpr flen qs =
+ let fec = parse_field_common _loc flen qs in
+ { fexpr = fexpr; fec = fec }
+
+(* Deal with the qualifiers which appear for a field of both types. *)
+and parse_field_common _loc flen qs =
let endian, signed, t =
match qs with
| None -> (None, None, None)
let t = match t with None -> Int | Some t -> t in
{
- fval = fval;
flen = flen;
endian = endian;
signed = signed;
| Int -> "int"
| Bitstring -> "bitstring"
-let string_of_field { fval = fval; flen = flen;
- endian = endian; signed = signed; t = t;
- _loc = _loc } =
- let fval =
- match fval with
+let rec string_of_patt_field { fpatt = fpatt; fpc = fpc } =
+ let fpc = string_of_field_common fpc in
+ let fpatt =
+ match fpatt with
+ | <:patt< $lid:id$ >> -> id
+ | _ -> "[pattern]" in
+ fpatt ^ " : " ^ fpc
+
+and string_of_constr_field { fexpr = fexpr; fec = fec } =
+ let fec = string_of_field_common fec in
+ let fexpr =
+ match fexpr with
| <:expr< $lid:id$ >> -> id
| _ -> "[expression]" in
+ fexpr ^ " : " ^ fec
+
+and string_of_field_common { flen = flen;
+ endian = endian; signed = signed; t = t;
+ _loc = _loc } =
let flen =
match flen with
| <:expr< $int:i$ >> -> i
let loc_line = Loc.start_line _loc in
let loc_char = Loc.start_off _loc - Loc.start_bol _loc in
- sprintf "%s : %s : %s, %s, %s @ (%S, %d, %d)"
- fval flen t endian signed loc_fname loc_line loc_char
+ sprintf "%s : %s, %s, %s @ (%S, %d, %d)"
+ flen t endian signed loc_fname loc_line loc_char
(* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
let output_constructor _loc fields =
(* Bitstrings are created like the 'Buffer' module (in fact, using
* the Buffer module), by appending snippets to a growing buffer.
- * This is reasonable efficient and avoids a lot of garbage.
+ * This is reasonably efficient and avoids a lot of garbage.
*)
let buffer = gensym "buffer" in
(* Convert each field to a simple bitstring-generating expression. *)
let fields = List.map (
- fun {fval=fval; flen=flen; endian=endian; signed=signed; t=t} ->
+ fun {fexpr=fexpr; fec={flen=flen; endian=endian; signed=signed; t=t}} ->
(* Is flen an integer constant? If so, what is it? This
* is very simple-minded and only detects simple constants.
*)
exn_used := true;
<:expr<
- Bitmatch.$lid:construct_func$ $lid:buffer$ $fval$ $flen$
+ Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
$lid:exn$
>>
<:expr<
if $flen$ >= 1 && $flen$ <= 64 then
- Bitmatch.$lid:construct_func$ $lid:buffer$ $fval$ $flen$
+ Bitmatch.$lid:construct_func$ $lid:buffer$ $fexpr$ $flen$
$lid:exn$
else
raise (Bitmatch.Construct_failure
| Bitstring, Some i when i > 0 ->
let bs = gensym "bs" in
<:expr<
- let $lid:bs$ = $fval$ in
+ let $lid:bs$ = $fexpr$ in
if Bitmatch.bitstring_length $lid:bs$ = $flen$ then
Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
else
* with no checks.
*)
| Bitstring, Some (-1) ->
- <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fval$ >>
+ <:expr< Bitmatch.construct_bitstring $lid:buffer$ $fexpr$ >>
(* Bitstring, constant length = 0 is probably an error, and so it
* any other value.
<:expr<
let $lid:bslen$ = $flen$ in
if $lid:bslen$ > 0 then (
- let $lid:bs$ = $fval$ in
+ let $lid:bs$ = $fexpr$ in
if Bitmatch.bitstring_length $lid:bs$ = $lid:bslen$ then
Bitmatch.construct_bitstring $lid:buffer$ $lid:bs$
else
let rec output_field_extraction inner = function
| [] -> inner
| field :: fields ->
- let {fval=fval; flen=flen; endian=endian; signed=signed; t=t}
+ let {fpatt=fpatt; fpc={flen=flen; endian=endian; signed=signed; t=t}}
= field in
- (* Is fval a binding (an ident) or an expression? If it's
- * a binding then we will generate a binding for this field.
- * If it's an expression then we will test the field against
- * the expression.
- *)
- let fval_is_ident =
- match fval with
- | <:expr< $lid:id$ >> -> Some id
- | _ -> None in
-
(* Is flen an integer constant? If so, what is it? This
* is very simple-minded and only detects simple constants.
*)
in
let expr =
- match t, fval_is_ident, flen_is_const with
- (* Common case: int field, binding, constant flen *)
- | Int, Some ident, Some i when i > 0 && i <= 64 ->
- let extract_func = name_of_int_extract_const (i,endian,signed) in
- <:expr<
- if $lid:len$ >= $flen$ then (
- let $lid:ident$, $lid:off$, $lid:len$ =
- Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
- $flen$ in
- $inner$
- )
- >>
-
- (* Int field, not a binding, constant flen *)
- | Int, None, Some i when i > 0 && i <= 64 ->
+ match t, flen_is_const with
+ (* Common case: int field, constant flen *)
+ | Int, Some i when i > 0 && i <= 64 ->
let extract_func = name_of_int_extract_const (i,endian,signed) in
let v = gensym "val" in
- <:expr<
- if $lid:len$ >= $flen$ then (
- let $lid:v$, $lid:off$, $lid:len$ =
- Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
- $flen$ in
- if $lid:v$ = $fval$ then (
- $inner$
+ if pattern_is_exhaustive fpatt then
+ <:expr<
+ if $lid:len$ >= $flen$ then (
+ let $lid:v$, $lid:off$, $lid:len$ =
+ Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
+ $flen$ in
+ match $lid:v$ with $fpatt$ -> $inner$
)
- )
- >>
+ >>
+ else
+ <:expr<
+ if $lid:len$ >= $flen$ then (
+ let $lid:v$, $lid:off$, $lid:len$ =
+ Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
+ $flen$ in
+ match $lid:v$ with $fpatt$ -> $inner$ | _ -> ()
+ )
+ >>
- | Int, _, Some _ ->
+ | Int, Some _ ->
Loc.raise _loc (Failure "length of int field must be [1..64]")
(* Int field, non-const flen. We have to test the range of
* the field at runtime. If outside the range it's a no-match
* (not an error).
*)
- | Int, Some ident, None ->
- let extract_func = name_of_int_extract (endian,signed) in
- <:expr<
- if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
- let $lid:ident$, $lid:off$, $lid:len$ =
- Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
- $flen$ in
- $inner$
- )
- >>
-
- | Int, None, None ->
+ | Int, None ->
let extract_func = name_of_int_extract (endian,signed) in
let v = gensym "val" in
- <:expr<
- if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
- let $lid:v$, $lid:off$, $lid:len$ =
- Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
- $flen$ in
- if $lid:v$ = $fval$ then (
- $inner$
+ if pattern_is_exhaustive fpatt then
+ <:expr<
+ if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
+ let $lid:v$, $lid:off$, $lid:len$ =
+ Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
+ $flen$ in
+ match $lid:v$ with $fpatt$ -> $inner$
)
- )
- >>
-
- (* Can't compare bitstrings at the moment. *)
- | Bitstring, None, _ ->
- Loc.raise _loc
- (Failure "cannot compare a bitstring to a constant")
+ >>
+ else
+ <:expr<
+ if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
+ let $lid:v$, $lid:off$, $lid:len$ =
+ Bitmatch.$lid:extract_func$ $lid:data$ $lid:off$ $lid:len$
+ $flen$ in
+ match $lid:v$ with $fpatt$ -> $inner$ | _ -> ()
+ )
+ >>
- (* Bitstring, constant flen >= 0. *)
- | Bitstring, Some ident, Some i when i >= 0 ->
+ (* Bitstring, constant flen >= 0.
+ * At the moment all we can do is assign the bitstring to an
+ * identifier.
+ *)
+ | Bitstring, Some i when i >= 0 ->
+ let ident =
+ match fpatt with
+ | <:patt< $lid:ident$ >> -> ident
+ | _ ->
+ Loc.raise _loc
+ (Failure "cannot compare a bitstring to a constant") in
<:expr<
if $lid:len$ >= $flen$ then (
let $lid:ident$, $lid:off$, $lid:len$ =
(* Bitstring, constant flen = -1, means consume all the
* rest of the input.
*)
- | Bitstring, Some ident, Some i when i = -1 ->
+ | Bitstring, Some i when i = -1 ->
+ let ident =
+ match fpatt with
+ | <:patt< $lid:ident$ >> -> ident
+ | _ ->
+ Loc.raise _loc
+ (Failure "cannot compare a bitstring to a constant") in
<:expr<
let $lid:ident$, $lid:off$, $lid:len$ =
Bitmatch.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
$inner$
>>
- | Bitstring, _, Some _ ->
+ | Bitstring, Some _ ->
Loc.raise _loc (Failure "length of bitstring must be >= 0 or the special value -1")
(* Bitstring field, non-const flen. We check the flen is >= 0
* (-1 is not allowed here) at runtime.
*)
- | Bitstring, Some ident, None ->
+ | Bitstring, None ->
+ let ident =
+ match fpatt with
+ | <:patt< $lid:ident$ >> -> ident
+ | _ ->
+ Loc.raise _loc
+ (Failure "cannot compare a bitstring to a constant") in
<:expr<
if $flen$ >= 0 && $flen$ <= $lid:len$ then (
let $lid:ident$, $lid:off$, $lid:len$ =
(* Emit extra debugging code. *)
let expr =
if not debug then expr else (
- let field = string_of_field field in
+ let field = string_of_patt_field field in
<:expr<
if !Bitmatch.debug then (
Printf.eprintf "PA_BITMATCH: TEST:\n";
Printf.eprintf " %s\n" $str:field$;
Printf.eprintf " off %d len %d\n%!" $lid:off$ $lid:len$;
+ (*Bitmatch.hexdump_bitstring stderr
+ ($lid:data$,$lid:off$,$lid:len$);*)
);
$expr$
>>
(* Convert each case in the match. *)
let cases = List.map (
- function
- (* field : len ; field : len when .. -> ..*)
- | (Fields fields, Some whenclause, code) ->
- let inner =
- <:expr<
- if $whenclause$ then (
- $lid:result$ := Some ($code$);
- raise Exit
- )
- >> in
- output_field_extraction inner (List.rev fields)
-
- (* field : len ; field : len -> ... *)
- | (Fields fields, None, code) ->
- let inner =
- <:expr<
- $lid:result$ := Some ($code$);
- raise Exit
- >> in
- output_field_extraction inner (List.rev fields)
-
- (* _ as name when ... -> ... *)
- | (Bind (Some name), Some whenclause, code) ->
- <:expr<
- let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
- if $whenclause$ then (
- $lid:result$ := Some ($code$);
- raise Exit
- )
- >>
-
- (* _ as name -> ... *)
- | (Bind (Some name), None, code) ->
- <:expr<
- let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
- $lid:result$ := Some ($code$);
- raise Exit
- >>
-
- (* _ when ... -> ... *)
- | (Bind None, Some whenclause, code) ->
- <:expr<
- if $whenclause$ then (
- $lid:result$ := Some ($code$);
- raise Exit
- )
- >>
-
- (* _ -> ... *)
- | (Bind None, None, code) ->
- <:expr<
- $lid:result$ := Some ($code$);
- raise Exit
- >>
-
+ fun (fields, bind, whenclause, code) ->
+ let inner = <:expr< $lid:result$ := Some ($code$); raise Exit >> in
+ let inner =
+ match whenclause with
+ | Some whenclause ->
+ <:expr< if $whenclause$ then $inner$ >>
+ | None -> inner in
+ let inner =
+ match bind with
+ | Some name ->
+ <:expr<
+ let $lid:name$ = ($lid:data$, $lid:off$, $lid:len$) in
+ $inner$
+ >>
+ | None -> inner in
+ output_field_extraction inner (List.rev fields)
) cases in
(* Join them into a single expression.
[ LIST0 [ q = LIDENT -> q ] SEP "," ]
];
- field: [
- [ fval = expr LEVEL "top"; ":"; len = expr LEVEL "top";
+ (* Field used in the bitmatch operator (a pattern). *)
+ patt_field: [
+ [ fpatt = patt; ":"; len = expr LEVEL "top";
qs = OPT [ ":"; qs = qualifiers -> qs ] ->
- parse_field _loc fval len qs
+ parse_patt_field _loc fpatt len qs
]
];
+ (* Case inside bitmatch operator. *)
match_case: [
- [ "_";
+ [ "{";
+ fields = LIST0 patt_field SEP ";";
+ "}";
bind = OPT [ "as"; name = LIDENT -> name ];
- w = OPT [ "when"; e = expr -> e ]; "->";
+ whenclause = OPT [ "when"; e = expr -> e ]; "->";
code = expr ->
- (Bind bind, w, code)
+ (fields, bind, whenclause, code)
]
- | [ fields = LIST0 field SEP ";";
- w = OPT [ "when"; e = expr -> e ]; "->";
- code = expr ->
- (Fields fields, w, code)
+ ];
+
+ (* Field used in the BITSTRING constructor (an expression). *)
+ constr_field: [
+ [ fexpr = expr LEVEL "top"; ":"; len = expr LEVEL "top";
+ qs = OPT [ ":"; qs = qualifiers -> qs ] ->
+ parse_constr_field _loc fexpr len qs
]
];
(* 'bitmatch' expressions. *)
expr: LEVEL ";" [
- [ "bitmatch"; bs = expr; "with"; OPT "|";
+ [ "bitmatch";
+ bs = expr; "with"; OPT "|";
cases = LIST1 match_case SEP "|" ->
output_bitmatch _loc bs cases
]
(* Constructor. *)
- | [ "BITSTRING";
- fields = LIST0 field SEP ";" ->
+ | [ "BITSTRING"; "{";
+ fields = LIST0 constr_field SEP ";";
+ "}" ->
output_constructor _loc fields
]
];
git.annexia.org / ocaml-bitstring.git / blobdiff