aboutsummaryrefslogtreecommitdiff
path: root/gramlib
diff options
context:
space:
mode:
Diffstat (limited to 'gramlib')
-rw-r--r--gramlib/dune4
-rw-r--r--gramlib/fstream.ml198
-rw-r--r--gramlib/fstream.mli49
-rw-r--r--gramlib/gramext.ml720
-rw-r--r--gramlib/gramext.mli120
-rw-r--r--gramlib/grammar.ml3826
-rw-r--r--gramlib/grammar.mli319
-rw-r--r--gramlib/plexing.ml256
-rw-r--r--gramlib/plexing.mli85
-rw-r--r--gramlib/ploc.ml286
-rw-r--r--gramlib/ploc.mli57
-rw-r--r--gramlib/token.ml50
-rw-r--r--gramlib/token.mli54
13 files changed, 3035 insertions, 2989 deletions
diff --git a/gramlib/dune b/gramlib/dune
new file mode 100644
index 0000000000..f7605fa9f3
--- /dev/null
+++ b/gramlib/dune
@@ -0,0 +1,4 @@
+(library
+ (name gramlib)
+ (public_name coq.gramlib)
+ (wrapped false))
diff --git a/gramlib/fstream.ml b/gramlib/fstream.ml
index 928df3b0c4..94e25ffd54 100644
--- a/gramlib/fstream.ml
+++ b/gramlib/fstream.ml
@@ -2,151 +2,145 @@
(* fstream.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)
-exception Cut;
-
-type mlazy_c 'a =
- [ Lfun of unit -> 'a
- | Lval of 'a ]
-;
-type mlazy 'a =
- [ Cval of 'a
- | Clazy of ref (mlazy_c 'a) ]
-;
-value mlazy f = Clazy (ref (Lfun f));
-value mlazy_force l =
+exception Cut
+
+type 'a mlazy_c =
+ Lfun of (unit -> 'a)
+ | Lval of 'a
+type 'a mlazy =
+ Cval of 'a
+ | Clazy of 'a mlazy_c ref
+let mlazy f = Clazy (ref (Lfun f))
+let mlazy_force l =
match l with
- [ Cval v -> v
+ Cval v -> v
| Clazy l ->
- match l.val with
- [ Lfun f -> do { let x = f () in l.val := Lval x; x }
- | Lval v -> v ] ]
-;
-value mlazy_is_val l =
+ match !l with
+ Lfun f -> let x = f () in l := Lval x; x
+ | Lval v -> v
+let mlazy_is_val l =
match l with
- [ Cval _ -> True
+ Cval _ -> true
| Clazy l ->
- match l.val with
- [ Lval _ -> True
- | Lfun _ -> False ] ]
-;
-
-type t 'a = { count : int; data : mlazy (data 'a) }
-and data 'a =
- [ Nil
- | Cons of 'a and t 'a
- | App of t 'a and t 'a ]
-;
-
-value from f =
- loop 0 where rec loop i =
+ match !l with
+ Lval _ -> true
+ | Lfun _ -> false
+
+type 'a t = { count : int; data : 'a data mlazy }
+and 'a data =
+ Nil
+ | Cons of 'a * 'a t
+ | App of 'a t * 'a t
+
+let from f =
+ let rec loop i =
{count = 0;
data =
mlazy
(fun () ->
match f i with
- [ Some x -> Cons x (loop (i + 1))
- | None -> Nil ])}
-;
+ Some x -> Cons (x, loop (i + 1))
+ | None -> Nil)}
+ in
+ loop 0
-value rec next s =
+let rec next s =
let count = s.count + 1 in
match mlazy_force s.data with
- [ Nil -> None
- | Cons a s -> Some (a, {count = count; data = s.data})
- | App s1 s2 ->
+ Nil -> None
+ | Cons (a, s) -> Some (a, {count = count; data = s.data})
+ | App (s1, s2) ->
match next s1 with
- [ Some (a, s1) ->
- Some (a, {count = count; data = mlazy (fun () -> App s1 s2)})
+ Some (a, s1) ->
+ Some (a, {count = count; data = mlazy (fun () -> App (s1, s2))})
| None ->
match next s2 with
- [ Some (a, s2) -> Some (a, {count = count; data = s2.data})
- | None -> None ] ] ]
-;
+ Some (a, s2) -> Some (a, {count = count; data = s2.data})
+ | None -> None
-value empty s =
+let empty s =
match next s with
- [ Some _ -> None
- | None -> Some ((), s) ]
-;
+ Some _ -> None
+ | None -> Some ((), s)
-value nil = {count = 0; data = Cval Nil};
-value cons a s = Cons a s;
-value app s1 s2 = App s1 s2;
-value flazy f = {count = 0; data = mlazy f};
+let nil = {count = 0; data = Cval Nil}
+let cons a s = Cons (a, s)
+let app s1 s2 = App (s1, s2)
+let flazy f = {count = 0; data = mlazy f}
-value of_list l =
- List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil
-;
+let of_list l = List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil
-value of_string s =
+let of_string s =
from (fun c -> if c < String.length s then Some s.[c] else None)
-;
-value of_channel ic =
- from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ])
-;
+let of_channel ic =
+ from (fun _ -> try Some (input_char ic) with End_of_file -> None)
-value iter f =
- do_rec where rec do_rec strm =
+let iter f =
+ let rec do_rec strm =
match next strm with
- [ Some (a, strm) ->
- let _ = f a in
- do_rec strm
- | None -> () ]
-;
+ Some (a, strm) -> let _ = f a in do_rec strm
+ | None -> ()
+ in
+ do_rec
-value count s = s.count;
+let count s = s.count
-value count_unfrozen s =
- loop 0 s where rec loop cnt s =
+let count_unfrozen s =
+ let rec loop cnt s =
if mlazy_is_val s.data then
match mlazy_force s.data with
- [ Cons _ s -> loop (cnt + 1) s
- | _ -> cnt ]
+ Cons (_, s) -> loop (cnt + 1) s
+ | _ -> cnt
else cnt
-;
+ in
+ loop 0 s
(* backtracking parsers *)
-type kont 'a 'b = [ K of unit -> option ('b * t 'a * kont 'a 'b) ];
-type bp 'a 'b = t 'a -> option ('b * t 'a * kont 'a 'b);
+type ('a, 'b) kont =
+ K of (unit -> ('b * 'a t * ('a, 'b) kont) option)
+type ('a, 'b) bp = 'a t -> ('b * 'a t * ('a, 'b) kont) option
-value bcontinue = fun [ (K k) -> k () ];
+let bcontinue =
+ function
+ K k -> k ()
-value bparse_all p strm =
- loop (fun () -> p strm) where rec loop p =
+let bparse_all p strm =
+ let rec loop p =
match p () with
- [ Some (r, _, K k) -> [r :: loop k]
- | None -> [] ]
-;
+ Some (r, _, K k) -> r :: loop k
+ | None -> []
+ in
+ loop (fun () -> p strm)
-value b_seq a b strm =
+let b_seq a b strm =
let rec app_a kont1 () =
match kont1 () with
- [ Some (x, strm, K kont1) -> app_b (fun () -> b x strm) kont1 ()
- | None -> None ]
+ Some (x, strm, K kont1) -> app_b (fun () -> b x strm) kont1 ()
+ | None -> None
and app_b kont2 kont1 () =
match kont2 () with
- [ Some (y, strm, K kont2) -> Some (y, strm, K (app_b kont2 kont1))
- | None -> app_a kont1 () ]
+ Some (y, strm, K kont2) -> Some (y, strm, K (app_b kont2 kont1))
+ | None -> app_a kont1 ()
in
app_a (fun () -> a strm) ()
-;
-value b_or a b strm =
- loop (fun () -> a strm) () where rec loop kont () =
+let b_or a b strm =
+ let rec loop kont () =
match kont () with
- [ Some (x, strm, K kont) -> Some (x, strm, K (loop kont))
- | None -> b strm ]
-;
+ Some (x, strm, K kont) -> Some (x, strm, K (loop kont))
+ | None -> b strm
+ in
+ loop (fun () -> a strm) ()
-value b_term f strm =
+let b_term f strm =
match next strm with
- [ Some (x, strm) ->
- match f x with
- [ Some y -> Some (y, strm, K (fun _ -> None))
- | None -> None ]
- | None -> None ]
-;
-
-value b_act a strm = Some (a, strm, K (fun _ -> None));
+ Some (x, strm) ->
+ begin match f x with
+ Some y -> Some (y, strm, K (fun _ -> None))
+ | None -> None
+ end
+ | None -> None
+
+let b_act a strm = Some (a, strm, K (fun _ -> None))
diff --git a/gramlib/fstream.mli b/gramlib/fstream.mli
index a6d0391173..2fefd4bcfc 100644
--- a/gramlib/fstream.mli
+++ b/gramlib/fstream.mli
@@ -28,68 +28,69 @@
case of the previous rule is tested.
*)
-exception Cut;
+exception Cut
(** Functional streams *)
-type t 'a = 'x;
+type 'a t
(* The type of 'a functional streams *)
-value from : (int -> option 'a) -> t 'a;
+val from : (int -> 'a option) -> 'a t
(* [Fstream.from f] returns a stream built from the function [f].
To create a new stream element, the function [f] is called with
the current stream count. The user function [f] must return either
[Some <value>] for a value or [None] to specify the end of the
stream. *)
-value of_list : list 'a -> t 'a;
+val of_list : 'a list -> 'a t
(* Return the stream holding the elements of the list in the same
order. *)
-value of_string : string -> t char;
+val of_string : string -> char t
(* Return the stream of the characters of the string parameter. *)
-value of_channel : in_channel -> t char;
+val of_channel : in_channel -> char t
(* Return the stream of the characters read from the input channel. *)
-value iter : ('a -> unit) -> t 'a -> unit;
+val iter : ('a -> unit) -> 'a t -> unit
(* [Fstream.iter f s] scans the whole stream s, applying function [f]
in turn to each stream element encountered. *)
-value next : t 'a -> option ('a * t 'a);
+val next : 'a t -> ('a * 'a t) option
(* Return [Some (a, s)] where [a] is the first element of the stream
and [s] the remaining stream, or [None] if the stream is empty. *)
-value empty : t 'a -> option (unit * t 'a);
+val empty : 'a t -> (unit * 'a t) option
(* Return [Some ((), s)] if the stream is empty where [s] is itself,
else [None] *)
-value count : t 'a -> int;
+val count : 'a t -> int
(* Return the current count of the stream elements, i.e. the number
of the stream elements discarded. *)
-value count_unfrozen : t 'a -> int;
+val count_unfrozen : 'a t -> int
(* Return the number of unfrozen elements in the beginning of the
stream; useful to determine the position of a parsing error (longuest
path). *)
(** Backtracking parsers *)
-type kont 'a 'b = [ K of unit -> option ('b * t 'a * kont 'a 'b) ];
+type ('a, 'b) kont =
+ K of (unit -> ('b * 'a t * ('a, 'b) kont) option)
(* The type of continuation of a backtracking parser. *)
-type bp 'a 'b = t 'a -> option ('b * t 'a * kont 'a 'b);
+type ('a, 'b) bp = 'a t -> ('b * 'a t * ('a, 'b) kont) option
(* The type of a backtracking parser. *)
-value bcontinue : kont 'a 'b -> option ('b * t 'a * kont 'a 'b);
+val bcontinue : ('a, 'b) kont -> ('b * 'a t * ('a, 'b) kont) option
(* [bcontinue k] return the next solution of a backtracking parser. *)
-value bparse_all : bp 'a 'b -> t 'a -> list 'b;
+val bparse_all : ('a, 'b) bp -> 'a t -> 'b list
(* [bparse_all p strm] return the list of all solutions of a
backtracking parser applied to a functional stream. *)
(*--*)
-value nil : t 'a;
-type data 'a = 'x;
-value cons : 'a -> t 'a -> data 'a;
-value app : t 'a -> t 'a -> data 'a;
-value flazy : (unit -> data 'a) -> t 'a;
+val nil : 'a t
+type 'a data
+val cons : 'a -> 'a t -> 'a data
+val app : 'a t -> 'a t -> 'a data
+val flazy : (unit -> 'a data) -> 'a t
-value b_seq : bp 'a 'b -> ('b -> bp 'a 'c) -> bp 'a 'c;
-value b_or : bp 'a 'b -> bp 'a 'b -> bp 'a 'b;
-value b_term : ('a -> option 'b) -> bp 'a 'b;
-value b_act : 'b -> bp 'a 'b;
+val b_seq : ('a, 'b) bp -> ('b -> ('a, 'c) bp) -> ('a, 'c) bp
+val b_or : ('a, 'b) bp -> ('a, 'b) bp -> ('a, 'b) bp
+val b_term : ('a -> 'b option) -> ('a, 'b) bp
+val b_act : 'b -> ('a, 'b) bp
diff --git a/gramlib/gramext.ml b/gramlib/gramext.ml
index 1e50bdc14f..028d1fdf12 100644
--- a/gramlib/gramext.ml
+++ b/gramlib/gramext.ml
@@ -2,446 +2,420 @@
(* gramext.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)
-open Printf;
+open Printf
-type parser_t 'a = Stream.t 'a -> Obj.t;
-type fparser_t 'a = Fstream.t 'a -> option (Obj.t * Fstream.t 'a);
-type bparser_t 'a = Fstream.bp 'a Obj.t;
+type 'a parser_t = 'a Stream.t -> Obj.t
+type 'a fparser_t = 'a Fstream.t -> (Obj.t * 'a Fstream.t) option
+type 'a bparser_t = ('a, Obj.t) Fstream.bp
type parse_algorithm =
- [ Predictive | Functional | Backtracking | DefaultAlgorithm ];
+ Predictive | Functional | Backtracking | DefaultAlgorithm
-type grammar 'te =
- { gtokens : Hashtbl.t Plexing.pattern (ref int);
- glexer : mutable Plexing.lexer 'te;
- galgo : mutable parse_algorithm }
-;
+type 'te grammar =
+ { gtokens : (Plexing.pattern, int ref) Hashtbl.t;
+ mutable glexer : 'te Plexing.lexer;
+ mutable galgo : parse_algorithm }
-type g_entry 'te =
- { egram : grammar 'te;
+type 'te g_entry =
+ { egram : 'te grammar;
ename : string;
elocal : bool;
- estart : mutable int -> parser_t 'te;
- econtinue : mutable int -> int -> Obj.t -> parser_t 'te;
- fstart : mutable int -> err_fun -> fparser_t 'te;
- fcontinue : mutable int -> int -> Obj.t -> err_fun -> fparser_t 'te;
- bstart : mutable int -> err_fun -> bparser_t 'te;
- bcontinue : mutable int -> int -> Obj.t -> err_fun -> bparser_t 'te;
- edesc : mutable g_desc 'te }
-and g_desc 'te =
- [ Dlevels of list (g_level 'te)
- | Dparser of parser_t 'te ]
-and g_level 'te =
+ mutable estart : int -> 'te parser_t;
+ mutable econtinue : int -> int -> Obj.t -> 'te parser_t;
+ mutable fstart : int -> err_fun -> 'te fparser_t;
+ mutable fcontinue : int -> int -> Obj.t -> err_fun -> 'te fparser_t;
+ mutable bstart : int -> err_fun -> 'te bparser_t;
+ mutable bcontinue : int -> int -> Obj.t -> err_fun -> 'te bparser_t;
+ mutable edesc : 'te g_desc }
+and 'te g_desc =
+ Dlevels of 'te g_level list
+ | Dparser of 'te parser_t
+and 'te g_level =
{ assoc : g_assoc;
- lname : option string;
- lsuffix : g_tree 'te;
- lprefix : g_tree 'te }
-and g_assoc = [ NonA | RightA | LeftA ]
-and g_symbol 'te =
- [ Sfacto of g_symbol 'te
- | Smeta of string and list (g_symbol 'te) and Obj.t
- | Snterm of g_entry 'te
- | Snterml of g_entry 'te and string
- | Slist0 of g_symbol 'te
- | Slist0sep of g_symbol 'te and g_symbol 'te and bool
- | Slist1 of g_symbol 'te
- | Slist1sep of g_symbol 'te and g_symbol 'te and bool
- | Sopt of g_symbol 'te
- | Sflag of g_symbol 'te
+ lname : string option;
+ lsuffix : 'te g_tree;
+ lprefix : 'te g_tree }
+and g_assoc = NonA | RightA | LeftA
+and 'te g_symbol =
+ Sfacto of 'te g_symbol
+ | Smeta of string * 'te g_symbol list * Obj.t
+ | Snterm of 'te g_entry
+ | Snterml of 'te g_entry * string
+ | Slist0 of 'te g_symbol
+ | Slist0sep of 'te g_symbol * 'te g_symbol * bool
+ | Slist1 of 'te g_symbol
+ | Slist1sep of 'te g_symbol * 'te g_symbol * bool
+ | Sopt of 'te g_symbol
+ | Sflag of 'te g_symbol
| Sself
| Snext
| Scut
| Stoken of Plexing.pattern
- | Stree of g_tree 'te
- | Svala of list string and g_symbol 'te ]
+ | Stree of 'te g_tree
+ | Svala of string list * 'te g_symbol
and g_action = Obj.t
-and g_tree 'te =
- [ Node of g_node 'te
- | LocAct of g_action and list g_action
- | DeadEnd ]
-and g_node 'te =
- { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te }
-and err_fun = unit -> string;
+and 'te g_tree =
+ Node of 'te g_node
+ | LocAct of g_action * g_action list
+ | DeadEnd
+and 'te g_node =
+ { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree }
+and err_fun = unit -> string
type position =
- [ First
+ First
| Last
| Before of string
| After of string
| Like of string
- | Level of string ]
-;
+ | Level of string
-value warning_verbose = ref True;
+let warning_verbose = ref true
-value rec derive_eps =
- fun
- [ Slist0 _ -> True
- | Slist0sep _ _ _ -> True
- | Sopt _ | Sflag _ -> True
+let rec derive_eps =
+ function
+ Slist0 _ -> true
+ | Slist0sep (_, _, _) -> true
+ | Sopt _ | Sflag _ -> true
| Sfacto s -> derive_eps s
| Stree t -> tree_derive_eps t
- | Svala _ s -> derive_eps s
- | Smeta _ _ _ | Slist1 _ | Slist1sep _ _ _ | Snterm _ | Snterml _ _ |
- Snext | Sself | Scut | Stoken _ ->
- False ]
+ | Svala (_, s) -> derive_eps s
+ | Smeta (_, _, _) | Slist1 _ | Slist1sep (_, _, _) | Snterm _ |
+ Snterml (_, _) | Snext | Sself | Scut | Stoken _ ->
+ false
and tree_derive_eps =
- fun
- [ LocAct _ _ -> True
+ function
+ LocAct (_, _) -> true
| Node {node = s; brother = bro; son = son} ->
derive_eps s && tree_derive_eps son || tree_derive_eps bro
- | DeadEnd -> False ]
-;
+ | DeadEnd -> false
-value rec eq_symbol s1 s2 =
- match (s1, s2) with
- [ (Snterm e1, Snterm e2) -> e1 == e2
- | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2
- | (Slist0 s1, Slist0 s2) -> eq_symbol s1 s2
- | (Slist0sep s1 sep1 b1, Slist0sep s2 sep2 b2) ->
+let rec eq_symbol s1 s2 =
+ match s1, s2 with
+ Snterm e1, Snterm e2 -> e1 == e2
+ | Snterml (e1, l1), Snterml (e2, l2) -> e1 == e2 && l1 = l2
+ | Slist0 s1, Slist0 s2 -> eq_symbol s1 s2
+ | Slist0sep (s1, sep1, b1), Slist0sep (s2, sep2, b2) ->
eq_symbol s1 s2 && eq_symbol sep1 sep2 && b1 = b2
- | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2
- | (Slist1sep s1 sep1 b1, Slist1sep s2 sep2 b2) ->
+ | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2
+ | Slist1sep (s1, sep1, b1), Slist1sep (s2, sep2, b2) ->
eq_symbol s1 s2 && eq_symbol sep1 sep2 && b1 = b2
- | (Sflag s1, Sflag s2) -> eq_symbol s1 s2
- | (Sopt s1, Sopt s2) -> eq_symbol s1 s2
- | (Svala ls1 s1, Svala ls2 s2) -> ls1 = ls2 && eq_symbol s1 s2
- | (Stree _, Stree _) -> False
- | (Sfacto (Stree t1), Sfacto (Stree t2)) ->
+ | Sflag s1, Sflag s2 -> eq_symbol s1 s2
+ | Sopt s1, Sopt s2 -> eq_symbol s1 s2
+ | Svala (ls1, s1), Svala (ls2, s2) -> ls1 = ls2 && eq_symbol s1 s2
+ | Stree _, Stree _ -> false
+ | Sfacto (Stree t1), Sfacto (Stree t2) ->
(* The only goal of the node 'Sfacto' is to allow tree comparison
(therefore factorization) without looking at the semantic
actions; allow factorization of rules like "SV foo" which are
actually expanded into a tree. *)
- eq_tree t1 t2 where rec eq_tree t1 t2 =
- match (t1, t2) with
- [ (Node n1, Node n2) ->
+ let rec eq_tree t1 t2 =
+ match t1, t2 with
+ Node n1, Node n2 ->
eq_symbol n1.node n2.node && eq_tree n1.son n2.son &&
eq_tree n1.brother n2.brother
- | (LocAct _ _, LocAct _ _) -> True
- | (DeadEnd, DeadEnd) -> True
- | _ -> False ]
- | _ -> s1 = s2 ]
-;
+ | LocAct (_, _), LocAct (_, _) -> true
+ | DeadEnd, DeadEnd -> true
+ | _ -> false
+ in
+ eq_tree t1 t2
+ | _ -> s1 = s2
-value is_before s1 s2 =
- let s1 = match s1 with [ Svala _ s -> s | _ -> s1 ] in
- let s2 = match s2 with [ Svala _ s -> s | _ -> s2 ] in
- match (s1, s2) with
- [ (Stoken ("ANY", _), _) -> False
- | (_, Stoken ("ANY", _)) -> True
- | (Stoken (_, s), Stoken (_, "")) when s <> "" -> True
- | (Stoken _, Stoken _) -> False
- | (Stoken _, _) -> True
- | _ -> False ]
-;
+let is_before s1 s2 =
+ let s1 =
+ match s1 with
+ Svala (_, s) -> s
+ | _ -> s1
+ in
+ let s2 =
+ match s2 with
+ Svala (_, s) -> s
+ | _ -> s2
+ in
+ match s1, s2 with
+ Stoken ("ANY", _), _ -> false
+ | _, Stoken ("ANY", _) -> true
+ | Stoken (_, s), Stoken (_, "") when s <> "" -> true
+ | Stoken _, Stoken _ -> false
+ | Stoken _, _ -> true
+ | _ -> false
-value insert_tree entry_name gsymbols action tree =
+let insert_tree entry_name gsymbols action tree =
let rec insert symbols tree =
match symbols with
- [ [s :: sl] -> insert_in_tree s sl tree
+ s :: sl -> insert_in_tree s sl tree
| [] ->
match tree with
- [ Node {node = s; son = son; brother = bro} ->
+ Node {node = s; son = son; brother = bro} ->
Node {node = s; son = son; brother = insert [] bro}
- | LocAct old_action action_list -> do {
- if warning_verbose.val then do {
- eprintf "<W> Grammar extension: ";
- if entry_name <> "" then eprintf "in [%s], " entry_name else ();
- eprintf "some rule has been masked\n";
- flush stderr
- }
- else ();
- LocAct action [old_action :: action_list]
- }
- | DeadEnd -> LocAct action [] ] ]
+ | LocAct (old_action, action_list) ->
+ if !warning_verbose then
+ begin
+ eprintf "<W> Grammar extension: ";
+ if entry_name <> "" then eprintf "in [%s], " entry_name;
+ eprintf "some rule has been masked\n";
+ flush stderr
+ end;
+ LocAct (action, old_action :: action_list)
+ | DeadEnd -> LocAct (action, [])
and insert_in_tree s sl tree =
match try_insert s sl tree with
- [ Some t -> t
- | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ]
+ Some t -> t
+ | None -> Node {node = s; son = insert sl DeadEnd; brother = tree}
and try_insert s sl tree =
match tree with
- [ Node {node = s1; son = son; brother = bro} ->
+ Node {node = s1; son = son; brother = bro} ->
if eq_symbol s s1 then
let t = Node {node = s1; son = insert sl son; brother = bro} in
Some t
else if s = Scut then
try_insert s sl (Node {node = s; son = tree; brother = DeadEnd})
- else if s1 = Scut then
- try_insert s1 [s :: sl] tree
+ else if s1 = Scut then try_insert s1 (s :: sl) tree
else if is_before s1 s || derive_eps s && not (derive_eps s1) then
let bro =
match try_insert s sl bro with
- [ Some bro -> bro
- | None ->
- Node {node = s; son = insert sl DeadEnd; brother = bro} ]
+ Some bro -> bro
+ | None -> Node {node = s; son = insert sl DeadEnd; brother = bro}
in
- let t = Node {node = s1; son = son; brother = bro} in
- Some t
+ let t = Node {node = s1; son = son; brother = bro} in Some t
else
- match try_insert s sl bro with
- [ Some bro ->
- let t = Node {node = s1; son = son; brother = bro} in
- Some t
- | None -> None ]
- | LocAct _ _ | DeadEnd -> None ]
+ begin match try_insert s sl bro with
+ Some bro ->
+ let t = Node {node = s1; son = son; brother = bro} in Some t
+ | None -> None
+ end
+ | LocAct (_, _) | DeadEnd -> None
in
insert gsymbols tree
-;
-value srules rl =
+let srules rl =
let t =
List.fold_left
(fun tree (symbols, action) -> insert_tree "" symbols action tree)
DeadEnd rl
in
Stree t
-;
-external action : 'a -> g_action = "%identity";
+external action : 'a -> g_action = "%identity"
-value is_level_labelled n lev =
+let is_level_labelled n lev =
match lev.lname with
- [ Some n1 -> n = n1
- | None -> False ]
-;
+ Some n1 -> n = n1
+ | None -> false
-value rec token_exists_in_level f lev =
+let rec token_exists_in_level f lev =
token_exists_in_tree f lev.lprefix || token_exists_in_tree f lev.lsuffix
and token_exists_in_tree f =
- fun
- [ Node n ->
+ function
+ Node n ->
token_exists_in_symbol f n.node || token_exists_in_tree f n.brother ||
token_exists_in_tree f n.son
- | LocAct _ _ | DeadEnd -> False ]
+ | LocAct (_, _) | DeadEnd -> false
and token_exists_in_symbol f =
- fun
- [ Sfacto sy -> token_exists_in_symbol f sy
- | Smeta _ syl _ -> List.exists (token_exists_in_symbol f) syl
+ function
+ Sfacto sy -> token_exists_in_symbol f sy
+ | Smeta (_, syl, _) -> List.exists (token_exists_in_symbol f) syl
| Slist0 sy -> token_exists_in_symbol f sy
- | Slist0sep sy sep _ ->
+ | Slist0sep (sy, sep, _) ->
token_exists_in_symbol f sy || token_exists_in_symbol f sep
| Slist1 sy -> token_exists_in_symbol f sy
- | Slist1sep sy sep _ ->
+ | Slist1sep (sy, sep, _) ->
token_exists_in_symbol f sy || token_exists_in_symbol f sep
| Sopt sy -> token_exists_in_symbol f sy
| Sflag sy -> token_exists_in_symbol f sy
| Stoken tok -> f tok
| Stree t -> token_exists_in_tree f t
- | Svala _ sy -> token_exists_in_symbol f sy
- | Snterm _ | Snterml _ _ | Snext | Sself | Scut -> False ]
-;
+ | Svala (_, sy) -> token_exists_in_symbol f sy
+ | Snterm _ | Snterml (_, _) | Snext | Sself | Scut -> false
-value insert_level entry_name e1 symbols action slev =
+let insert_level entry_name e1 symbols action slev =
match e1 with
- [ True ->
+ true ->
{assoc = slev.assoc; lname = slev.lname;
lsuffix = insert_tree entry_name symbols action slev.lsuffix;
lprefix = slev.lprefix}
- | False ->
+ | false ->
{assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
- lprefix = insert_tree entry_name symbols action slev.lprefix} ]
-;
+ lprefix = insert_tree entry_name symbols action slev.lprefix}
-value empty_lev lname assoc =
+let empty_lev lname assoc =
let assoc =
match assoc with
- [ Some a -> a
- | None -> LeftA ]
+ Some a -> a
+ | None -> LeftA
in
{assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
-;
-value change_lev lev n lname assoc = do {
+let change_lev lev n lname assoc =
let a =
match assoc with
- [ None -> lev.assoc
- | Some a -> do {
- if a <> lev.assoc && warning_verbose.val then do {
- eprintf "<W> Changing associativity of level \"%s\"\n" n;
- flush stderr
- }
- else ();
+ None -> lev.assoc
+ | Some a ->
+ if a <> lev.assoc && !warning_verbose then
+ begin
+ eprintf "<W> Changing associativity of level \"%s\"\n" n;
+ flush stderr
+ end;
a
- } ]
in
- match lname with
- [ Some n ->
- if lname <> lev.lname && warning_verbose.val then do {
- eprintf "<W> Level label \"%s\" ignored\n" n;
- flush stderr
- }
- else ()
- | None -> () ];
+ begin match lname with
+ Some n ->
+ if lname <> lev.lname && !warning_verbose then
+ begin eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr end
+ | None -> ()
+ end;
{assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix}
-};
-value get_level entry position levs =
+let get_level entry position levs =
match position with
- [ Some First -> ([], empty_lev, levs)
- | Some Last -> (levs, empty_lev, [])
+ Some First -> [], empty_lev, levs
+ | Some Last -> levs, empty_lev, []
| Some (Level n) ->
- get levs where rec get =
- fun
- [ [] -> do {
+ let rec get =
+ function
+ [] ->
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush stderr;
failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([], change_lev lev n, levs)
+ | lev :: levs ->
+ if is_level_labelled n lev then [], change_lev lev n, levs
else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
+ let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
+ in
+ get levs
| Some (Before n) ->
- get levs where rec get =
- fun
- [ [] -> do {
+ let rec get =
+ function
+ [] ->
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush stderr;
failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([], empty_lev, [lev :: levs])
+ | lev :: levs ->
+ if is_level_labelled n lev then [], empty_lev, lev :: levs
else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
+ let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
+ in
+ get levs
| Some (After n) ->
- get levs where rec get =
- fun
- [ [] -> do {
+ let rec get =
+ function
+ [] ->
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush stderr;
failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([lev], empty_lev, levs)
+ | lev :: levs ->
+ if is_level_labelled n lev then [lev], empty_lev, levs
else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
+ let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
+ in
+ get levs
| Some (Like n) ->
let f (tok, prm) = n = tok || n = prm in
- get levs where rec get =
- fun
- [ [] -> do {
+ let rec get =
+ function
+ [] ->
eprintf "No level with \"%s\" in entry \"%s\"\n" n entry.ename;
flush stderr;
failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if token_exists_in_level f lev then ([], change_lev lev n, levs)
+ | lev :: levs ->
+ if token_exists_in_level f lev then [], change_lev lev n, levs
else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
+ let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
+ in
+ get levs
| None ->
match levs with
- [ [lev :: levs] -> ([], change_lev lev "<top>", levs)
- | [] -> ([], empty_lev, []) ] ]
-;
+ lev :: levs -> [], change_lev lev "<top>", levs
+ | [] -> [], empty_lev, []
-value rec check_gram entry =
- fun
- [ Snterm e ->
- if e.egram != entry.egram then do {
- eprintf "\
+let rec check_gram entry =
+ function
+ Snterm e ->
+ if e.egram != entry.egram then
+ begin
+ eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- }
- else ()
- | Snterml e _ ->
- if e.egram != entry.egram then do {
- eprintf "\
+ entry.ename e.ename;
+ flush stderr;
+ failwith "Grammar.extend error"
+ end
+ | Snterml (e, _) ->
+ if e.egram != entry.egram then
+ begin
+ eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- }
- else ()
+ entry.ename e.ename;
+ flush stderr;
+ failwith "Grammar.extend error"
+ end
| Sfacto s -> check_gram entry s
- | Smeta _ sl _ -> List.iter (check_gram entry) sl
- | Slist0sep s t _ -> do { check_gram entry t; check_gram entry s }
- | Slist1sep s t _ -> do { check_gram entry t; check_gram entry s }
+ | Smeta (_, sl, _) -> List.iter (check_gram entry) sl
+ | Slist0sep (s, t, _) -> check_gram entry t; check_gram entry s
+ | Slist1sep (s, t, _) -> check_gram entry t; check_gram entry s
| Slist0 s -> check_gram entry s
| Slist1 s -> check_gram entry s
| Sopt s -> check_gram entry s
| Sflag s -> check_gram entry s
| Stree t -> tree_check_gram entry t
- | Svala _ s -> check_gram entry s
- | Snext | Sself | Scut | Stoken _ -> () ]
+ | Svala (_, s) -> check_gram entry s
+ | Snext | Sself | Scut | Stoken _ -> ()
and tree_check_gram entry =
- fun
- [ Node {node = n; brother = bro; son = son} -> do {
- check_gram entry n;
- tree_check_gram entry bro;
- tree_check_gram entry son
- }
- | LocAct _ _ | DeadEnd -> () ]
-;
+ function
+ Node {node = n; brother = bro; son = son} ->
+ check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son
+ | LocAct (_, _) | DeadEnd -> ()
-value change_to_self entry =
- fun
- [ Snterm e when e == entry -> Sself
- | x -> x ]
-;
+let change_to_self entry =
+ function
+ Snterm e when e == entry -> Sself
+ | x -> x
-value get_initial entry =
- fun
- [ [Sself :: symbols] -> (True, symbols)
- | symbols -> (False, symbols) ]
-;
+let get_initial entry =
+ function
+ Sself :: symbols -> true, symbols
+ | symbols -> false, symbols
-value insert_tokens gram symbols =
+let insert_tokens gram symbols =
let rec insert =
- fun
- [ Sfacto s -> insert s
- | Smeta _ sl _ -> List.iter insert sl
+ function
+ Sfacto s -> insert s
+ | Smeta (_, sl, _) -> List.iter insert sl
| Slist0 s -> insert s
| Slist1 s -> insert s
- | Slist0sep s t _ -> do { insert s; insert t }
- | Slist1sep s t _ -> do { insert s; insert t }
+ | Slist0sep (s, t, _) -> insert s; insert t
+ | Slist1sep (s, t, _) -> insert s; insert t
| Sopt s -> insert s
| Sflag s -> insert s
| Stree t -> tinsert t
- | Svala _ s -> insert s
+ | Svala (_, s) -> insert s
| Stoken ("ANY", _) -> ()
- | Stoken tok -> do {
+ | Stoken tok ->
gram.glexer.Plexing.tok_using tok;
let r =
try Hashtbl.find gram.gtokens tok with
- [ Not_found -> do {
- let r = ref 0 in
- Hashtbl.add gram.gtokens tok r;
- r
- } ]
+ Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r
in
incr r
- }
- | Snterm _ | Snterml _ _ | Snext | Sself | Scut -> () ]
+ | Snterm _ | Snterml (_, _) | Snext | Sself | Scut -> ()
and tinsert =
- fun
- [ Node {node = s; brother = bro; son = son} -> do {
- insert s;
- tinsert bro;
- tinsert son
- }
- | LocAct _ _ | DeadEnd -> () ]
+ function
+ Node {node = s; brother = bro; son = son} ->
+ insert s; tinsert bro; tinsert son
+ | LocAct (_, _) | DeadEnd -> ()
in
List.iter insert symbols
-;
-value levels_of_rules entry position rules =
+let levels_of_rules entry position rules =
let elev =
match entry.edesc with
- [ Dlevels elev -> elev
- | Dparser _ -> do {
+ Dlevels elev -> elev
+ | Dparser _ ->
eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
flush stderr;
failwith "Grammar.extend"
- } ]
in
if rules = [] then elev
else
@@ -452,47 +426,44 @@ value levels_of_rules entry position rules =
let lev = make_lev lname assoc in
let lev =
List.fold_left
- (fun lev (symbols, action) -> do {
+ (fun lev (symbols, action) ->
let symbols = List.map (change_to_self entry) symbols in
List.iter (check_gram entry) symbols;
let (e1, symbols) = get_initial entry symbols in
insert_tokens entry.egram symbols;
- insert_level entry.ename e1 symbols action lev
- })
+ insert_level entry.ename e1 symbols action lev)
lev level
in
- ([lev :: levs], empty_lev))
+ lev :: levs, empty_lev)
([], make_lev) rules
in
levs1 @ List.rev levs @ levs2
-;
-value logically_eq_symbols entry =
+let logically_eq_symbols entry =
let rec eq_symbols s1 s2 =
- match (s1, s2) with
- [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename
- | (Snterm e1, Sself) -> e1.ename = entry.ename
- | (Sself, Snterm e2) -> entry.ename = e2.ename
- | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2
- | (Slist0 s1, Slist0 s2) -> eq_symbols s1 s2
- | (Slist0sep s1 sep1 b1, Slist0sep s2 sep2 b2) ->
+ match s1, s2 with
+ Snterm e1, Snterm e2 -> e1.ename = e2.ename
+ | Snterm e1, Sself -> e1.ename = entry.ename
+ | Sself, Snterm e2 -> entry.ename = e2.ename
+ | Snterml (e1, l1), Snterml (e2, l2) -> e1.ename = e2.ename && l1 = l2
+ | Slist0 s1, Slist0 s2 -> eq_symbols s1 s2
+ | Slist0sep (s1, sep1, b1), Slist0sep (s2, sep2, b2) ->
eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2
- | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2
- | (Slist1sep s1 sep1 b1, Slist1sep s2 sep2 b2) ->
+ | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2
+ | Slist1sep (s1, sep1, b1), Slist1sep (s2, sep2, b2) ->
eq_symbols s1 s2 && eq_symbols sep1 sep2 && b1 = b2
- | (Sopt s1, Sopt s2) -> eq_symbols s1 s2
- | (Stree t1, Stree t2) -> eq_trees t1 t2
- | _ -> s1 = s2 ]
+ | Sopt s1, Sopt s2 -> eq_symbols s1 s2
+ | Stree t1, Stree t2 -> eq_trees t1 t2
+ | _ -> s1 = s2
and eq_trees t1 t2 =
- match (t1, t2) with
- [ (Node n1, Node n2) ->
+ match t1, t2 with
+ Node n1, Node n2 ->
eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&
eq_trees n1.brother n2.brother
- | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True
- | _ -> False ]
+ | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true
+ | _ -> false
in
eq_symbols
-;
(* [delete_rule_in_tree] returns
[Some (dsl, t)] if success
@@ -502,121 +473,118 @@ value logically_eq_symbols entry =
[t] = remaining tree
[None] if failure *)
-value delete_rule_in_tree entry =
+let delete_rule_in_tree entry =
let rec delete_in_tree symbols tree =
- match (symbols, tree) with
- [ ([s :: sl], Node n) ->
+ match symbols, tree with
+ s :: sl, Node n ->
if logically_eq_symbols entry s n.node then delete_son sl n
else
- match delete_in_tree symbols n.brother with
- [ Some (dsl, t) ->
+ begin match delete_in_tree symbols n.brother with
+ Some (dsl, t) ->
Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None ]
- | ([s :: sl], _) -> None
- | ([], Node n) ->
- match delete_in_tree [] n.brother with
- [ Some (dsl, t) ->
+ | None -> None
+ end
+ | s :: sl, _ -> None
+ | [], Node n ->
+ begin match delete_in_tree [] n.brother with
+ Some (dsl, t) ->
Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None ]
- | ([], DeadEnd) -> None
- | ([], LocAct _ []) -> Some (Some [], DeadEnd)
- | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ]
+ | None -> None
+ end
+ | [], DeadEnd -> None
+ | [], LocAct (_, []) -> Some (Some [], DeadEnd)
+ | [], LocAct (_, action :: list) -> Some (None, LocAct (action, list))
and delete_son sl n =
match delete_in_tree sl n.son with
- [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother)
+ Some (Some dsl, DeadEnd) -> Some (Some (n.node :: dsl), n.brother)
| Some (Some dsl, t) ->
let t = Node {node = n.node; son = t; brother = n.brother} in
- Some (Some [n.node :: dsl], t)
+ Some (Some (n.node :: dsl), t)
| Some (None, t) ->
let t = Node {node = n.node; son = t; brother = n.brother} in
Some (None, t)
- | None -> None ]
+ | None -> None
in
delete_in_tree
-;
-value rec decr_keyw_use gram =
- fun
- [ Stoken tok -> do {
+let rec decr_keyw_use gram =
+ function
+ Stoken tok ->
let r = Hashtbl.find gram.gtokens tok in
decr r;
- if r.val == 0 then do {
- Hashtbl.remove gram.gtokens tok;
- gram.glexer.Plexing.tok_removing tok
- }
- else ()
- }
+ if !r == 0 then
+ begin
+ Hashtbl.remove gram.gtokens tok;
+ gram.glexer.Plexing.tok_removing tok
+ end
| Sfacto s -> decr_keyw_use gram s
- | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl
+ | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl
| Slist0 s -> decr_keyw_use gram s
| Slist1 s -> decr_keyw_use gram s
- | Slist0sep s1 s2 _ -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
- | Slist1sep s1 s2 _ -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
+ | Slist0sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2
+ | Slist1sep (s1, s2, _) -> decr_keyw_use gram s1; decr_keyw_use gram s2
| Sopt s -> decr_keyw_use gram s
| Sflag s -> decr_keyw_use gram s
| Stree t -> decr_keyw_use_in_tree gram t
- | Svala _ s -> decr_keyw_use gram s
- | Sself | Snext | Scut | Snterm _ | Snterml _ _ -> () ]
+ | Svala (_, s) -> decr_keyw_use gram s
+ | Sself | Snext | Scut | Snterm _ | Snterml (_, _) -> ()
and decr_keyw_use_in_tree gram =
- fun
- [ DeadEnd | LocAct _ _ -> ()
- | Node n -> do {
+ function
+ DeadEnd | LocAct (_, _) -> ()
+ | Node n ->
decr_keyw_use gram n.node;
decr_keyw_use_in_tree gram n.son;
decr_keyw_use_in_tree gram n.brother
- } ]
-;
-value rec delete_rule_in_suffix entry symbols =
- fun
- [ [lev :: levs] ->
- match delete_rule_in_tree entry symbols lev.lsuffix with
- [ Some (dsl, t) -> do {
- match dsl with
- [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> () ];
- match t with
- [ DeadEnd when lev.lprefix == DeadEnd -> levs
+let rec delete_rule_in_suffix entry symbols =
+ function
+ lev :: levs ->
+ begin match delete_rule_in_tree entry symbols lev.lsuffix with
+ Some (dsl, t) ->
+ begin match dsl with
+ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
+ | None -> ()
+ end;
+ begin match t with
+ DeadEnd when lev.lprefix == DeadEnd -> levs
| _ ->
let lev =
{assoc = lev.assoc; lname = lev.lname; lsuffix = t;
lprefix = lev.lprefix}
in
- [lev :: levs] ]
- }
+ lev :: levs
+ end
| None ->
- let levs = delete_rule_in_suffix entry symbols levs in
- [lev :: levs] ]
- | [] -> raise Not_found ]
-;
+ let levs = delete_rule_in_suffix entry symbols levs in lev :: levs
+ end
+ | [] -> raise Not_found
-value rec delete_rule_in_prefix entry symbols =
- fun
- [ [lev :: levs] ->
- match delete_rule_in_tree entry symbols lev.lprefix with
- [ Some (dsl, t) -> do {
- match dsl with
- [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> () ];
- match t with
- [ DeadEnd when lev.lsuffix == DeadEnd -> levs
+let rec delete_rule_in_prefix entry symbols =
+ function
+ lev :: levs ->
+ begin match delete_rule_in_tree entry symbols lev.lprefix with
+ Some (dsl, t) ->
+ begin match dsl with
+ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
+ | None -> ()
+ end;
+ begin match t with
+ DeadEnd when lev.lsuffix == DeadEnd -> levs
| _ ->
let lev =
{assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix;
lprefix = t}
in
- [lev :: levs] ]
- }
+ lev :: levs
+ end
| None ->
- let levs = delete_rule_in_prefix entry symbols levs in
- [lev :: levs] ]
- | [] -> raise Not_found ]
-;
+ let levs = delete_rule_in_prefix entry symbols levs in lev :: levs
+ end
+ | [] -> raise Not_found
-value rec delete_rule_in_level_list entry symbols levs =
+let rec delete_rule_in_level_list entry symbols levs =
match symbols with
- [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs
- | [Snterm e :: symbols] when e == entry ->
+ Sself :: symbols -> delete_rule_in_suffix entry symbols levs
+ | Snterm e :: symbols when e == entry ->
delete_rule_in_suffix entry symbols levs
- | _ -> delete_rule_in_prefix entry symbols levs ]
-;
+ | _ -> delete_rule_in_prefix entry symbols levs
diff --git a/gramlib/gramext.mli b/gramlib/gramext.mli
index 69498f6d40..0852709bf4 100644
--- a/gramlib/gramext.mli
+++ b/gramlib/gramext.mli
@@ -2,86 +2,82 @@
(* gramext.mli,v *)
(* Copyright (c) INRIA 2007-2017 *)
-type parser_t 'a = Stream.t 'a -> Obj.t;
-type fparser_t 'a = Fstream.t 'a -> option (Obj.t * Fstream.t 'a);
-type bparser_t 'a = Fstream.bp 'a Obj.t;
+type 'a parser_t = 'a Stream.t -> Obj.t
+type 'a fparser_t = 'a Fstream.t -> (Obj.t * 'a Fstream.t) option
+type 'a bparser_t = ('a, Obj.t) Fstream.bp
type parse_algorithm =
- [ Predictive | Functional | Backtracking | DefaultAlgorithm ];
+ Predictive | Functional | Backtracking | DefaultAlgorithm
-type grammar 'te =
- { gtokens : Hashtbl.t Plexing.pattern (ref int);
- glexer : mutable Plexing.lexer 'te;
- galgo : mutable parse_algorithm }
-;
+type 'te grammar =
+ { gtokens : (Plexing.pattern, int ref) Hashtbl.t;
+ mutable glexer : 'te Plexing.lexer;
+ mutable galgo : parse_algorithm }
-type g_entry 'te =
- { egram : grammar 'te;
+type 'te g_entry =
+ { egram : 'te grammar;
ename : string;
elocal : bool;
- estart : mutable int -> parser_t 'te;
- econtinue : mutable int -> int -> Obj.t -> parser_t 'te;
- fstart : mutable int -> err_fun -> fparser_t 'te;
- fcontinue : mutable int -> int -> Obj.t -> err_fun -> fparser_t 'te;
- bstart : mutable int -> err_fun -> bparser_t 'te;
- bcontinue : mutable int -> int -> Obj.t -> err_fun -> bparser_t 'te;
- edesc : mutable g_desc 'te }
-and g_desc 'te =
- [ Dlevels of list (g_level 'te)
- | Dparser of parser_t 'te ]
-and g_level 'te =
+ mutable estart : int -> 'te parser_t;
+ mutable econtinue : int -> int -> Obj.t -> 'te parser_t;
+ mutable fstart : int -> err_fun -> 'te fparser_t;
+ mutable fcontinue : int -> int -> Obj.t -> err_fun -> 'te fparser_t;
+ mutable bstart : int -> err_fun -> 'te bparser_t;
+ mutable bcontinue : int -> int -> Obj.t -> err_fun -> 'te bparser_t;
+ mutable edesc : 'te g_desc }
+and 'te g_desc =
+ Dlevels of 'te g_level list
+ | Dparser of 'te parser_t
+and 'te g_level =
{ assoc : g_assoc;
- lname : option string;
- lsuffix : g_tree 'te;
- lprefix : g_tree 'te }
-and g_assoc = [ NonA | RightA | LeftA ]
-and g_symbol 'te =
- [ Sfacto of g_symbol 'te
- | Smeta of string and list (g_symbol 'te) and Obj.t
- | Snterm of g_entry 'te
- | Snterml of g_entry 'te and string
- | Slist0 of g_symbol 'te
- | Slist0sep of g_symbol 'te and g_symbol 'te and bool
- | Slist1 of g_symbol 'te
- | Slist1sep of g_symbol 'te and g_symbol 'te and bool
- | Sopt of g_symbol 'te
- | Sflag of g_symbol 'te
+ lname : string option;
+ lsuffix : 'te g_tree;
+ lprefix : 'te g_tree }
+and g_assoc = NonA | RightA | LeftA
+and 'te g_symbol =
+ Sfacto of 'te g_symbol
+ | Smeta of string * 'te g_symbol list * Obj.t
+ | Snterm of 'te g_entry
+ | Snterml of 'te g_entry * string
+ | Slist0 of 'te g_symbol
+ | Slist0sep of 'te g_symbol * 'te g_symbol * bool
+ | Slist1 of 'te g_symbol
+ | Slist1sep of 'te g_symbol * 'te g_symbol * bool
+ | Sopt of 'te g_symbol
+ | Sflag of 'te g_symbol
| Sself
| Snext
| Scut
| Stoken of Plexing.pattern
- | Stree of g_tree 'te
- | Svala of list string and g_symbol 'te ]
+ | Stree of 'te g_tree
+ | Svala of string list * 'te g_symbol
and g_action = Obj.t
-and g_tree 'te =
- [ Node of g_node 'te
- | LocAct of g_action and list g_action
- | DeadEnd ]
-and g_node 'te =
- { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te }
-and err_fun = unit -> string;
+and 'te g_tree =
+ Node of 'te g_node
+ | LocAct of g_action * g_action list
+ | DeadEnd
+and 'te g_node =
+ { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree }
+and err_fun = unit -> string
type position =
- [ First
+ First
| Last
| Before of string
| After of string
| Like of string
- | Level of string ]
-;
+ | Level of string
-value levels_of_rules :
- g_entry 'te -> option position ->
- list
- (option string * option g_assoc *
- list (list (g_symbol 'te) * g_action)) ->
- list (g_level 'te);
-value srules : list (list (g_symbol 'te) * g_action) -> g_symbol 'te;
-external action : 'a -> g_action = "%identity";
-value eq_symbol : g_symbol 'a -> g_symbol 'a -> bool;
+val levels_of_rules :
+ 'te g_entry -> position option ->
+ (string option * g_assoc option * ('te g_symbol list * g_action) list)
+ list ->
+ 'te g_level list
+val srules : ('te g_symbol list * g_action) list -> 'te g_symbol
+external action : 'a -> g_action = "%identity"
+val eq_symbol : 'a g_symbol -> 'a g_symbol -> bool
-value delete_rule_in_level_list :
- g_entry 'te -> list (g_symbol 'te) -> list (g_level 'te) ->
- list (g_level 'te);
+val delete_rule_in_level_list :
+ 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list
-value warning_verbose : ref bool;
+val warning_verbose : bool ref
diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml
index d6a2019c20..8e33d860bd 100644
--- a/gramlib/grammar.ml
+++ b/gramlib/grammar.ml
@@ -2,87 +2,88 @@
(* grammar.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)
-#load "pa_fstream.cmo";
+(* #load "pa_fstream.cmo" *)
-value pervasives_stderr = stderr;
+let pervasives_stderr = stderr
-open Gramext;
-open Format;
+open Gramext
+open Format
-value stderr = pervasives_stderr;
+let stderr = pervasives_stderr
-value rec flatten_tree =
- fun
- [ DeadEnd -> []
- | LocAct _ _ -> [[]]
+let rec flatten_tree =
+ function
+ DeadEnd -> []
+ | LocAct (_, _) -> [[]]
| Node {node = n; brother = b; son = s} ->
- List.map (fun l -> [n :: l]) (flatten_tree s) @ flatten_tree b ]
-;
+ List.map (fun l -> n :: l) (flatten_tree s) @ flatten_tree b
-value utf8_print = ref True;
+let utf8_print = ref true
-value utf8_string_escaped s =
+let utf8_string_escaped s =
let b = Buffer.create (String.length s) in
- loop 0 where rec loop i =
+ let rec loop i =
if i = String.length s then Buffer.contents b
- else do {
- match s.[i] with
- | '"' → Buffer.add_string b "\\\""
- | '\\' → Buffer.add_string b "\\\\"
- | '\n' → Buffer.add_string b "\\n"
- | '\t' → Buffer.add_string b "\\t"
- | '\r' → Buffer.add_string b "\\r"
- | '\b' → Buffer.add_string b "\\b"
- | c → Buffer.add_char b c
- end;
- loop (i + 1)
- }
-;
-
-value string_escaped s =
- if utf8_print.val then utf8_string_escaped s
- else String.escaped s
-;
-
-value print_str ppf s = fprintf ppf "\"%s\"" (string_escaped s);
-
-value rec print_symbol ppf =
- fun
- [ Sfacto s -> print_symbol ppf s
- | Smeta n sl _ -> print_meta ppf n sl
+ else
+ begin
+ begin match s.[i] with
+ '"' -> Buffer.add_string b "\\\""
+ | '\\' -> Buffer.add_string b "\\\\"
+ | '\n' -> Buffer.add_string b "\\n"
+ | '\t' -> Buffer.add_string b "\\t"
+ | '\r' -> Buffer.add_string b "\\r"
+ | '\b' -> Buffer.add_string b "\\b"
+ | c -> Buffer.add_char b c
+ end;
+ loop (i + 1)
+ end
+ in
+ loop 0
+
+let string_escaped s =
+ if !utf8_print then utf8_string_escaped s else String.escaped s
+
+let print_str ppf s = fprintf ppf "\"%s\"" (string_escaped s)
+
+let rec print_symbol ppf =
+ function
+ Sfacto s -> print_symbol ppf s
+ | Smeta (n, sl, _) -> print_meta ppf n sl
| Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
- | Slist0sep s t osep ->
+ | Slist0sep (s, t, osep) ->
fprintf ppf "LIST0 %a SEP %a%s" print_symbol1 s print_symbol1 t
(if osep then " OPT_SEP" else "")
| Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
- | Slist1sep s t osep ->
+ | Slist1sep (s, t, osep) ->
fprintf ppf "LIST1 %a SEP %a%s" print_symbol1 s print_symbol1 t
(if osep then " OPT_SEP" else "")
| Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
| Sflag s -> fprintf ppf "FLAG %a" print_symbol1 s
| Stoken (con, prm) when con <> "" && prm <> "" ->
fprintf ppf "%s@ %a" con print_str prm
- | Svala _ s -> fprintf ppf "V %a" print_symbol s
- | Snterml e l ->
+ | Svala (_, s) -> fprintf ppf "V %a" print_symbol s
+ | Snterml (e, l) ->
fprintf ppf "%s%s@ LEVEL@ %a" e.ename (if e.elocal then "*" else "")
print_str l
| Snterm _ | Snext | Sself | Scut | Stoken _ | Stree _ as s ->
- print_symbol1 ppf s ]
+ print_symbol1 ppf s
and print_meta ppf n sl =
- loop 0 sl where rec loop i =
- fun
- [ [] -> ()
- | [s :: sl] -> do {
+ let rec loop i =
+ function
+ [] -> ()
+ | s :: sl ->
let j =
- try String.index_from n i ' ' with [ Not_found -> String.length n ]
+ try String.index_from n i ' ' with Not_found -> String.length n
in
fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
if sl = [] then ()
- else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
- } ]
+ else
+ begin fprintf ppf " "; loop (min (j + 1) (String.length n)) sl end
+ in
+ loop 0 sl
and print_symbol1 ppf =
- fun
- [ Sfacto s -> print_symbol1 ppf s
+ function
+ Sfacto s -> print_symbol1 ppf s
| Snterm e -> fprintf ppf "%s%s" e.ename (if e.elocal then "*" else "")
| Sself -> pp_print_string ppf "SELF"
| Snext -> pp_print_string ppf "NEXT"
@@ -90,210 +91,197 @@ and print_symbol1 ppf =
| Stoken ("", s) -> print_str ppf s
| Stoken (con, "") -> pp_print_string ppf con
| Stree t -> print_level ppf pp_print_space (flatten_tree t)
- | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ _ | Slist1 _ |
- Slist1sep _ _ _ | Sopt _ | Sflag _ | Stoken _ | Svala _ _ as s ->
- fprintf ppf "(%a)" print_symbol s ]
-and print_rule ppf symbols = do {
+ | Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _, _) |
+ Slist1 _ | Slist1sep (_, _, _) | Sopt _ | Sflag _ | Stoken _ |
+ Svala (_, _) as s ->
+ fprintf ppf "(%a)" print_symbol s
+and print_rule ppf symbols =
fprintf ppf "@[<hov 0>";
let _ =
List.fold_left
- (fun sep symbol -> do {
+ (fun sep symbol ->
fprintf ppf "%t%a" sep print_symbol symbol;
- fun ppf -> fprintf ppf ";@ "
- })
+ fun ppf -> fprintf ppf ";@ ")
(fun ppf -> ()) symbols
in
fprintf ppf "@]"
-}
-and print_level ppf pp_print_space rules = do {
+and print_level ppf pp_print_space rules =
fprintf ppf "@[<hov 0>[ ";
let _ =
List.fold_left
- (fun sep rule -> do {
+ (fun sep rule ->
fprintf ppf "%t%a" sep print_rule rule;
- fun ppf -> fprintf ppf "%a| " pp_print_space ()
- })
+ fun ppf -> fprintf ppf "%a| " pp_print_space ())
(fun ppf -> ()) rules
in
fprintf ppf " ]@]"
-};
-value print_levels ppf elev =
+let print_levels ppf elev =
let _ =
List.fold_left
- (fun sep lev -> do {
+ (fun sep lev ->
let rules =
- List.map (fun t -> [Sself :: t]) (flatten_tree lev.lsuffix) @
+ List.map (fun t -> Sself :: t) (flatten_tree lev.lsuffix) @
flatten_tree lev.lprefix
in
fprintf ppf "%t@[<hov 2>" sep;
- match lev.lname with
- [ Some n -> fprintf ppf "%a@;<1 2>" print_str n
- | None -> () ];
- match lev.assoc with
- [ LeftA -> fprintf ppf "LEFTA"
+ begin match lev.lname with
+ Some n -> fprintf ppf "%a@;<1 2>" print_str n
+ | None -> ()
+ end;
+ begin match lev.assoc with
+ LeftA -> fprintf ppf "LEFTA"
| RightA -> fprintf ppf "RIGHTA"
- | NonA -> fprintf ppf "NONA" ];
+ | NonA -> fprintf ppf "NONA"
+ end;
fprintf ppf "@]@;<1 2>";
print_level ppf pp_force_newline rules;
- fun ppf -> fprintf ppf "@,| "
- })
+ fun ppf -> fprintf ppf "@,| ")
(fun ppf -> ()) elev
in
()
-;
-value print_entry ppf e = do {
+let print_entry ppf e =
fprintf ppf "@[<v 0>[ ";
- match e.edesc with
- [ Dlevels elev -> print_levels ppf elev
- | Dparser _ -> fprintf ppf "<parser>" ];
+ begin match e.edesc with
+ Dlevels elev -> print_levels ppf elev
+ | Dparser _ -> fprintf ppf "<parser>"
+ end;
fprintf ppf " ]@]"
-};
-value iter_entry f e =
+let iter_entry f e =
let treated = ref [] in
let rec do_entry e =
- if List.memq e treated.val then ()
- else do {
- treated.val := [e :: treated.val];
- f e;
- match e.edesc with
- [ Dlevels ll -> List.iter do_level ll
- | Dparser _ -> () ]
- }
- and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix }
+ if List.memq e !treated then ()
+ else
+ begin
+ treated := e :: !treated;
+ f e;
+ match e.edesc with
+ Dlevels ll -> List.iter do_level ll
+ | Dparser _ -> ()
+ end
+ and do_level lev = do_tree lev.lsuffix; do_tree lev.lprefix
and do_tree =
- fun
- [ Node n -> do_node n
- | LocAct _ _ | DeadEnd -> () ]
- and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother }
+ function
+ Node n -> do_node n
+ | LocAct (_, _) | DeadEnd -> ()
+ and do_node n = do_symbol n.node; do_tree n.son; do_tree n.brother
and do_symbol =
- fun
- [ Sfacto s -> do_symbol s
- | Smeta _ sl _ -> List.iter do_symbol sl
+ function
+ Sfacto s -> do_symbol s
+ | Smeta (_, sl, _) -> List.iter do_symbol sl
| Snterm e -> do_entry e
- | Snterml e _ -> do_entry e
+ | Snterml (e, _) -> do_entry e
| Slist0 s -> do_symbol s
| Slist1 s -> do_symbol s
| Sopt s -> do_symbol s
| Sflag s -> do_symbol s
- | Slist0sep s1 s2 _ -> do { do_symbol s1; do_symbol s2 }
- | Slist1sep s1 s2 _ -> do { do_symbol s1; do_symbol s2 }
+ | Slist0sep (s1, s2, _) -> do_symbol s1; do_symbol s2
+ | Slist1sep (s1, s2, _) -> do_symbol s1; do_symbol s2
| Stree t -> do_tree t
- | Svala _ s -> do_symbol s
- | Sself | Snext | Scut | Stoken _ -> () ]
+ | Svala (_, s) -> do_symbol s
+ | Sself | Snext | Scut | Stoken _ -> ()
in
do_entry e
-;
-value fold_entry f e init =
+let fold_entry f e init =
let treated = ref [] in
let rec do_entry accu e =
- if List.memq e treated.val then accu
- else do {
- treated.val := [e :: treated.val];
- let accu = f e accu in
- match e.edesc with
- [ Dlevels ll -> List.fold_left do_level accu ll
- | Dparser _ -> accu ]
- }
+ if List.memq e !treated then accu
+ else
+ begin
+ treated := e :: !treated;
+ let accu = f e accu in
+ match e.edesc with
+ Dlevels ll -> List.fold_left do_level accu ll
+ | Dparser _ -> accu
+ end
and do_level accu lev =
- let accu = do_tree accu lev.lsuffix in
- do_tree accu lev.lprefix
+ let accu = do_tree accu lev.lsuffix in do_tree accu lev.lprefix
and do_tree accu =
- fun
- [ Node n -> do_node accu n
- | LocAct _ _ | DeadEnd -> accu ]
+ function
+ Node n -> do_node accu n
+ | LocAct (_, _) | DeadEnd -> accu
and do_node accu n =
let accu = do_symbol accu n.node in
- let accu = do_tree accu n.son in
- do_tree accu n.brother
+ let accu = do_tree accu n.son in do_tree accu n.brother
and do_symbol accu =
- fun
- [ Sfacto s -> do_symbol accu s
- | Smeta _ sl _ -> List.fold_left do_symbol accu sl
+ function
+ Sfacto s -> do_symbol accu s
+ | Smeta (_, sl, _) -> List.fold_left do_symbol accu sl
| Snterm e -> do_entry accu e
- | Snterml e _ -> do_entry accu e
+ | Snterml (e, _) -> do_entry accu e
| Slist0 s -> do_symbol accu s
| Slist1 s -> do_symbol accu s
| Sopt s -> do_symbol accu s
| Sflag s -> do_symbol accu s
- | Slist0sep s1 s2 _ -> do_symbol (do_symbol accu s1) s2
- | Slist1sep s1 s2 _ -> do_symbol (do_symbol accu s1) s2
+ | Slist0sep (s1, s2, _) -> do_symbol (do_symbol accu s1) s2
+ | Slist1sep (s1, s2, _) -> do_symbol (do_symbol accu s1) s2
| Stree t -> do_tree accu t
- | Svala _ s -> do_symbol accu s
- | Sself | Snext | Scut | Stoken _ -> accu ]
+ | Svala (_, s) -> do_symbol accu s
+ | Sself | Snext | Scut | Stoken _ -> accu
in
do_entry init e
-;
-value floc = ref (fun _ -> failwith "internal error when computing location");
+let floc = ref (fun _ -> failwith "internal error when computing location")
-value loc_of_token_interval bp ep =
+let loc_of_token_interval bp ep =
if bp == ep then
- if bp == 0 then Ploc.dummy
- else Ploc.after (floc.val (bp - 1)) 0 1
+ if bp == 0 then Ploc.dummy else Ploc.after (!floc (bp - 1)) 0 1
else
- let loc1 = floc.val bp in
- let loc2 = floc.val (pred ep) in
- Ploc.encl loc1 loc2
-;
-
-value rec name_of_symbol entry =
- fun
- [ Snterm e -> "[" ^ e.ename ^ "]"
- | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]"
+ let loc1 = !floc bp in let loc2 = !floc (pred ep) in Ploc.encl loc1 loc2
+
+let rec name_of_symbol entry =
+ function
+ Snterm e -> "[" ^ e.ename ^ "]"
+ | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]"
| Sself | Snext -> "[" ^ entry.ename ^ "]"
| Stoken tok -> entry.egram.glexer.Plexing.tok_text tok
- | _ -> "???" ]
-;
+ | _ -> "???"
-value rec get_token_list entry rev_tokl last_tok tree =
+let rec get_token_list entry rev_tokl last_tok tree =
match tree with
- [ Node {node = Stoken tok; son = son; brother = DeadEnd} ->
- get_token_list entry [last_tok :: rev_tokl] (tok, None) son
- | Node {node = Svala ls (Stoken tok); son = son; brother = DeadEnd} ->
- get_token_list entry [last_tok :: rev_tokl] (tok, Some ls) son
- | _ ->
- if rev_tokl = [] then None
- else Some (rev_tokl, last_tok, tree) ]
-;
-
-value rec name_of_symbol_failed entry =
- fun
- [ Sfacto s -> name_of_symbol_failed entry s
+ Node {node = Stoken tok; son = son; brother = DeadEnd} ->
+ get_token_list entry (last_tok :: rev_tokl) (tok, None) son
+ | Node {node = Svala (ls, Stoken tok); son = son; brother = DeadEnd} ->
+ get_token_list entry (last_tok :: rev_tokl) (tok, Some ls) son
+ | _ -> if rev_tokl = [] then None else Some (rev_tokl, last_tok, tree)
+
+let rec name_of_symbol_failed entry =
+ function
+ Sfacto s -> name_of_symbol_failed entry s
| Slist0 s -> name_of_symbol_failed entry s
- | Slist0sep s _ _ -> name_of_symbol_failed entry s
+ | Slist0sep (s, _, _) -> name_of_symbol_failed entry s
| Slist1 s -> name_of_symbol_failed entry s
- | Slist1sep s _ _ -> name_of_symbol_failed entry s
+ | Slist1sep (s, _, _) -> name_of_symbol_failed entry s
| Sopt s -> name_of_symbol_failed entry s
| Sflag s -> name_of_symbol_failed entry s
| Stree t -> name_of_tree_failed entry t
- | Svala _ s -> name_of_symbol_failed entry s
- | Smeta _ [s :: _] _ -> name_of_symbol_failed entry s
- | s -> name_of_symbol entry s ]
+ | Svala (_, s) -> name_of_symbol_failed entry s
+ | Smeta (_, s :: _, _) -> name_of_symbol_failed entry s
+ | s -> name_of_symbol entry s
and name_of_tree_failed entry =
- fun
- [ Node {node = s; brother = bro; son = son} ->
+ function
+ Node {node = s; brother = bro; son = son} ->
let tokl =
match s with
- [ Stoken tok -> get_token_list entry [] (tok, None) son
- | Svala ls (Stoken tok) -> get_token_list entry [] (tok, Some ls) son
- | _ -> None ]
+ Stoken tok -> get_token_list entry [] (tok, None) son
+ | Svala (ls, Stoken tok) -> get_token_list entry [] (tok, Some ls) son
+ | _ -> None
in
- match tokl with
- [ None ->
+ begin match tokl with
+ None ->
let txt = name_of_symbol_failed entry s in
let txt =
- match (s, son) with
- [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son
- | _ -> txt ]
+ match s, son with
+ Sopt _, Node _ -> txt ^ " or " ^ name_of_tree_failed entry son
+ | _ -> txt
in
let txt =
match bro with
- [ DeadEnd | LocAct _ _ -> txt
- | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ]
+ DeadEnd | LocAct (_, _) -> txt
+ | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro
in
txt
| Some (rev_tokl, last_tok, son) ->
@@ -301,426 +289,417 @@ and name_of_tree_failed entry =
(fun s (tok, _) ->
(if s = "" then "" else s ^ " ") ^
entry.egram.glexer.Plexing.tok_text tok)
- "" (List.rev [last_tok :: rev_tokl]) ]
- | DeadEnd | LocAct _ _ -> "???" ]
-;
+ "" (List.rev (last_tok :: rev_tokl))
+ end
+ | DeadEnd | LocAct (_, _) -> "???"
-value search_tree_in_entry prev_symb tree =
- fun
- [ Dlevels levels ->
+let search_tree_in_entry prev_symb tree =
+ function
+ Dlevels levels ->
let rec search_levels =
- fun
- [ [] -> tree
- | [level :: levels] ->
+ function
+ [] -> tree
+ | level :: levels ->
match search_level level with
- [ Some tree -> tree
- | None -> search_levels levels ] ]
+ Some tree -> tree
+ | None -> search_levels levels
and search_level level =
match search_tree level.lsuffix with
- [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd})
- | None -> search_tree level.lprefix ]
+ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd})
+ | None -> search_tree level.lprefix
and search_tree t =
if tree <> DeadEnd && t == tree then Some t
else
match t with
- [ Node n ->
- match search_symbol n.node with
- [ Some symb ->
+ Node n ->
+ begin match search_symbol n.node with
+ Some symb ->
Some (Node {node = symb; son = n.son; brother = DeadEnd})
| None ->
match search_tree n.son with
- [ Some t ->
+ Some t ->
Some (Node {node = n.node; son = t; brother = DeadEnd})
- | None -> search_tree n.brother ] ]
- | LocAct _ _ | DeadEnd -> None ]
+ | None -> search_tree n.brother
+ end
+ | LocAct (_, _) | DeadEnd -> None
and search_symbol symb =
match symb with
- [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ _ | Slist1 _ |
- Slist1sep _ _ _ | Sopt _ | Stoken _ | Stree _
+ Snterm _ | Snterml (_, _) | Slist0 _ | Slist0sep (_, _, _) |
+ Slist1 _ | Slist1sep (_, _, _) | Sopt _ | Stoken _ | Stree _
when symb == prev_symb ->
Some symb
| Slist0 symb ->
- match search_symbol symb with
- [ Some symb -> Some (Slist0 symb)
- | None -> None ]
- | Slist0sep symb sep b ->
- match search_symbol symb with
- [ Some symb -> Some (Slist0sep symb sep b)
+ begin match search_symbol symb with
+ Some symb -> Some (Slist0 symb)
+ | None -> None
+ end
+ | Slist0sep (symb, sep, b) ->
+ begin match search_symbol symb with
+ Some symb -> Some (Slist0sep (symb, sep, b))
| None ->
match search_symbol sep with
- [ Some sep -> Some (Slist0sep symb sep b)
- | None -> None ] ]
+ Some sep -> Some (Slist0sep (symb, sep, b))
+ | None -> None
+ end
| Slist1 symb ->
- match search_symbol symb with
- [ Some symb -> Some (Slist1 symb)
- | None -> None ]
- | Slist1sep symb sep b ->
- match search_symbol symb with
- [ Some symb -> Some (Slist1sep symb sep b)
+ begin match search_symbol symb with
+ Some symb -> Some (Slist1 symb)
+ | None -> None
+ end
+ | Slist1sep (symb, sep, b) ->
+ begin match search_symbol symb with
+ Some symb -> Some (Slist1sep (symb, sep, b))
| None ->
match search_symbol sep with
- [ Some sep -> Some (Slist1sep symb sep b)
- | None -> None ] ]
+ Some sep -> Some (Slist1sep (symb, sep, b))
+ | None -> None
+ end
| Sopt symb ->
- match search_symbol symb with
- [ Some symb -> Some (Sopt symb)
- | None -> None ]
+ begin match search_symbol symb with
+ Some symb -> Some (Sopt symb)
+ | None -> None
+ end
| Stree t ->
- match search_tree t with
- [ Some t -> Some (Stree t)
- | None -> None ]
- | _ -> None ]
+ begin match search_tree t with
+ Some t -> Some (Stree t)
+ | None -> None
+ end
+ | _ -> None
in
search_levels levels
- | Dparser _ -> tree ]
-;
+ | Dparser _ -> tree
-value error_verbose = ref False;
+let error_verbose = ref false
-value tree_failed entry prev_symb_result prev_symb tree = do {
+let tree_failed entry prev_symb_result prev_symb tree =
let txt = name_of_tree_failed entry tree in
let txt =
match prev_symb with
- [ Slist0 s ->
+ Slist0 s ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
| Slist1 s ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
- | Slist0sep s sep _ ->
- match Obj.magic prev_symb_result with
- [ [] ->
+ | Slist0sep (s, sep, _) ->
+ begin match Obj.magic prev_symb_result with
+ [] ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
| _ ->
let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected" ]
- | Slist1sep s sep _ ->
- match Obj.magic prev_symb_result with
- [ [] ->
+ txt1 ^ " or " ^ txt ^ " expected"
+ end
+ | Slist1sep (s, sep, _) ->
+ begin match Obj.magic prev_symb_result with
+ [] ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
| _ ->
let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected" ]
- | Sopt _ | Sflag _ | Stree _ | Svala _ _ -> txt ^ " expected"
- | _ -> txt ^ " expected after " ^ name_of_symbol_failed entry prev_symb ]
+ txt1 ^ " or " ^ txt ^ " expected"
+ end
+ | Sopt _ | Sflag _ | Stree _ | Svala (_, _) -> txt ^ " expected"
+ | _ -> txt ^ " expected after " ^ name_of_symbol_failed entry prev_symb
in
- if error_verbose.val then do {
- let tree = search_tree_in_entry prev_symb tree entry.edesc in
- let ppf = err_formatter in
- fprintf ppf "@[<v 0>@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename;
- fprintf ppf "@[";
- print_level ppf pp_force_newline (flatten_tree tree);
- fprintf ppf "@]@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "@]@."
- }
- else ();
+ if !error_verbose then
+ begin let tree = search_tree_in_entry prev_symb tree entry.edesc in
+ let ppf = err_formatter in
+ fprintf ppf "@[<v 0>@,";
+ fprintf ppf "----------------------------------@,";
+ fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename;
+ fprintf ppf "@[";
+ print_level ppf pp_force_newline (flatten_tree tree);
+ fprintf ppf "@]@,";
+ fprintf ppf "----------------------------------@,";
+ fprintf ppf "@]@."
+ end;
txt ^ " (in [" ^ entry.ename ^ "])"
-};
-value symb_failed entry prev_symb_result prev_symb symb =
+let symb_failed entry prev_symb_result prev_symb symb =
let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in
tree_failed entry prev_symb_result prev_symb tree
-;
-external app : Obj.t -> 'a = "%identity";
+external app : Obj.t -> 'a = "%identity"
-value is_level_labelled n lev =
+let is_level_labelled n lev =
match lev.lname with
- [ Some n1 -> n = n1
- | None -> False ]
-;
+ Some n1 -> n = n1
+ | None -> false
-value level_number entry lab =
+let level_number entry lab =
let rec lookup levn =
- fun
- [ [] -> failwith ("unknown level " ^ lab)
- | [lev :: levs] ->
- if is_level_labelled lab lev then levn else lookup (succ levn) levs ]
+ function
+ [] -> failwith ("unknown level " ^ lab)
+ | lev :: levs ->
+ if is_level_labelled lab lev then levn else lookup (succ levn) levs
in
match entry.edesc with
- [ Dlevels elev -> lookup 0 elev
- | Dparser _ -> raise Not_found ]
-;
-
-value rec top_symb entry =
- fun
- [ Sself | Snext -> Snterm entry
- | Snterml e _ -> Snterm e
- | Slist1sep s sep b -> Slist1sep (top_symb entry s) sep b
- | _ -> raise Stream.Failure ]
-;
-
-value entry_of_symb entry =
- fun
- [ Sself | Snext -> entry
+ Dlevels elev -> lookup 0 elev
+ | Dparser _ -> raise Not_found
+
+let rec top_symb entry =
+ function
+ Sself | Snext -> Snterm entry
+ | Snterml (e, _) -> Snterm e
+ | Slist1sep (s, sep, b) -> Slist1sep (top_symb entry s, sep, b)
+ | _ -> raise Stream.Failure
+
+let entry_of_symb entry =
+ function
+ Sself | Snext -> entry
| Snterm e -> e
- | Snterml e _ -> e
- | _ -> raise Stream.Failure ]
-;
+ | Snterml (e, _) -> e
+ | _ -> raise Stream.Failure
-value top_tree entry =
- fun
- [ Node {node = s; brother = bro; son = son} ->
+let top_tree entry =
+ function
+ Node {node = s; brother = bro; son = son} ->
Node {node = top_symb entry s; brother = bro; son = son}
- | LocAct _ _ | DeadEnd -> raise Stream.Failure ]
-;
+ | LocAct (_, _) | DeadEnd -> raise Stream.Failure
-value skip_if_empty bp p strm =
+let skip_if_empty bp p strm =
if Stream.count strm == bp then Gramext.action (fun a -> p strm)
else raise Stream.Failure
-;
-
-value continue entry bp a s son p1 =
- parser
- [: a = (entry_of_symb entry s).econtinue 0 bp a;
- act = p1 ? tree_failed entry a s son :] ->
- Gramext.action (fun _ -> app act a)
-;
-
-value do_recover parser_of_tree entry nlevn alevn bp a s son =
- parser
- [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a
- | [: a = skip_if_empty bp (parser []) :] -> a
- | [: a =
- continue entry bp a s son
- (parser_of_tree entry nlevn alevn son) :] ->
- a ]
-;
-
-value strict_parsing = ref False;
-
-value recover parser_of_tree entry nlevn alevn bp a s son strm =
- if strict_parsing.val then raise (Stream.Error (tree_failed entry a s son))
+
+let continue entry bp a s son p1 (strm__ : _ Stream.t) =
+ let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in
+ let act =
+ try p1 strm__ with
+ Stream.Failure -> raise (Stream.Error (tree_failed entry a s son))
+ in
+ Gramext.action (fun _ -> app act a)
+
+let do_recover parser_of_tree entry nlevn alevn bp a s son
+ (strm__ : _ Stream.t) =
+ try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with
+ Stream.Failure ->
+ try
+ skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure)
+ strm__
+ with Stream.Failure ->
+ continue entry bp a s son (parser_of_tree entry nlevn alevn son)
+ strm__
+
+let strict_parsing = ref false
+
+let recover parser_of_tree entry nlevn alevn bp a s son strm =
+ if !strict_parsing then raise (Stream.Error (tree_failed entry a s son))
else do_recover parser_of_tree entry nlevn alevn bp a s son strm
-;
-value token_count = ref 0;
+let token_count = ref 0
-value peek_nth n strm = do {
+let peek_nth n strm =
let list = Stream.npeek n strm in
- token_count.val := Stream.count strm + n;
+ token_count := Stream.count strm + n;
let rec loop list n =
- match (list, n) with
- [ ([x :: _], 1) -> Some x
- | ([_ :: l], n) -> loop l (n - 1)
- | ([], _) -> None ]
+ match list, n with
+ x :: _, 1 -> Some x
+ | _ :: l, n -> loop l (n - 1)
+ | [], _ -> None
in
loop list n
-};
-value item_skipped = ref False;
-value skip_item a = do { item_skipped.val := True; a };
+let item_skipped = ref false
+let skip_item a = item_skipped := true; a
-value call_and_push ps al strm = do {
- item_skipped.val := False;
+let call_and_push ps al strm =
+ item_skipped := false;
let a = ps strm in
- let al = if item_skipped.val then al else [a :: al] in
- item_skipped.val := False;
- al
-};
+ let al = if !item_skipped then al else a :: al in item_skipped := false; al
-value fcall_and_push ps al err strm = do {
- item_skipped.val := False;
+let fcall_and_push ps al err strm =
+ item_skipped := false;
match ps err strm with
- [ Some (a, strm) -> do {
- let al = if item_skipped.val then al else [a :: al] in
- item_skipped.val := False;
- Some (al, strm)
- }
- | None -> None ]
-};
-
-value bcall_and_push ps al err strm = do {
- item_skipped.val := False;
+ Some (a, strm) ->
+ let al = if !item_skipped then al else a :: al in
+ item_skipped := false; Some (al, strm)
+ | None -> None
+
+let bcall_and_push ps al err strm =
+ item_skipped := false;
match ps err strm with
- [ Some (a, strm, Fstream.K kont) -> do {
- let rec kont2 kont () = do {
- item_skipped.val := False;
+ Some (a, strm, Fstream.K kont) ->
+ let rec kont2 kont () =
+ item_skipped := false;
match kont () with
- [ Some (a, strm, Fstream.K kont) -> do {
- let al = if item_skipped.val then al else [a :: al] in
- item_skipped.val := False;
- Some (al, strm, Fstream.K (kont2 kont))
- }
- | None -> None ]
- }
+ Some (a, strm, Fstream.K kont) ->
+ let al = if !item_skipped then al else a :: al in
+ item_skipped := false; Some (al, strm, Fstream.K (kont2 kont))
+ | None -> None
in
- let al = if item_skipped.val then al else [a :: al] in
- item_skipped.val := False;
- Some (al, strm, Fstream.K (kont2 kont))
- }
- | None -> None ]
-};
-
-value token_ematch gram (tok, vala) =
+ let al = if !item_skipped then al else a :: al in
+ item_skipped := false; Some (al, strm, Fstream.K (kont2 kont))
+ | None -> None
+
+let token_ematch gram (tok, vala) =
let tematch = gram.glexer.Plexing.tok_match tok in
match vala with
- | Some al ->
+ Some al ->
let pa =
match al with
- [ [] ->
- let t = "V " ^ fst tok in
- gram.glexer.Plexing.tok_match (t, "")
+ [] ->
+ let t = "V " ^ fst tok in gram.glexer.Plexing.tok_match (t, "")
| al ->
- loop al where rec loop =
- fun
- [ [a :: al] ->
+ let rec loop =
+ function
+ a :: al ->
let pa = gram.glexer.Plexing.tok_match ("V", a) in
let pal = loop al in
- fun tok ->
- try pa tok with [ Stream.Failure -> pal tok ]
- | [] -> fun tok -> raise Stream.Failure ] ]
+ (fun tok -> try pa tok with Stream.Failure -> pal tok)
+ | [] -> fun tok -> raise Stream.Failure
+ in
+ loop al
in
- fun tok ->
- try Obj.repr (Ploc.VaAnt (Obj.magic (pa tok : string))) with
- [ Stream.Failure -> Obj.repr (Ploc.VaVal (tematch tok)) ]
- | None ->
- fun tok -> Obj.repr (tematch tok : string)
- end
-;
-
-value rec parser_of_tree entry nlevn alevn =
- fun
- [ DeadEnd -> parser []
- | LocAct act _ -> parser [: :] -> act
- | Node {node = Sself; son = LocAct act _; brother = DeadEnd} ->
- parser [: a = entry.estart alevn :] -> app act a
+ (fun tok ->
+ try Obj.repr (Ploc.VaAnt (Obj.magic (pa tok : string))) with
+ Stream.Failure -> Obj.repr (Ploc.VaVal (tematch tok)))
+ | None -> fun tok -> Obj.repr (tematch tok : string)
+
+let rec parser_of_tree entry nlevn alevn =
+ function
+ DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure)
+ | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act)
+ | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} ->
+ (fun (strm__ : _ Stream.t) ->
+ let a = entry.estart alevn strm__ in app act a)
| Node {node = Scut; son = son; brother = _} ->
parser_of_tree entry nlevn alevn son
- | Node {node = Sself; son = LocAct act _; brother = bro} ->
+ | Node {node = Sself; son = LocAct (act, _); brother = bro} ->
let p2 = parser_of_tree entry nlevn alevn bro in
- parser
- [ [: a = entry.estart alevn :] -> app act a
- | [: a = p2 :] -> a ]
+ (fun (strm__ : _ Stream.t) ->
+ match
+ try Some (entry.estart alevn strm__) with Stream.Failure -> None
+ with
+ Some a -> app act a
+ | _ -> p2 strm__)
| Node {node = s; son = son; brother = DeadEnd} ->
let tokl =
match s with
- [ Stoken tok -> get_token_list entry [] (tok, None) son
- | Svala ls (Stoken tok) -> get_token_list entry [] (tok, Some ls) son
- | _ -> None ]
+ Stoken tok -> get_token_list entry [] (tok, None) son
+ | Svala (ls, Stoken tok) -> get_token_list entry [] (tok, Some ls) son
+ | _ -> None
in
- match tokl with
- [ None ->
+ begin match tokl with
+ None ->
let ps = parser_of_symbol entry nlevn s in
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn s son in
- parser bp
- [: a = ps;
- act = p1 bp a ? tree_failed entry a s son :] -> app act a
+ (fun (strm__ : _ Stream.t) ->
+ let bp = Stream.count strm__ in
+ let a = ps strm__ in
+ let act =
+ try p1 bp a strm__ with
+ Stream.Failure ->
+ raise (Stream.Error (tree_failed entry a s son))
+ in
+ app act a)
| Some (rev_tokl, (last_tok, svala), son) ->
let lt =
let t = Stoken last_tok in
match svala with
- [ Some l -> Svala l t
- | None -> t ]
+ Some l -> Svala (l, t)
+ | None -> t
in
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn lt son in
- parser_of_token_list entry s son p1 (parser []) rev_tokl
- (last_tok, svala) ]
+ parser_of_token_list entry s son p1
+ (fun (strm__ : _ Stream.t) -> raise Stream.Failure) rev_tokl
+ (last_tok, svala)
+ end
| Node {node = s; son = son; brother = bro} ->
let tokl =
match s with
- [ Stoken tok -> get_token_list entry [] (tok, None) son
- | Svala ls (Stoken tok) -> get_token_list entry [] (tok, Some ls) son
- | _ -> None ]
+ Stoken tok -> get_token_list entry [] (tok, None) son
+ | Svala (ls, Stoken tok) -> get_token_list entry [] (tok, Some ls) son
+ | _ -> None
in
match tokl with
- [ None ->
+ None ->
let ps = parser_of_symbol entry nlevn s in
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn s son in
let p2 = parser_of_tree entry nlevn alevn bro in
- fun (strm : Stream.t _) ->
- let bp = Stream.count strm in
- match try Some (ps strm) with [ Stream.Failure -> None ] with
- | Some a ->
- match
- try Some (p1 bp a strm) with [ Stream.Failure -> None ]
- with
- | Some act -> app act a
- | None -> raise (Stream.Error (tree_failed entry a s son))
- end
- | None -> p2 strm
- end
+ (fun (strm : _ Stream.t) ->
+ let bp = Stream.count strm in
+ match try Some (ps strm) with Stream.Failure -> None with
+ Some a ->
+ begin match
+ (try Some (p1 bp a strm) with Stream.Failure -> None)
+ with
+ Some act -> app act a
+ | None -> raise (Stream.Error (tree_failed entry a s son))
+ end
+ | None -> p2 strm)
| Some (rev_tokl, (last_tok, vala), son) ->
let lt =
let t = Stoken last_tok in
match vala with
- [ Some ls -> Svala ls t
- | None -> t ]
+ Some ls -> Svala (ls, t)
+ | None -> t
in
let p2 = parser_of_tree entry nlevn alevn bro in
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn lt son in
let p1 =
- parser_of_token_list entry lt son p1 p2 rev_tokl
- (last_tok, vala)
+ parser_of_token_list entry lt son p1 p2 rev_tokl (last_tok, vala)
in
- parser
- [ [: a = p1 :] -> a
- | [: a = p2 :] -> a ] ] ]
-and parser_cont p1 entry nlevn alevn s son bp a =
- parser
- [ [: a = p1 :] -> a
- | [: a = recover parser_of_tree entry nlevn alevn bp a s son :] -> a ]
+ fun (strm__ : _ Stream.t) ->
+ try p1 strm__ with Stream.Failure -> p2 strm__
+and parser_cont p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) =
+ try p1 strm__ with
+ Stream.Failure ->
+ recover parser_of_tree entry nlevn alevn bp a s son strm__
and parser_of_token_list entry s son p1 p2 rev_tokl last_tok =
let plast =
let n = List.length rev_tokl + 1 in
let tematch = token_ematch entry.egram last_tok in
let ps strm =
match peek_nth n strm with
- [ Some tok -> do {
+ Some tok ->
let r = tematch tok in
- for i = 1 to n do { Stream.junk strm };
- Obj.repr r
- }
- | None -> raise Stream.Failure ]
+ for i = 1 to n do Stream.junk strm done; Obj.repr r
+ | None -> raise Stream.Failure
in
- fun (strm : Stream.t _) ->
+ fun (strm : _ Stream.t) ->
let bp = Stream.count strm in
let a = ps strm in
- match try Some (p1 bp a strm) with [ Stream.Failure -> None ] with
- | Some act -> app act a
+ match try Some (p1 bp a strm) with Stream.Failure -> None with
+ Some act -> app act a
| None -> raise (Stream.Error (tree_failed entry a s son))
- end
in
match List.rev rev_tokl with
- | [] -> parser [: a = plast :] -> a
- | [tok :: tokl] ->
+ [] -> (fun (strm__ : _ Stream.t) -> plast strm__)
+ | tok :: tokl ->
let tematch = token_ematch entry.egram tok in
let ps strm =
match peek_nth 1 strm with
- [ Some tok -> tematch tok
- | None -> raise Stream.Failure ]
+ Some tok -> tematch tok
+ | None -> raise Stream.Failure
in
let p1 =
- loop 2 tokl where rec loop n =
- fun
- | [] -> plast
- | [tok :: tokl] ->
+ let rec loop n =
+ function
+ [] -> plast
+ | tok :: tokl ->
let tematch = token_ematch entry.egram tok in
let ps strm =
match peek_nth n strm with
- | Some tok -> tematch tok
+ Some tok -> tematch tok
| None -> raise Stream.Failure
- end
in
let p1 = loop (n + 1) tokl in
- parser [: a = ps; act = p1 ! :] -> app act a
- end
+ fun (strm__ : _ Stream.t) ->
+ let a = ps strm__ in let act = p1 strm__ in app act a
+ in
+ loop 2 tokl
in
- parser [: a = ps; act = p1 ! :] -> app act a
- end
+ fun (strm__ : _ Stream.t) ->
+ let a = ps strm__ in let act = p1 strm__ in app act a
and parser_of_symbol entry nlevn =
- fun
- [ Sfacto s -> parser_of_symbol entry nlevn s
- | Smeta _ symbl act ->
+ function
+ Sfacto s -> parser_of_symbol entry nlevn s
+ | Smeta (_, symbl, act) ->
let act = Obj.magic act entry symbl in
Obj.magic
(List.fold_left
@@ -728,471 +707,496 @@ and parser_of_symbol entry nlevn =
act symbl)
| Slist0 s ->
let ps = call_and_push (parser_of_symbol entry nlevn s) in
- let rec loop al =
- parser
- [ [: al = ps al; a = loop al ! :] -> a
- | [: :] -> al ]
+ let rec loop al (strm__ : _ Stream.t) =
+ match try Some (ps al strm__) with Stream.Failure -> None with
+ Some al -> loop al strm__
+ | _ -> al
in
- parser [: a = loop [] :] -> Obj.repr (List.rev a)
- | Slist0sep symb sep False ->
+ (fun (strm__ : _ Stream.t) ->
+ let a = loop [] strm__ in Obj.repr (List.rev a))
+ | Slist0sep (symb, sep, false) ->
let ps = call_and_push (parser_of_symbol entry nlevn symb) in
let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt; al = ps al ? symb_failed entry v sep symb;
- a = kont al ! :] ->
- a
- | [: :] -> al ]
+ let rec kont al (strm__ : _ Stream.t) =
+ match try Some (pt strm__) with Stream.Failure -> None with
+ Some v ->
+ let al =
+ try ps al strm__ with
+ Stream.Failure ->
+ raise (Stream.Error (symb_failed entry v sep symb))
+ in
+ kont al strm__
+ | _ -> al
in
- parser
- [ [: al = ps []; a = kont al ! :] -> Obj.repr (List.rev a)
- | [: :] -> Obj.repr [] ]
- | Slist0sep symb sep True ->
+ (fun (strm__ : _ Stream.t) ->
+ match try Some (ps [] strm__) with Stream.Failure -> None with
+ Some al -> let a = kont al strm__ in Obj.repr (List.rev a)
+ | _ -> Obj.repr [])
+ | Slist0sep (symb, sep, true) ->
let ps = call_and_push (parser_of_symbol entry nlevn symb) in
let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt; al = ps al; a = kont al ! :] -> a
- | [: v = pt :] -> al
- | [: :] -> al ]
+ let rec kont al (strm__ : _ Stream.t) =
+ match try Some (pt strm__) with Stream.Failure -> None with
+ Some v ->
+ begin match
+ (try Some (ps al strm__) with Stream.Failure -> None)
+ with
+ Some al -> kont al strm__
+ | _ -> al
+ end
+ | _ -> al
in
- parser
- [ [: al = ps []; a = kont al ! :] -> Obj.repr (List.rev a)
- | [: :] -> Obj.repr [] ]
+ (fun (strm__ : _ Stream.t) ->
+ match try Some (ps [] strm__) with Stream.Failure -> None with
+ Some al -> let a = kont al strm__ in Obj.repr (List.rev a)
+ | _ -> Obj.repr [])
| Slist1 s ->
let ps = call_and_push (parser_of_symbol entry nlevn s) in
- let rec loop al =
- parser
- [ [: al = ps al; a = loop al ! :] -> a
- | [: :] -> al ]
+ let rec loop al (strm__ : _ Stream.t) =
+ match try Some (ps al strm__) with Stream.Failure -> None with
+ Some al -> loop al strm__
+ | _ -> al
in
- parser [: al = ps []; a = loop al ! :] -> Obj.repr (List.rev a)
- | Slist1sep symb sep False ->
+ (fun (strm__ : _ Stream.t) ->
+ let al = ps [] strm__ in
+ let a = loop al strm__ in Obj.repr (List.rev a))
+ | Slist1sep (symb, sep, false) ->
let ps = call_and_push (parser_of_symbol entry nlevn symb) in
let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt;
- al =
- parser
- [ [: a = ps al :] -> a
- | [: a = parse_top_symb entry symb :] -> [a :: al]
- | [: :] ->
- raise (Stream.Error (symb_failed entry v sep symb)) ] !;
- a = kont al ! :] ->
- a
- | [: :] -> al ]
+ let rec kont al (strm__ : _ Stream.t) =
+ match try Some (pt strm__) with Stream.Failure -> None with
+ Some v ->
+ let al =
+ try ps al strm__ with
+ Stream.Failure ->
+ let a =
+ try parse_top_symb entry symb strm__ with
+ Stream.Failure ->
+ raise (Stream.Error (symb_failed entry v sep symb))
+ in
+ a :: al
+ in
+ kont al strm__
+ | _ -> al
in
- parser [: al = ps []; a = kont al ! :] -> Obj.repr (List.rev a)
- | Slist1sep symb sep True ->
+ (fun (strm__ : _ Stream.t) ->
+ let al = ps [] strm__ in
+ let a = kont al strm__ in Obj.repr (List.rev a))
+ | Slist1sep (symb, sep, true) ->
let ps = call_and_push (parser_of_symbol entry nlevn symb) in
let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt; al = ps al; al = kont al ! :] -> al
- | [: v = pt; a = parse_top_symb entry symb;
- al = kont [a :: al] ! :] -> al
- | [: v = pt :] -> al
- | [: :] -> al ]
+ let rec kont al (strm__ : _ Stream.t) =
+ match try Some (pt strm__) with Stream.Failure -> None with
+ Some v ->
+ begin match
+ (try Some (ps al strm__) with Stream.Failure -> None)
+ with
+ Some al -> kont al strm__
+ | _ ->
+ match
+ try Some (parse_top_symb entry symb strm__) with
+ Stream.Failure -> None
+ with
+ Some a -> kont (a :: al) strm__
+ | _ -> al
+ end
+ | _ -> al
in
- parser [: al = ps []; a = kont al ! :] -> Obj.repr (List.rev a)
+ (fun (strm__ : _ Stream.t) ->
+ let al = ps [] strm__ in
+ let a = kont al strm__ in Obj.repr (List.rev a))
| Sopt s ->
let ps = parser_of_symbol entry nlevn s in
- parser
- [ [: a = ps :] -> Obj.repr (Some a)
- | [: :] -> Obj.repr None ]
+ (fun (strm__ : _ Stream.t) ->
+ match try Some (ps strm__) with Stream.Failure -> None with
+ Some a -> Obj.repr (Some a)
+ | _ -> Obj.repr None)
| Sflag s ->
let ps = parser_of_symbol entry nlevn s in
- parser
- [ [: _ = ps :] -> Obj.repr True
- | [: :] -> Obj.repr False ]
+ (fun (strm__ : _ Stream.t) ->
+ match try Some (ps strm__) with Stream.Failure -> None with
+ Some _ -> Obj.repr true
+ | _ -> Obj.repr false)
| Stree t ->
let pt = parser_of_tree entry 1 0 t in
- parser bp
- [: a = pt :] ep ->
- let loc = loc_of_token_interval bp ep in
- app a loc
- | Svala al s ->
+ (fun (strm__ : _ Stream.t) ->
+ let bp = Stream.count strm__ in
+ let a = pt strm__ in
+ let ep = Stream.count strm__ in
+ let loc = loc_of_token_interval bp ep in app a loc)
+ | Svala (al, s) ->
let pa =
match al with
- [ [] ->
+ [] ->
let t =
match s with
- [ Sflag _ -> Some "V FLAG"
+ Sflag _ -> Some "V FLAG"
| Sopt _ -> Some "V OPT"
- | Slist0 _ | Slist0sep _ _ _ -> Some "V LIST"
- | Slist1 _ | Slist1sep _ _ _ -> Some "V LIST"
+ | Slist0 _ | Slist0sep (_, _, _) -> Some "V LIST"
+ | Slist1 _ | Slist1sep (_, _, _) -> Some "V LIST"
| Stoken (con, "") -> Some ("V " ^ con)
- | _ -> None ]
+ | _ -> None
in
- match t with
- [ Some t -> parser_of_token entry (t, "")
- | None -> parser [] ]
+ begin match t with
+ Some t -> parser_of_token entry (t, "")
+ | None -> fun (strm__ : _ Stream.t) -> raise Stream.Failure
+ end
| al ->
- loop al where rec loop =
- fun
- [ [a :: al] ->
+ let rec loop =
+ function
+ a :: al ->
let pa = parser_of_token entry ("V", a) in
let pal = loop al in
- parser
- [ [: a = pa :] -> a
- | [: a = pal :] -> a ]
- | [] -> parser [] ] ]
+ (fun (strm__ : _ Stream.t) ->
+ try pa strm__ with Stream.Failure -> pal strm__)
+ | [] -> fun (strm__ : _ Stream.t) -> raise Stream.Failure
+ in
+ loop al
in
let ps = parser_of_symbol entry nlevn s in
- parser
- [ [: a = pa :] -> Obj.repr (Ploc.VaAnt (Obj.magic a : string))
- | [: a = ps :] -> Obj.repr (Ploc.VaVal a) ]
- | Snterm e -> parser [: a = e.estart 0 :] -> a
- | Snterml e l -> parser [: a = e.estart (level_number e l) :] -> a
- | Sself -> parser [: a = entry.estart 0 :] -> a
- | Snext -> parser [: a = entry.estart nlevn :] -> a
- | Scut -> parser [: :] -> Obj.repr ()
- | Stoken tok -> parser_of_token entry tok ]
+ (fun (strm__ : _ Stream.t) ->
+ match try Some (pa strm__) with Stream.Failure -> None with
+ Some a -> Obj.repr (Ploc.VaAnt (Obj.magic a : string))
+ | _ -> let a = ps strm__ in Obj.repr (Ploc.VaVal a))
+ | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__)
+ | Snterml (e, l) ->
+ (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__)
+ | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__)
+ | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__)
+ | Scut -> (fun (strm__ : _ Stream.t) -> Obj.repr ())
+ | Stoken tok -> parser_of_token entry tok
and parser_of_token entry tok =
let f = entry.egram.glexer.Plexing.tok_match tok in
fun strm ->
match Stream.peek strm with
- [ Some tok -> do {
- let r = f tok in
- Stream.junk strm;
- Obj.repr r
- }
- | None -> raise Stream.Failure ]
-and parse_top_symb entry symb =
- parser_of_symbol entry 0 (top_symb entry symb)
-;
+ Some tok -> let r = f tok in Stream.junk strm; Obj.repr r
+ | None -> raise Stream.Failure
+and parse_top_symb entry symb = parser_of_symbol entry 0 (top_symb entry symb)
-value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;
+let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2
-value rec start_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn -> parser []
- | [lev :: levs] ->
+let rec start_parser_of_levels entry clevn =
+ function
+ [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure)
+ | lev :: levs ->
let p1 = start_parser_of_levels entry (succ clevn) levs in
match lev.lprefix with
- [ DeadEnd -> p1
+ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
+ LeftA | NonA -> succ clevn
+ | RightA -> clevn
in
let p2 = parser_of_tree entry (succ clevn) alevn tree in
match levs with
- [ [] ->
- fun levn strm ->
- (* this code should be there but is commented to preserve
- compatibility with previous versions... with this code,
- the grammar entry e: [[ "x"; a = e | "y" ]] should fail
- because it should be: e: [RIGHTA[ "x"; a = e | "y" ]]...
- if levn > clevn then match strm with parser []
- else
- *)
- match strm with parser bp
- [: act = p2 :] ep ->
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm
+ [] ->
+ (fun levn strm ->
+ (* this code should be there but is commented to preserve
+ compatibility with previous versions... with this code,
+ the grammar entry e: [[ "x"; a = e | "y" ]] should fail
+ because it should be: e: [RIGHTA[ "x"; a = e | "y" ]]...
+ if levn > clevn then match strm with parser []
+ else
+ *)
+ let (strm__ : _ Stream.t) = strm in
+ let bp = Stream.count strm__ in
+ let act = p2 strm__ in
+ let ep = Stream.count strm__ in
+ let a = app act (loc_of_token_interval bp ep) in
+ entry.econtinue levn bp a strm)
| _ ->
fun levn strm ->
if levn > clevn then p1 levn strm
else
- match strm with parser bp
- [ [: act = p2 :] ep ->
+ let (strm__ : _ Stream.t) = strm in
+ let bp = Stream.count strm__ in
+ match try Some (p2 strm__) with Stream.Failure -> None with
+ Some act ->
+ let ep = Stream.count strm__ in
let a = app act (loc_of_token_interval bp ep) in
entry.econtinue levn bp a strm
- | [: a = p1 levn :] -> a ] ] ] ]
-;
+ | _ -> p1 levn strm__
-value rec continue_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn bp a -> parser []
- | [lev :: levs] ->
+let rec continue_parser_of_levels entry clevn =
+ function
+ [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure)
+ | lev :: levs ->
let p1 = continue_parser_of_levels entry (succ clevn) levs in
match lev.lsuffix with
- [ DeadEnd -> p1
+ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
+ LeftA | NonA -> succ clevn
+ | RightA -> clevn
in
let p2 = parser_of_tree entry (succ clevn) alevn tree in
fun levn bp a strm ->
if levn > clevn then p1 levn bp a strm
else
- match strm with parser
- [ [: a = p1 levn bp a :] -> a
- | [: act = p2 :] ep ->
+ let (strm__ : _ Stream.t) = strm in
+ try p1 levn bp a strm__ with
+ Stream.Failure ->
+ let act = p2 strm__ in
+ let ep = Stream.count strm__ in
let a = app act a (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm ] ] ]
-;
+ entry.econtinue levn bp a strm
-value continue_parser_of_entry entry =
+let continue_parser_of_entry entry =
match entry.edesc with
- [ Dlevels elev ->
+ Dlevels elev ->
let p = continue_parser_of_levels entry 0 elev in
- fun levn bp a ->
- parser
- [ [: a = p levn bp a :] -> a
- | [: :] -> a ]
- | Dparser p -> fun levn bp a -> parser [] ]
-;
-
-value empty_entry ename levn strm =
+ (fun levn bp a (strm__ : _ Stream.t) ->
+ try p levn bp a strm__ with Stream.Failure -> a)
+ | Dparser p -> fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure
+
+let empty_entry ename levn strm =
raise (Stream.Error ("entry [" ^ ename ^ "] is empty"))
-;
-value start_parser_of_entry entry =
+let start_parser_of_entry entry =
match entry.edesc with
- [ Dlevels [] -> empty_entry entry.ename
+ Dlevels [] -> empty_entry entry.ename
| Dlevels elev -> start_parser_of_levels entry 0 elev
- | Dparser p -> fun levn strm -> p strm ]
-;
+ | Dparser p -> fun levn strm -> p strm
-value default_algorithm_var = ref DefaultAlgorithm;
-value set_default_algorithm algo = default_algorithm_var.val := algo;
-value default_algorithm () = default_algorithm_var.val;
+let default_algorithm_var = ref DefaultAlgorithm
+let set_default_algorithm algo = default_algorithm_var := algo
+let default_algorithm () = !default_algorithm_var
(* deprecated since 2017-06-06: use 'set_default_algorithm' instead *)
-value backtrack_parse = ref False;
-value warned_using_backtrack_parse = ref False;
-value compatible_deprecated_backtrack_parse () =
- if backtrack_parse.val then do {
- if not warned_using_backtrack_parse.val then do {
- eprintf "<W> use of Grammar.backtrace_parse ";
- eprintf "deprecated since 2017-06-06\n%!";
- warned_using_backtrack_parse.val := True
- }
- else ();
- backtrack_parse.val := False;
- set_default_algorithm Backtracking
- }
- else ()
-;
+let backtrack_parse = ref false
+let warned_using_backtrack_parse = ref false
+let compatible_deprecated_backtrack_parse () =
+ if !backtrack_parse then
+ begin
+ if not !warned_using_backtrack_parse then
+ begin
+ eprintf "<W> use of Grammar.backtrace_parse ";
+ eprintf "deprecated since 2017-06-06\n%!";
+ warned_using_backtrack_parse := true
+ end;
+ backtrack_parse := false;
+ set_default_algorithm Backtracking
+ end
(* parsing with functional streams *)
-value backtrack_trace = ref False;
-value backtrack_stalling_limit = ref 10000;
-value backtrack_trace_try = ref False;
-value tind = ref "";
-value max_fcount = ref None;
-value nb_ftry = ref 0;
+let backtrack_trace = ref false
+let backtrack_stalling_limit = ref 10000
+let backtrack_trace_try = ref false
+let tind = ref ""
+let max_fcount = ref None
+let nb_ftry = ref 0
-value no_err () = "";
-value ftree_failed entry prev_symb_result prev_symb tree () =
+let no_err () = ""
+let ftree_failed entry prev_symb_result prev_symb tree () =
tree_failed entry prev_symb_result prev_symb tree
-;
-value fsymb_failed entry prev_symb_result prev_symb symb () =
+let fsymb_failed entry prev_symb_result prev_symb symb () =
symb_failed entry prev_symb_result prev_symb symb
-;
-value bfparser_of_token entry tok return_value =
+let bfparser_of_token entry tok return_value =
let f = entry.egram.glexer.Plexing.tok_match tok in
fun err strm ->
let _ =
- if backtrack_trace.val then do {
- Printf.eprintf "%stesting (\"%s\", \"%s\") ..." tind.val (fst tok)
- (snd tok);
- flush stderr;
- }
- else ()
+ if !backtrack_trace then
+ begin
+ Printf.eprintf "%stesting (\"%s\", \"%s\") ..." !tind (fst tok)
+ (snd tok);
+ flush stderr
+ end
in
let _ =
- if backtrack_stalling_limit.val > 0 || backtrack_trace_try.val then
+ if !backtrack_stalling_limit > 0 || !backtrack_trace_try then
let m =
- match max_fcount.val with
- | Some (m, _, _) -> m
+ match !max_fcount with
+ Some (m, _, _) -> m
| None -> 0
- end
in
- if Fstream.count strm > m then do {
- if backtrack_trace.val then
- Printf.eprintf " (token count max %d)%!" (Fstream.count strm)
- else ();
- let e : g_entry Obj.t = Obj.magic (entry : g_entry _) in
- let cnt = Fstream.count strm in
- max_fcount.val := Some (cnt, e, err);
- nb_ftry.val := 0
- }
- else do {
- if backtrack_trace.val then
- Printf.eprintf " (token count %d/%d)%!" (Fstream.count strm) m
- else ();
- incr nb_ftry;
- if backtrack_trace_try.val then do {
- Printf.eprintf "\ntokens read: %d; tokens tests: %d" m
- nb_ftry.val;
- flush stderr;
- }
- else ();
- if backtrack_stalling_limit.val > 0 &&
- nb_ftry.val >= backtrack_stalling_limit.val
- then do {
- if backtrack_trace.val || backtrack_trace_try.val then
- Printf.eprintf " (stalling limit reached)\n%!"
- else ();
- raise Stream.Failure
- }
- else ()
- }
- else ()
+ if Fstream.count strm > m then
+ begin
+ if !backtrack_trace then
+ Printf.eprintf " (token count max %d)%!" (Fstream.count strm);
+ let e : Obj.t g_entry = Obj.magic (entry : _ g_entry) in
+ let cnt = Fstream.count strm in
+ max_fcount := Some (cnt, e, err); nb_ftry := 0
+ end
+ else
+ begin
+ if !backtrack_trace then
+ Printf.eprintf " (token count %d/%d)%!" (Fstream.count strm) m;
+ incr nb_ftry;
+ if !backtrack_trace_try then
+ begin
+ Printf.eprintf "\ntokens read: %d; tokens tests: %d" m
+ !nb_ftry;
+ flush stderr
+ end;
+ if !backtrack_stalling_limit > 0 &&
+ !nb_ftry >= !backtrack_stalling_limit
+ then
+ begin
+ if !backtrack_trace || !backtrack_trace_try then
+ Printf.eprintf " (stalling limit reached)\n%!";
+ raise Stream.Failure
+ end
+ end
in
match Fstream.next strm with
- [ Some (tok, strm) ->
- try do {
+ Some (tok, strm) ->
+ begin try
let r = f tok in
let _ =
- if backtrack_trace.val then Printf.eprintf " yes \"%s\"\n%!" r
- else ()
+ if !backtrack_trace then Printf.eprintf " yes \"%s\"\n%!" r
in
- nb_ftry.val := 0;
- return_value r strm
- }
- with
- [ Stream.Failure ->
- let _ =
- if backtrack_trace.val then Printf.eprintf " not found\n%!"
- else ()
- in
- None ]
+ nb_ftry := 0; return_value r strm
+ with Stream.Failure ->
+ let _ = if !backtrack_trace then Printf.eprintf " not found\n%!" in
+ None
+ end
| None ->
let _ =
- if backtrack_trace.val then do {
- Printf.eprintf " eos\n";
- flush stderr;
- }
- else ()
+ if !backtrack_trace then
+ begin Printf.eprintf " eos\n"; flush stderr end
in
- None ]
-;
-
-let s = try Sys.getenv "CAMLP5PARAM" with [ Not_found -> "" ] in
-loop 0 where rec loop i =
- if i = String.length s then ()
- else if s.[i] = 'b' then do {
- set_default_algorithm Backtracking;
- loop (i + 1)
- }
- else if s.[i] = 'f' then do {
- set_default_algorithm Functional;
- loop (i + 1)
- }
- else if s.[i] = 'p' then do {
- set_default_algorithm Predictive;
- loop (i + 1)
- }
- else if s.[i] = 'l' && i + 1 < String.length s && s.[i+1] = '=' then do {
- let (n, i) =
- loop 0 (i + 2) where rec loop n i =
- if i = String.length s then (n, i)
- else if s.[i] >= '0' && s.[i] <= '9' then
- loop (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
- else (n, i)
- in
- backtrack_stalling_limit.val := n;
- loop i
- }
- else if s.[i] = 't' then do {
- backtrack_trace.val := True;
- loop (i + 1)
- }
- else if s.[i] = 'y' then do {
- backtrack_trace_try.val := True;
- loop (i + 1)
- }
- else
- loop (i + 1)
-;
+ None
+
+let _ =
+ let s = try Sys.getenv "CAMLP5PARAM" with Not_found -> "" in
+ let rec loop i =
+ if i = String.length s then ()
+ else if s.[i] = 'b' then
+ begin set_default_algorithm Backtracking; loop (i + 1) end
+ else if s.[i] = 'f' then
+ begin set_default_algorithm Functional; loop (i + 1) end
+ else if s.[i] = 'p' then
+ begin set_default_algorithm Predictive; loop (i + 1) end
+ else if s.[i] = 'l' && i + 1 < String.length s && s.[i+1] = '=' then
+ let (n, i) =
+ let rec loop n i =
+ if i = String.length s then n, i
+ else if s.[i] >= '0' && s.[i] <= '9' then
+ loop (10 * n + Char.code s.[i] - Char.code '0') (i + 1)
+ else n, i
+ in
+ loop 0 (i + 2)
+ in
+ backtrack_stalling_limit := n; loop i
+ else if s.[i] = 't' then begin backtrack_trace := true; loop (i + 1) end
+ else if s.[i] = 'y' then
+ begin backtrack_trace_try := true; loop (i + 1) end
+ else loop (i + 1)
+ in
+ loop 0
(* version with functional streams and limited backtracking *)
-value fcount = fparser bp [: :] → bp;
-
-value rec ftop_symb entry =
- fun
- [ Sself | Snext -> Some (Snterm entry)
- | Snterml e _ -> Some (Snterm e)
- | Slist1sep s sep b ->
- match ftop_symb entry s with
- [ Some s -> Some (Slist1sep s sep b)
- | None -> None ]
- | _ -> None ]
-;
+let fcount (strm__ : _ Fstream.t) =
+ let bp = Fstream.count strm__ in Some (bp, strm__)
+
+let rec ftop_symb entry =
+ function
+ Sself | Snext -> Some (Snterm entry)
+ | Snterml (e, _) -> Some (Snterm e)
+ | Slist1sep (s, sep, b) ->
+ begin match ftop_symb entry s with
+ Some s -> Some (Slist1sep (s, sep, b))
+ | None -> None
+ end
+ | _ -> None
-value ftop_tree entry son strm =
+let ftop_tree entry son strm =
match son with
- [ Node {node = s; brother = bro; son = son} ->
- match ftop_symb entry s with
- [ Some sy ->
+ Node {node = s; brother = bro; son = son} ->
+ begin match ftop_symb entry s with
+ Some sy ->
let r = Node {node = sy; brother = bro; son = son} in
let _ =
- if backtrack_trace.val then
- Printf.eprintf "%srecovering pos %d\n%!" tind.val
+ if !backtrack_trace then
+ Printf.eprintf "%srecovering pos %d\n%!" !tind
(Fstream.count strm)
- else ()
in
- match strm with fparser [: :] -> r
- | None ->
- None ]
- | LocAct _ _ | DeadEnd ->
- None ]
-;
-
-value frecover fparser_of_tree entry next_levn assoc_levn son err =
- fparser
- [ [: t = ftop_tree entry son;
- a = fparser_of_tree entry next_levn assoc_levn t err :] -> a ]
-;
-
-value fparser_of_token entry tok =
- let return_value r strm = match strm with fparser [: :] -> Obj.repr r in
+ let (strm__ : _ Fstream.t) = strm in Some (r, strm__)
+ | None -> None
+ end
+ | LocAct (_, _) | DeadEnd -> None
+
+let frecover fparser_of_tree entry next_levn assoc_levn son err
+ (strm__ : _ Fstream.t) =
+ match ftop_tree entry son strm__ with
+ Some (t, strm__) ->
+ fparser_of_tree entry next_levn assoc_levn t err strm__
+ | _ -> None
+
+let fparser_of_token entry tok =
+ let return_value r strm =
+ let (strm__ : _ Fstream.t) = strm in Some (Obj.repr r, strm__)
+ in
bfparser_of_token entry tok return_value
-;
-
-value rec fparser_of_tree entry next_levn assoc_levn =
- fun
- [ DeadEnd -> fun err -> fparser []
- | LocAct act _ -> fun err -> fparser [: :] -> act
- | Node {node = Sself; son = LocAct act _; brother = DeadEnd} ->
- fun err -> fparser [: a = entry.fstart assoc_levn err :] -> app act a
- | Node {node = Sself; son = LocAct act _; brother = bro} ->
+
+let rec fparser_of_tree entry next_levn assoc_levn =
+ function
+ DeadEnd -> (fun err (strm__ : _ Fstream.t) -> None)
+ | LocAct (act, _) -> (fun err (strm__ : _ Fstream.t) -> Some (act, strm__))
+ | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} ->
+ (fun err (strm__ : _ Fstream.t) ->
+ match entry.fstart assoc_levn err strm__ with
+ Some (a, strm__) -> Some (app act a, strm__)
+ | _ -> None)
+ | Node {node = Sself; son = LocAct (act, _); brother = bro} ->
let p2 = fparser_of_tree entry next_levn assoc_levn bro in
- fun err ->
- fparser
- [ [: a = entry.fstart assoc_levn err :] -> app act a
- | [: a = p2 err :] -> a ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match
+ match entry.fstart assoc_levn err strm__ with
+ Some (a, strm__) -> Some (app act a, strm__)
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> p2 err strm__)
| Node {node = Scut; son = son; brother = _} ->
let p1 = fparser_of_tree entry next_levn assoc_levn son in
- fun err ->
- fparser
- [ [: !; a = p1 err :] -> a ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match p1 err strm__ with
+ None -> raise Fstream.Cut
+ | x -> x)
| Node {node = s; son = son; brother = DeadEnd} ->
let ps = fparser_of_symbol entry next_levn s in
let p1 = fparser_of_tree entry next_levn assoc_levn son in
let p1 = fparser_cont p1 entry next_levn assoc_levn son in
- fun err ->
- fparser [: a = ps err; act = p1 (ftree_failed entry a s son) :] ->
- app act a
+ (fun err (strm__ : _ Fstream.t) ->
+ match ps err strm__ with
+ Some (a, strm__) ->
+ begin match p1 (ftree_failed entry a s son) strm__ with
+ Some (act, strm__) -> Some (app act a, strm__)
+ | _ -> None
+ end
+ | _ -> None)
| Node {node = s; son = son; brother = bro} ->
let ps = fparser_of_symbol entry next_levn s in
let p1 = fparser_of_tree entry next_levn assoc_levn son in
let p1 = fparser_cont p1 entry next_levn assoc_levn son in
let p2 = fparser_of_tree entry next_levn assoc_levn bro in
- fun err ->
- fparser
- [ [: a = ps err; act = p1 (ftree_failed entry a s son) :] -> app act a
- | [: a = p2 err :] -> a ] ]
-and fparser_cont p1 entry next_levn assoc_levn son err =
- fparser
- [ [: a = p1 err :] -> a
- | [: a = frecover fparser_of_tree entry next_levn assoc_levn son err :] ->
- a ]
+ fun err (strm__ : _ Fstream.t) ->
+ match
+ match ps err strm__ with
+ Some (a, strm__) ->
+ begin match p1 (ftree_failed entry a s son) strm__ with
+ Some (act, strm__) -> Some (app act a, strm__)
+ | _ -> None
+ end
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> p2 err strm__
+and fparser_cont p1 entry next_levn assoc_levn son err
+ (strm__ : _ Fstream.t) =
+ match p1 err strm__ with
+ Some _ as x -> x
+ | None -> frecover fparser_of_tree entry next_levn assoc_levn son err strm__
and fparser_of_symbol entry next_levn =
- fun
- [ Sfacto s -> fparser_of_symbol entry next_levn s
- | Smeta _ symbl act ->
+ function
+ Sfacto s -> fparser_of_symbol entry next_levn s
+ | Smeta (_, symbl, act) ->
let _ = failwith "Smeta for fparser not impl" in
let act = Obj.magic act entry symbl in
Obj.magic
@@ -1203,301 +1207,457 @@ and fparser_of_symbol entry next_levn =
| Slist0 s ->
let ps = fparser_of_symbol entry next_levn s in
let ps = fcall_and_push ps in
- let rec loop al err =
- fparser
- [ [: al = ps al err; a = loop al err :] -> a
- | [: :] -> al ]
+ let rec loop al err (strm__ : _ Fstream.t) =
+ match
+ match ps al err strm__ with
+ Some (al, strm__) -> loop al err strm__
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (al, strm__)
in
- fun err -> fparser [: a = loop [] err :] -> Obj.repr (List.rev a)
- | Slist0sep symb sep False ->
+ (fun err (strm__ : _ Fstream.t) ->
+ match loop [] err strm__ with
+ Some (a, strm__) -> Some (Obj.repr (List.rev a), strm__)
+ | _ -> None)
+ | Slist0sep (symb, sep, false) ->
let ps = fparser_of_symbol entry next_levn symb in
let ps = fcall_and_push ps in
let pt = fparser_of_symbol entry next_levn sep in
- let rec kont al err =
- fparser
- [ [: v = pt err; al = ps al (fsymb_failed entry v sep symb);
- a = kont al err :] -> a
- | [: :] -> al ]
+ let rec kont al err (strm__ : _ Fstream.t) =
+ match
+ match pt err strm__ with
+ Some (v, strm__) ->
+ begin match ps al (fsymb_failed entry v sep symb) strm__ with
+ Some (al, strm__) -> kont al err strm__
+ | _ -> None
+ end
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (al, strm__)
in
- fun err ->
- fparser
- [ [: al = ps [] err; a = kont al err :] -> Obj.repr (List.rev a)
- | [: :] -> Obj.repr [] ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match
+ match ps [] err strm__ with
+ Some (al, strm__) ->
+ begin match kont al err strm__ with
+ Some (a, strm__) -> Some (Obj.repr (List.rev a), strm__)
+ | _ -> None
+ end
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (Obj.repr [], strm__))
| Slist1 s ->
let ps = fparser_of_symbol entry next_levn s in
let ps = fcall_and_push ps in
- let rec loop al err =
- fparser
- [ [: al = ps al err; a = loop al err :] -> a
- | [: :] -> al ]
+ let rec loop al err (strm__ : _ Fstream.t) =
+ match
+ match ps al err strm__ with
+ Some (al, strm__) -> loop al err strm__
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (al, strm__)
in
- fun err ->
- fparser [: al = ps [] err; a = loop al err :] -> Obj.repr (List.rev a)
- | Slist0sep symb sep True ->
+ (fun err (strm__ : _ Fstream.t) ->
+ match ps [] err strm__ with
+ Some (al, strm__) ->
+ begin match loop al err strm__ with
+ Some (a, strm__) -> Some (Obj.repr (List.rev a), strm__)
+ | _ -> None
+ end
+ | _ -> None)
+ | Slist0sep (symb, sep, true) ->
failwith "LIST0 _ SEP _ OPT_SEP not implemented; please report"
- | Slist1sep symb sep False ->
+ | Slist1sep (symb, sep, false) ->
let ps = fparser_of_symbol entry next_levn symb in
let ps = fcall_and_push ps in
let pt = fparser_of_symbol entry next_levn sep in
let pts = fparse_top_symb entry symb in
- let rec kont al err =
- fparser
- [ [: v = pt err;
- al =
- fparser
- [ [: a = ps al (fsymb_failed entry v sep symb) :] -> a
- | [: a = pts (fsymb_failed entry v sep symb) :] -> [a :: al] ];
- a = kont al err :] ->
- a
- | [: :] -> al ]
+ let rec kont al err (strm__ : _ Fstream.t) =
+ match
+ match pt err strm__ with
+ Some (v, strm__) ->
+ begin match
+ (fun (strm__ : _ Fstream.t) ->
+ match ps al (fsymb_failed entry v sep symb) strm__ with
+ Some _ as x -> x
+ | None ->
+ match pts (fsymb_failed entry v sep symb) strm__ with
+ Some (a, strm__) -> Some (a :: al, strm__)
+ | _ -> None)
+ strm__
+ with
+ Some (al, strm__) -> kont al err strm__
+ | _ -> None
+ end
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (al, strm__)
in
- fun err ->
- fparser [: al = ps [] err; a = kont al err :] -> Obj.repr (List.rev a)
- | Slist1sep symb sep True ->
+ (fun err (strm__ : _ Fstream.t) ->
+ match ps [] err strm__ with
+ Some (al, strm__) ->
+ begin match kont al err strm__ with
+ Some (a, strm__) -> Some (Obj.repr (List.rev a), strm__)
+ | _ -> None
+ end
+ | _ -> None)
+ | Slist1sep (symb, sep, true) ->
let ps = fparser_of_symbol entry next_levn symb in
let ps = fcall_and_push ps in
let pt = fparser_of_symbol entry next_levn sep in
let pts = fparse_top_symb entry symb in
- let rec kont al err =
- fparser
- [ [: v = pt err; al = ps al err; al = kont al err :] -> al
- | [: v = pt err; a = pts err; al = kont [a :: al] err :] -> al
- | [: v = pt err :] -> al
- | [: :] -> al ]
+ let rec kont al err (strm__ : _ Fstream.t) =
+ match
+ match pt err strm__ with
+ Some (v, strm__) ->
+ begin match ps al err strm__ with
+ Some (al, strm__) -> kont al err strm__
+ | _ -> None
+ end
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None ->
+ match
+ match pt err strm__ with
+ Some (v, strm__) ->
+ begin match pts err strm__ with
+ Some (a, strm__) -> kont (a :: al) err strm__
+ | _ -> None
+ end
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None ->
+ match
+ match pt err strm__ with
+ Some (v, strm__) -> Some (al, strm__)
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (al, strm__)
in
- fun err ->
- fparser [: al = ps [] err; a = kont al err :] -> Obj.repr (List.rev a)
+ (fun err (strm__ : _ Fstream.t) ->
+ match ps [] err strm__ with
+ Some (al, strm__) ->
+ begin match kont al err strm__ with
+ Some (a, strm__) -> Some (Obj.repr (List.rev a), strm__)
+ | _ -> None
+ end
+ | _ -> None)
| Sopt s ->
let ps = fparser_of_symbol entry next_levn s in
- fun err ->
- fparser
- [ [: a = ps err :] -> Obj.repr (Some a)
- | [: :] -> Obj.repr None ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match
+ match ps err strm__ with
+ Some (a, strm__) -> Some (Obj.repr (Some a), strm__)
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (Obj.repr None, strm__))
| Sflag s ->
let ps = fparser_of_symbol entry next_levn s in
- fun err ->
- fparser
- [ [: _ = ps err :] -> Obj.repr True
- | [: :] -> Obj.repr False ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match
+ match ps err strm__ with
+ Some (_, strm__) -> Some (Obj.repr true, strm__)
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> Some (Obj.repr false, strm__))
| Stree t ->
let pt = fparser_of_tree entry 1 0 t in
- fun err ->
- fparser bp
- [: a = pt err :] ep ->
- let loc = loc_of_token_interval bp ep in
- app a loc
- | Svala al s ->
+ (fun err (strm__ : _ Fstream.t) ->
+ let bp = Fstream.count strm__ in
+ match pt err strm__ with
+ Some (a, strm__) ->
+ Some
+ ((let ep = Fstream.count strm__ in
+ let loc = loc_of_token_interval bp ep in app a loc),
+ strm__)
+ | _ -> None)
+ | Svala (al, s) ->
let pa =
match al with
- [ [] ->
+ [] ->
let t =
match s with
- [ Sflag _ -> Some "V FLAG"
+ Sflag _ -> Some "V FLAG"
| Sopt _ -> Some "V OPT"
- | Slist0 _ | Slist0sep _ _ _ -> Some "V LIST"
- | Slist1 _ | Slist1sep _ _ _ -> Some "V LIST"
+ | Slist0 _ | Slist0sep (_, _, _) -> Some "V LIST"
+ | Slist1 _ | Slist1sep (_, _, _) -> Some "V LIST"
| Stoken (con, "") -> Some ("V " ^ con)
- | _ -> None ]
+ | _ -> None
in
- match t with
- [ Some t -> fparser_of_token entry (t, "")
- | None -> fun err -> fparser [] ]
+ begin match t with
+ Some t -> fparser_of_token entry (t, "")
+ | None -> fun err (strm__ : _ Fstream.t) -> None
+ end
| al ->
- loop al where rec loop =
- fun
- [ [a :: al] ->
+ let rec loop =
+ function
+ a :: al ->
let pa = fparser_of_token entry ("V", a) in
let pal = loop al in
- fun err ->
- fparser
- [ [: a = pa err :] -> a
- | [: a = pal err :] -> a ]
- | [] -> fun err -> fparser [] ] ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match pa err strm__ with
+ Some _ as x -> x
+ | None -> pal err strm__)
+ | [] -> fun err (strm__ : _ Fstream.t) -> None
+ in
+ loop al
in
let ps = fparser_of_symbol entry next_levn s in
- fun err ->
- fparser
- [ [: a = pa err :] -> Obj.repr (Ploc.VaAnt (Obj.magic a : string))
- | [: a = ps err :] -> Obj.repr (Ploc.VaVal a) ]
- | Snterm e ->
- fun err -> fparser [: a = e.fstart 0 err :] -> a
- | Snterml e l ->
- fun err -> fparser [: a = e.fstart (level_number e l) err :] -> a
- | Sself -> fun err -> fparser [: a = entry.fstart 0 err :] -> a
- | Snext -> fun err -> fparser [: a = entry.fstart next_levn err :] -> a
- | Scut -> fun err -> fparser [: ! :] -> Obj.repr ()
- | Stoken tok -> fparser_of_token entry tok ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match
+ match pa err strm__ with
+ Some (a, strm__) ->
+ Some (Obj.repr (Ploc.VaAnt (Obj.magic a : string)), strm__)
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None ->
+ match ps err strm__ with
+ Some (a, strm__) -> Some (Obj.repr (Ploc.VaVal a), strm__)
+ | _ -> None)
+ | Snterm e -> (fun err (strm__ : _ Fstream.t) -> e.fstart 0 err strm__)
+ | Snterml (e, l) ->
+ (fun err (strm__ : _ Fstream.t) ->
+ e.fstart (level_number e l) err strm__)
+ | Sself -> (fun err (strm__ : _ Fstream.t) -> entry.fstart 0 err strm__)
+ | Snext ->
+ (fun err (strm__ : _ Fstream.t) -> entry.fstart next_levn err strm__)
+ | Scut ->
+ (fun err (strm__ : _ Fstream.t) ->
+ match Some (Obj.repr (), strm__) with
+ None -> raise Fstream.Cut
+ | x -> x)
+ | Stoken tok -> fparser_of_token entry tok
and fparse_top_symb entry symb =
match ftop_symb entry symb with
- [ Some sy -> fparser_of_symbol entry 0 sy
- | None -> fun err -> fparser [] ]
-;
-
-value rec fstart_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn err -> fparser []
- | [lev :: levs] ->
+ Some sy -> fparser_of_symbol entry 0 sy
+ | None -> fun err (strm__ : _ Fstream.t) -> None
+
+let rec fstart_parser_of_levels entry clevn =
+ function
+ [] -> (fun levn err (strm__ : _ Fstream.t) -> None)
+ | lev :: levs ->
let p1 = fstart_parser_of_levels entry (succ clevn) levs in
match lev.lprefix with
- [ DeadEnd -> p1
+ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
+ LeftA | NonA -> succ clevn
+ | RightA -> clevn
in
let p2 = fparser_of_tree entry (succ clevn) alevn tree in
match levs with
- [ [] ->
- fun levn err strm ->
- match strm with fparser bp
- [: act = p2 err; ep = fcount;
- a =
- entry.fcontinue levn bp
- (app act (loc_of_token_interval bp ep)) err :] ->
- a
+ [] ->
+ (fun levn err strm ->
+ let (strm__ : _ Fstream.t) = strm in
+ let bp = Fstream.count strm__ in
+ match p2 err strm__ with
+ Some (act, strm__) ->
+ begin match fcount strm__ with
+ Some (ep, strm__) ->
+ entry.fcontinue levn bp
+ (app act (loc_of_token_interval bp ep)) err strm__
+ | _ -> None
+ end
+ | _ -> None)
| _ ->
fun levn err strm ->
if levn > clevn then p1 levn err strm
else
- match strm with fparser bp
- [ [: act = p2 err; ep = fcount;
- a =
- entry.fcontinue levn bp
- (app act (loc_of_token_interval bp ep)) err :] ->
- a
- | [: a = p1 levn err :] -> a ] ] ] ]
-;
-
-value rec fcontinue_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn bp a err -> fparser []
- | [lev :: levs] ->
+ let (strm__ : _ Fstream.t) = strm in
+ let bp = Fstream.count strm__ in
+ match
+ match p2 err strm__ with
+ Some (act, strm__) ->
+ begin match fcount strm__ with
+ Some (ep, strm__) ->
+ entry.fcontinue levn bp
+ (app act (loc_of_token_interval bp ep)) err
+ strm__
+ | _ -> None
+ end
+ | _ -> None
+ with
+ Some _ as x -> x
+ | None -> p1 levn err strm__
+
+let rec fcontinue_parser_of_levels entry clevn =
+ function
+ [] -> (fun levn bp a err (strm__ : _ Fstream.t) -> None)
+ | lev :: levs ->
let p1 = fcontinue_parser_of_levels entry (succ clevn) levs in
match lev.lsuffix with
- [ DeadEnd -> p1
+ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
+ LeftA | NonA -> succ clevn
+ | RightA -> clevn
in
let p2 = fparser_of_tree entry (succ clevn) alevn tree in
fun levn bp a err strm ->
if levn > clevn then p1 levn bp a err strm
else
- match strm with fparser
- [ [: a = p1 levn bp a err :] -> a
- | [: act = p2 err; ep = fcount;
- a =
- entry.fcontinue levn bp
- (app act a (loc_of_token_interval bp ep)) err :] ->
- a ] ] ]
-;
-
-value fstart_parser_of_entry entry =
+ let (strm__ : _ Fstream.t) = strm in
+ match p1 levn bp a err strm__ with
+ Some _ as x -> x
+ | None ->
+ match p2 err strm__ with
+ Some (act, strm__) ->
+ begin match fcount strm__ with
+ Some (ep, strm__) ->
+ entry.fcontinue levn bp
+ (app act a (loc_of_token_interval bp ep)) err
+ strm__
+ | _ -> None
+ end
+ | _ -> None
+
+let fstart_parser_of_entry entry =
match entry.edesc with
- [ Dlevels [] -> fun _ err -> fparser []
+ Dlevels [] -> (fun _ err (strm__ : _ Fstream.t) -> None)
| Dlevels elev -> fstart_parser_of_levels entry 0 elev
- | Dparser p -> fun levn err strm -> failwith "Dparser for Fstream" ]
-;
+ | Dparser p -> fun levn err strm -> failwith "Dparser for Fstream"
-value fcontinue_parser_of_entry entry =
+let fcontinue_parser_of_entry entry =
match entry.edesc with
- [ Dlevels elev ->
+ Dlevels elev ->
let p = fcontinue_parser_of_levels entry 0 elev in
- fun levn bp a err ->
- fparser
- [ [: a = p levn bp a err :] -> a
- | [: :] -> a ]
- | Dparser p -> fun levn bp a err -> fparser [] ]
-;
+ (fun levn bp a err (strm__ : _ Fstream.t) ->
+ match p levn bp a err strm__ with
+ Some _ as x -> x
+ | None -> Some (a, strm__))
+ | Dparser p -> fun levn bp a err (strm__ : _ Fstream.t) -> None
(* version with functional streams and full backtracking *)
-value rec btop_symb entry =
- fun
- [ Sself | Snext -> Some (Snterm entry)
- | Snterml e _ -> Some (Snterm e)
- | Slist1sep s sep b ->
- match btop_symb entry s with
- [ Some s -> Some (Slist1sep s sep b)
- | None -> None ]
- | _ -> None ]
-;
-
-value btop_tree entry son strm =
+let rec btop_symb entry =
+ function
+ Sself | Snext -> Some (Snterm entry)
+ | Snterml (e, _) -> Some (Snterm e)
+ | Slist1sep (s, sep, b) ->
+ begin match btop_symb entry s with
+ Some s -> Some (Slist1sep (s, sep, b))
+ | None -> None
+ end
+ | _ -> None
+
+let btop_tree entry son strm =
match son with
- [ Node {node = s; brother = bro; son = son} ->
- match btop_symb entry s with
- [ Some sy ->
+ Node {node = s; brother = bro; son = son} ->
+ begin match btop_symb entry s with
+ Some sy ->
let r = Node {node = sy; brother = bro; son = son} in
let _ =
- if backtrack_trace.val then
- Printf.eprintf "%srecovering pos %d\n%!" tind.val
+ if !backtrack_trace then
+ Printf.eprintf "%srecovering pos %d\n%!" !tind
(Fstream.count strm)
- else ()
in
- match strm with bparser [: :] -> r
- | None ->
- None ]
- | LocAct _ _ | DeadEnd ->
- None ]
-;
-
-value brecover bparser_of_tree entry next_levn assoc_levn son err =
- bparser
- [ [: t = btop_tree entry son;
- a = bparser_of_tree entry next_levn assoc_levn t err :] -> a ]
-;
-
-value bparser_of_token entry tok =
- let return_value r strm = match strm with bparser [: :] -> Obj.repr r in
+ let (strm__ : _ Fstream.t) = strm in Fstream.b_act r strm__
+ | None -> None
+ end
+ | LocAct (_, _) | DeadEnd -> None
+
+let brecover bparser_of_tree entry next_levn assoc_levn son err
+ (strm__ : _ Fstream.t) =
+ Fstream.b_seq (fun strm__ -> btop_tree entry son strm__)
+ (fun t strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ bparser_of_tree entry next_levn assoc_levn t err strm__)
+ Fstream.b_act strm__)
+ strm__
+
+let bparser_of_token entry tok =
+ let return_value r strm =
+ let (strm__ : _ Fstream.t) = strm in Fstream.b_act (Obj.repr r) strm__
+ in
bfparser_of_token entry tok return_value
-;
-
-value rec bparser_of_tree entry next_levn assoc_levn =
- fun
- [ DeadEnd -> fun err -> bparser []
- | LocAct act _ -> fun err -> bparser [: :] -> act
- | Node {node = Sself; son = LocAct act _; brother = DeadEnd} ->
- fun err -> bparser [: a = entry.bstart assoc_levn err :] -> app act a
- | Node {node = Sself; son = LocAct act _; brother = bro} ->
+
+let rec bparser_of_tree entry next_levn assoc_levn =
+ function
+ DeadEnd -> (fun err (strm__ : _ Fstream.t) -> None)
+ | LocAct (act, _) ->
+ (fun err (strm__ : _ Fstream.t) -> Fstream.b_act act strm__)
+ | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} ->
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> entry.bstart assoc_levn err strm__)
+ (fun a strm__ -> Fstream.b_act (app act a) strm__) strm__)
+ | Node {node = Sself; son = LocAct (act, _); brother = bro} ->
let p2 = bparser_of_tree entry next_levn assoc_levn bro in
- fun err ->
- bparser
- [ [: a = entry.bstart assoc_levn err :] -> app act a
- | [: a = p2 err :] -> a ]
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> entry.bstart assoc_levn err strm__)
+ (fun a strm__ -> Fstream.b_act (app act a) strm__) strm__)
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p2 err strm__) Fstream.b_act
+ strm__)
+ strm__)
| Node {node = Scut; son = son; brother = _} ->
let p1 = bparser_of_tree entry next_levn assoc_levn son in
- fun err ->
- bparser
- [ [: !; a = p1 err :] -> a ]
+ (fun err (strm__ : _ Fstream.t) ->
+ match
+ Fstream.b_seq (fun strm__ -> p1 err strm__) Fstream.b_act strm__
+ with
+ None -> raise Fstream.Cut
+ | x -> x)
| Node {node = s; son = son; brother = DeadEnd} ->
let ps = bparser_of_symbol entry next_levn s in
let p1 = bparser_of_tree entry next_levn assoc_levn son in
let p1 = bparser_cont p1 entry next_levn assoc_levn son in
- fun err ->
- bparser [: a = ps err; act = p1 (ftree_failed entry a s son) :] ->
- app act a
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> ps err strm__)
+ (fun a strm__ ->
+ Fstream.b_seq
+ (fun strm__ -> p1 (ftree_failed entry a s son) strm__)
+ (fun act strm__ -> Fstream.b_act (app act a) strm__) strm__)
+ strm__)
| Node {node = s; son = son; brother = bro} ->
let ps = bparser_of_symbol entry next_levn s in
let p1 = bparser_of_tree entry next_levn assoc_levn son in
let p1 = bparser_cont p1 entry next_levn assoc_levn son in
let p2 = bparser_of_tree entry next_levn assoc_levn bro in
- fun err ->
- bparser
- [ [: a = ps err; act = p1 (ftree_failed entry a s son) :] -> app act a
- | [: a = p2 err :] -> a ] ]
-and bparser_cont p1 entry next_levn assoc_levn son err =
- bparser
- [ [: a = p1 err :] -> a
- | [: a = brecover bparser_of_tree entry next_levn assoc_levn son err :] ->
- a ]
+ fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> ps err strm__)
+ (fun a strm__ ->
+ Fstream.b_seq
+ (fun strm__ -> p1 (ftree_failed entry a s son) strm__)
+ (fun act strm__ -> Fstream.b_act (app act a) strm__)
+ strm__)
+ strm__)
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p2 err strm__) Fstream.b_act strm__)
+ strm__
+and bparser_cont p1 entry next_levn assoc_levn son err
+ (strm__ : _ Fstream.t) =
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p1 err strm__) Fstream.b_act strm__)
+ (fun strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ brecover bparser_of_tree entry next_levn assoc_levn son err
+ strm__)
+ Fstream.b_act strm__)
+ strm__
and bparser_of_symbol entry next_levn =
- fun
- [ Sfacto s -> bparser_of_symbol entry next_levn s
- | Smeta _ symbl act ->
+ function
+ Sfacto s -> bparser_of_symbol entry next_levn s
+ | Smeta (_, symbl, act) ->
let _ = failwith "Smeta for bparser not impl" in
let act = Obj.magic act entry symbl in
Obj.magic
@@ -1508,905 +1668,953 @@ and bparser_of_symbol entry next_levn =
| Slist0 s ->
let ps = bparser_of_symbol entry next_levn s in
let ps = bcall_and_push ps in
- let rec loop al err =
- bparser
- [ [: al = ps al err; a = loop al err :] -> a
- | [: :] -> al ]
+ let rec loop al err (strm__ : _ Fstream.t) =
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> ps al err strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> loop al err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ (fun strm__ -> Fstream.b_act al strm__) strm__
in
- fun err -> bparser [: a = loop [] err :] -> Obj.repr (List.rev a)
- | Slist0sep symb sep False ->
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> loop [] err strm__)
+ (fun a strm__ -> Fstream.b_act (Obj.repr (List.rev a)) strm__)
+ strm__)
+ | Slist0sep (symb, sep, false) ->
let ps = bparser_of_symbol entry next_levn symb in
let ps = bcall_and_push ps in
let pt = bparser_of_symbol entry next_levn sep in
- let rec kont al err =
- bparser
- [ [: v = pt err; al = ps al (fsymb_failed entry v sep symb);
- a = kont al err :] -> a
- | [: :] -> al ]
+ let rec kont al err (strm__ : _ Fstream.t) =
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pt err strm__)
+ (fun v strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ ps al (fsymb_failed entry v sep symb) strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> kont al err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ strm__)
+ (fun strm__ -> Fstream.b_act al strm__) strm__
in
- fun err ->
- bparser
- [ [: al = ps [] err; a = kont al err :] -> Obj.repr (List.rev a)
- | [: :] -> Obj.repr [] ]
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> ps [] err strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> kont al err strm__)
+ (fun a strm__ ->
+ Fstream.b_act (Obj.repr (List.rev a)) strm__)
+ strm__)
+ strm__)
+ (fun strm__ -> Fstream.b_act (Obj.repr []) strm__) strm__)
| Slist1 s ->
let ps = bparser_of_symbol entry next_levn s in
let ps = bcall_and_push ps in
- let rec loop al err =
- bparser
- [ [: al = ps al err; a = loop al err :] -> a
- | [: :] -> al ]
+ let rec loop al err (strm__ : _ Fstream.t) =
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> ps al err strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> loop al err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ (fun strm__ -> Fstream.b_act al strm__) strm__
in
- fun err ->
- bparser [: al = ps [] err; a = loop al err :] -> Obj.repr (List.rev a)
- | Slist0sep symb sep True ->
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> ps [] err strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> loop al err strm__)
+ (fun a strm__ -> Fstream.b_act (Obj.repr (List.rev a)) strm__)
+ strm__)
+ strm__)
+ | Slist0sep (symb, sep, true) ->
failwith "LIST0 _ SEP _ OPT_SEP not implemented; please report"
- | Slist1sep symb sep False ->
+ | Slist1sep (symb, sep, false) ->
let ps = bparser_of_symbol entry next_levn symb in
let ps = bcall_and_push ps in
let pt = bparser_of_symbol entry next_levn sep in
let pts = bparse_top_symb entry symb in
- let rec kont al err =
- bparser
- [ [: v = pt err;
- al =
- bparser
- [ [: a = ps al (fsymb_failed entry v sep symb) :] -> a
- | [: a = pts (fsymb_failed entry v sep symb) :] -> [a :: al] ];
- a = kont al err :] ->
- a
- | [: :] -> al ]
+ let rec kont al err (strm__ : _ Fstream.t) =
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pt err strm__)
+ (fun v strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ (fun (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ ps al (fsymb_failed entry v sep symb)
+ strm__)
+ Fstream.b_act strm__)
+ (fun strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ pts (fsymb_failed entry v sep symb)
+ strm__)
+ (fun a strm__ ->
+ Fstream.b_act (a :: al) strm__)
+ strm__)
+ strm__)
+ strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> kont al err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ strm__)
+ (fun strm__ -> Fstream.b_act al strm__) strm__
in
- fun err ->
- bparser [: al = ps [] err; a = kont al err :] -> Obj.repr (List.rev a)
- | Slist1sep symb sep True ->
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> ps [] err strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> kont al err strm__)
+ (fun a strm__ -> Fstream.b_act (Obj.repr (List.rev a)) strm__)
+ strm__)
+ strm__)
+ | Slist1sep (symb, sep, true) ->
let ps = bparser_of_symbol entry next_levn symb in
let ps = bcall_and_push ps in
let pt = bparser_of_symbol entry next_levn sep in
let pts = bparse_top_symb entry symb in
- let rec kont al err =
- bparser
- [ [: v = pt err; al = ps al err; al = kont al err :] -> al
- | [: v = pt err; a = pts err; al = kont [a :: al] err :] -> al
- | [: v = pt err :] -> al
- | [: :] -> al ]
+ let rec kont al err (strm__ : _ Fstream.t) =
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pt err strm__)
+ (fun v strm__ ->
+ Fstream.b_seq (fun strm__ -> ps al err strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> kont al err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ strm__)
+ (Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pt err strm__)
+ (fun v strm__ ->
+ Fstream.b_seq (fun strm__ -> pts err strm__)
+ (fun a strm__ ->
+ Fstream.b_seq
+ (fun strm__ -> kont (a :: al) err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ strm__)
+ (Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pt err strm__)
+ (fun v strm__ -> Fstream.b_act al strm__) strm__)
+ (fun strm__ -> Fstream.b_act al strm__)))
+ strm__
in
- fun err ->
- bparser [: al = ps [] err; a = kont al err :] -> Obj.repr (List.rev a)
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> ps [] err strm__)
+ (fun al strm__ ->
+ Fstream.b_seq (fun strm__ -> kont al err strm__)
+ (fun a strm__ -> Fstream.b_act (Obj.repr (List.rev a)) strm__)
+ strm__)
+ strm__)
| Sopt s ->
let ps = bparser_of_symbol entry next_levn s in
- fun err ->
- bparser
- [ [: a = ps err :] -> Obj.repr (Some a)
- | [: :] -> Obj.repr None ]
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> ps err strm__)
+ (fun a strm__ -> Fstream.b_act (Obj.repr (Some a)) strm__)
+ strm__)
+ (fun strm__ -> Fstream.b_act (Obj.repr None) strm__) strm__)
| Sflag s ->
let ps = bparser_of_symbol entry next_levn s in
- fun err ->
- bparser
- [ [: _ = ps err :] -> Obj.repr True
- | [: :] -> Obj.repr False ]
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> ps err strm__)
+ (fun _ strm__ -> Fstream.b_act (Obj.repr true) strm__) strm__)
+ (fun strm__ -> Fstream.b_act (Obj.repr false) strm__) strm__)
| Stree t ->
let pt = bparser_of_tree entry 1 0 t in
- fun err ->
- bparser bp
- [: a = pt err :] ep ->
- let loc = loc_of_token_interval bp ep in
- app a loc
- | Svala al s ->
+ (fun err (strm__ : _ Fstream.t) ->
+ let bp = Fstream.count strm__ in
+ Fstream.b_seq (fun strm__ -> pt err strm__)
+ (fun a strm__ ->
+ let ep = Fstream.count strm__ in
+ Fstream.b_act
+ (let loc = loc_of_token_interval bp ep in app a loc) strm__)
+ strm__)
+ | Svala (al, s) ->
let pa =
match al with
- [ [] ->
+ [] ->
let t =
match s with
- [ Sflag _ -> Some "V FLAG"
+ Sflag _ -> Some "V FLAG"
| Sopt _ -> Some "V OPT"
- | Slist0 _ | Slist0sep _ _ _ -> Some "V LIST"
- | Slist1 _ | Slist1sep _ _ _ -> Some "V LIST"
+ | Slist0 _ | Slist0sep (_, _, _) -> Some "V LIST"
+ | Slist1 _ | Slist1sep (_, _, _) -> Some "V LIST"
| Stoken (con, "") -> Some ("V " ^ con)
- | _ -> None ]
+ | _ -> None
in
- match t with
- [ Some t -> bparser_of_token entry (t, "")
- | None -> fun err -> bparser [] ]
+ begin match t with
+ Some t -> bparser_of_token entry (t, "")
+ | None -> fun err (strm__ : _ Fstream.t) -> None
+ end
| al ->
- loop al where rec loop =
- fun
- [ [a :: al] ->
+ let rec loop =
+ function
+ a :: al ->
let pa = bparser_of_token entry ("V", a) in
let pal = loop al in
- fun err ->
- bparser
- [ [: a = pa err :] -> a
- | [: a = pal err :] -> a ]
- | [] -> fun err -> bparser [] ] ]
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pa err strm__)
+ Fstream.b_act strm__)
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pal err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ | [] -> fun err (strm__ : _ Fstream.t) -> None
+ in
+ loop al
in
let ps = bparser_of_symbol entry next_levn s in
- fun err ->
- bparser
- [ [: a = pa err :] -> Obj.repr (Ploc.VaAnt (Obj.magic a : string))
- | [: a = ps err :] -> Obj.repr (Ploc.VaVal a) ]
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> pa err strm__)
+ (fun a strm__ ->
+ Fstream.b_act
+ (Obj.repr (Ploc.VaAnt (Obj.magic a : string))) strm__)
+ strm__)
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> ps err strm__)
+ (fun a strm__ ->
+ Fstream.b_act (Obj.repr (Ploc.VaVal a)) strm__)
+ strm__)
+ strm__)
| Snterm e ->
- fun err -> bparser [: a = e.bstart 0 err :] -> a
- | Snterml e l ->
- fun err -> bparser [: a = e.bstart (level_number e l) err :] -> a
- | Sself -> fun err -> bparser [: a = entry.bstart 0 err :] -> a
- | Snext -> fun err -> bparser [: a = entry.bstart next_levn err :] -> a
- | Scut -> fun err -> bparser [: ! :] -> Obj.repr ()
- | Stoken tok -> bparser_of_token entry tok ]
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> e.bstart 0 err strm__) Fstream.b_act
+ strm__)
+ | Snterml (e, l) ->
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> e.bstart (level_number e l) err strm__)
+ Fstream.b_act strm__)
+ | Sself ->
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> entry.bstart 0 err strm__) Fstream.b_act
+ strm__)
+ | Snext ->
+ (fun err (strm__ : _ Fstream.t) ->
+ Fstream.b_seq (fun strm__ -> entry.bstart next_levn err strm__)
+ Fstream.b_act strm__)
+ | Scut ->
+ (fun err (strm__ : _ Fstream.t) ->
+ match Fstream.b_act (Obj.repr ()) strm__ with
+ None -> raise Fstream.Cut
+ | x -> x)
+ | Stoken tok -> bparser_of_token entry tok
and bparse_top_symb entry symb =
match btop_symb entry symb with
- [ Some sy -> bparser_of_symbol entry 0 sy
- | None -> fun err -> bparser [] ]
-;
+ Some sy -> bparser_of_symbol entry 0 sy
+ | None -> fun err (strm__ : _ Fstream.t) -> None
-value bcount strm = match strm with bparser [: :] -> Fstream.count strm;
+let bcount strm =
+ let (strm__ : _ Fstream.t) = strm in
+ Fstream.b_act (Fstream.count strm) strm__
-value rec bstart_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn err -> bparser []
- | [lev :: levs] ->
+let rec bstart_parser_of_levels entry clevn =
+ function
+ [] -> (fun levn err (strm__ : _ Fstream.t) -> None)
+ | lev :: levs ->
let p1 = bstart_parser_of_levels entry (succ clevn) levs in
match lev.lprefix with
- [ DeadEnd -> p1
+ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
+ LeftA | NonA -> succ clevn
+ | RightA -> clevn
in
let p2 = bparser_of_tree entry (succ clevn) alevn tree in
match levs with
- [ [] ->
- fun levn err strm ->
- match strm with bparser bp
- [: act = p2 err; ep = bcount;
- a =
- entry.bcontinue levn bp
- (app act (loc_of_token_interval bp ep)) err :] ->
- a
+ [] ->
+ (fun levn err strm ->
+ let (strm__ : _ Fstream.t) = strm in
+ let bp = Fstream.count strm__ in
+ Fstream.b_seq (fun strm__ -> p2 err strm__)
+ (fun act strm__ ->
+ Fstream.b_seq bcount
+ (fun ep strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ entry.bcontinue levn bp
+ (app act (loc_of_token_interval bp ep)) err
+ strm__)
+ Fstream.b_act strm__)
+ strm__)
+ strm__)
| _ ->
fun levn err strm ->
if levn > clevn then p1 levn err strm
else
- match strm with bparser bp
- [ [: act = p2 err; ep = bcount;
- a =
- entry.bcontinue levn bp
- (app act (loc_of_token_interval bp ep)) err :] ->
- a
- | [: a = p1 levn err :] -> a ] ] ] ]
-;
-
-value rec bcontinue_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn bp a err -> bparser []
- | [lev :: levs] ->
+ let (strm__ : _ Fstream.t) = strm in
+ let bp = Fstream.count strm__ in
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p2 err strm__)
+ (fun act strm__ ->
+ Fstream.b_seq bcount
+ (fun ep strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ entry.bcontinue levn bp
+ (app act
+ (loc_of_token_interval bp ep))
+ err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ strm__)
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p1 levn err strm__)
+ Fstream.b_act strm__)
+ strm__
+
+let rec bcontinue_parser_of_levels entry clevn =
+ function
+ [] -> (fun levn bp a err (strm__ : _ Fstream.t) -> None)
+ | lev :: levs ->
let p1 = bcontinue_parser_of_levels entry (succ clevn) levs in
match lev.lsuffix with
- [ DeadEnd -> p1
+ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
+ LeftA | NonA -> succ clevn
+ | RightA -> clevn
in
let p2 = bparser_of_tree entry (succ clevn) alevn tree in
fun levn bp a err strm ->
if levn > clevn then p1 levn bp a err strm
else
- match strm with bparser
- [ [: a = p1 levn bp a err :] -> a
- | [: act = p2 err; ep = bcount;
- a =
- entry.bcontinue levn bp
- (app act a (loc_of_token_interval bp ep)) err :] ->
- a ] ] ]
-;
-
-value bstart_parser_of_entry entry =
+ let (strm__ : _ Fstream.t) = strm in
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p1 levn bp a err strm__)
+ Fstream.b_act strm__)
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p2 err strm__)
+ (fun act strm__ ->
+ Fstream.b_seq bcount
+ (fun ep strm__ ->
+ Fstream.b_seq
+ (fun strm__ ->
+ entry.bcontinue levn bp
+ (app act a (loc_of_token_interval bp ep))
+ err strm__)
+ Fstream.b_act strm__)
+ strm__)
+ strm__)
+ strm__
+
+let bstart_parser_of_entry entry =
match entry.edesc with
- [ Dlevels [] -> fun _ err -> bparser []
+ Dlevels [] -> (fun _ err (strm__ : _ Fstream.t) -> None)
| Dlevels elev -> bstart_parser_of_levels entry 0 elev
- | Dparser p -> fun levn err strm -> failwith "Dparser for Fstream" ]
-;
+ | Dparser p -> fun levn err strm -> failwith "Dparser for Fstream"
-value bcontinue_parser_of_entry entry =
+let bcontinue_parser_of_entry entry =
match entry.edesc with
- [ Dlevels elev ->
+ Dlevels elev ->
let p = bcontinue_parser_of_levels entry 0 elev in
- fun levn bp a err ->
- bparser
- [ [: a = p levn bp a err :] -> a
- | [: :] -> a ]
- | Dparser p -> fun levn bp a err -> bparser [] ]
-;
+ (fun levn bp a err (strm__ : _ Fstream.t) ->
+ Fstream.b_or
+ (fun strm__ ->
+ Fstream.b_seq (fun strm__ -> p levn bp a err strm__)
+ Fstream.b_act strm__)
+ (fun strm__ -> Fstream.b_act a strm__) strm__)
+ | Dparser p -> fun levn bp a err (strm__ : _ Fstream.t) -> None
(* Extend syntax *)
-value trace_entry_lev_name entry lev =
+let trace_entry_lev_name entry lev =
match entry.edesc with
- | Dlevels ll ->
+ Dlevels ll ->
if lev < List.length ll then
let glev = List.nth ll lev in
- match glev.lname with
- | Some "" | None -> ()
+ begin match glev.lname with
+ Some "" | None -> ()
| Some s -> Printf.eprintf " (\"%s\")" s
end
- else ()
| Dparser _ -> ()
- end
-;
-value may_trace_start entry f =
- if backtrack_trace.val then
- fun lev err strm -> do {
- let t = tind.val in
- Printf.eprintf "%s>> start %s lev %d" tind.val entry.ename lev;
+let may_trace_start entry f =
+ if !backtrack_trace then
+ fun lev err strm ->
+ let t = !tind in
+ Printf.eprintf "%s>> start %s lev %d" !tind entry.ename lev;
trace_entry_lev_name entry lev;
Printf.eprintf "\n%!";
- tind.val := tind.val ^ " ";
- try do {
+ tind := !tind ^ " ";
+ try
let r = f lev err strm in
- tind.val := t;
- Printf.eprintf "%s<< end %s lev %d" tind.val entry.ename lev;
+ tind := t;
+ Printf.eprintf "%s<< end %s lev %d" !tind entry.ename lev;
trace_entry_lev_name entry lev;
Printf.eprintf "\n%!";
r
- }
- with e -> do {
- tind.val := t;
- Printf.eprintf "%sexception \"%s\"\n" tind.val
- (Printexc.to_string e);
+ with e ->
+ tind := t;
+ Printf.eprintf "%sexception \"%s\"\n" !tind (Printexc.to_string e);
flush stderr;
raise e
- }
- }
else f
-;
-
-value may_trace_continue entry f =
- if backtrack_trace.val then
- fun lev bp a err strm -> do {
- let t = tind.val in
- Printf.eprintf "%s>> continue %s lev %d bp %d pos %d" tind.val
- entry.ename lev bp (Fstream.count strm);
+
+let may_trace_continue entry f =
+ if !backtrack_trace then
+ fun lev bp a err strm ->
+ let t = !tind in
+ Printf.eprintf "%s>> continue %s lev %d bp %d pos %d" !tind entry.ename
+ lev bp (Fstream.count strm);
trace_entry_lev_name entry lev;
Printf.eprintf "\n%!";
- tind.val := tind.val ^ " ";
- try do {
+ tind := !tind ^ " ";
+ try
let r = f lev bp a err strm in
- tind.val := t;
- Printf.eprintf "%s<< end continue %s lev %d %d" tind.val
- entry.ename lev bp;
+ tind := t;
+ Printf.eprintf "%s<< end continue %s lev %d %d" !tind entry.ename lev
+ bp;
trace_entry_lev_name entry lev;
Printf.eprintf "\n%!";
r
- }
- with e -> do {
- tind.val := t;
- Printf.eprintf "%sexception \"%s\"" tind.val
- (Printexc.to_string e);
+ with e ->
+ tind := t;
+ Printf.eprintf "%sexception \"%s\"" !tind (Printexc.to_string e);
trace_entry_lev_name entry lev;
Printf.eprintf "\n%!";
raise e
- }
- }
else f
-;
-
-value init_entry_functions entry = do {
- entry.estart :=
- fun lev strm -> do {
- let f = start_parser_of_entry entry in
- entry.estart := f;
- f lev strm
- };
- entry.econtinue :=
- fun lev bp a strm -> do {
- let f = continue_parser_of_entry entry in
- entry.econtinue := f;
- f lev bp a strm
- };
- entry.fstart :=
- fun lev err strm -> do {
- let f = fstart_parser_of_entry entry in
- let f = may_trace_start entry f in
- entry.fstart := f;
- f lev err strm
- };
- entry.fcontinue :=
- fun lev bp a err strm -> do {
- let f = fcontinue_parser_of_entry entry in
- let f = may_trace_continue entry f in
- entry.fcontinue := f;
- f lev bp a err strm
- };
- entry.bstart :=
- fun lev err strm -> do {
- let f = bstart_parser_of_entry entry in
- let f = may_trace_start entry f in
- entry.bstart := f;
- f lev err strm
- };
- entry.bcontinue :=
- fun lev bp a err strm -> do {
+
+let init_entry_functions entry =
+ entry.estart <-
+ (fun lev strm ->
+ let f = start_parser_of_entry entry in entry.estart <- f; f lev strm);
+ entry.econtinue <-
+ (fun lev bp a strm ->
+ let f = continue_parser_of_entry entry in
+ entry.econtinue <- f; f lev bp a strm);
+ entry.fstart <-
+ (fun lev err strm ->
+ let f = fstart_parser_of_entry entry in
+ let f = may_trace_start entry f in entry.fstart <- f; f lev err strm);
+ entry.fcontinue <-
+ (fun lev bp a err strm ->
+ let f = fcontinue_parser_of_entry entry in
+ let f = may_trace_continue entry f in
+ entry.fcontinue <- f; f lev bp a err strm);
+ entry.bstart <-
+ (fun lev err strm ->
+ let f = bstart_parser_of_entry entry in
+ let f = may_trace_start entry f in entry.bstart <- f; f lev err strm);
+ entry.bcontinue <-
+ fun lev bp a err strm ->
let f = bcontinue_parser_of_entry entry in
let f = may_trace_continue entry f in
- entry.bcontinue := f;
- f lev bp a err strm
- }
-};
+ entry.bcontinue <- f; f lev bp a err strm
-value reinit_entry_functions entry =
+let reinit_entry_functions entry =
match entry.edesc with
- [ Dlevels elev -> init_entry_functions entry
- | _ -> () ]
-;
+ Dlevels elev -> init_entry_functions entry
+ | _ -> ()
-value extend_entry entry position rules =
- try do {
+let extend_entry entry position rules =
+ try
let elev = Gramext.levels_of_rules entry position rules in
- entry.edesc := Dlevels elev;
- init_entry_functions entry
- }
- with
- [ Plexing.Error s -> do {
- Printf.eprintf "Lexer initialization error:\n- %s\n" s;
- flush stderr;
- failwith "Grammar.extend"
- } ]
-;
-
-value extend entry_rules_list =
+ entry.edesc <- Dlevels elev; init_entry_functions entry
+ with Plexing.Error s ->
+ Printf.eprintf "Lexer initialization error:\n- %s\n" s;
+ flush stderr;
+ failwith "Grammar.extend"
+
+let extend entry_rules_list =
let gram = ref None in
List.iter
- (fun (entry, position, rules) -> do {
- match gram.val with
- [ Some g ->
- if g != entry.egram then do {
- Printf.eprintf "Error: entries with different grammars\n";
- flush stderr;
- failwith "Grammar.extend"
- }
- else ()
- | None -> gram.val := Some entry.egram ];
- extend_entry entry position rules
- })
+ (fun (entry, position, rules) ->
+ begin match !gram with
+ Some g ->
+ if g != entry.egram then
+ begin
+ Printf.eprintf "Error: entries with different grammars\n";
+ flush stderr;
+ failwith "Grammar.extend"
+ end
+ | None -> gram := Some entry.egram
+ end;
+ extend_entry entry position rules)
entry_rules_list
-;
(* Deleting a rule *)
-value delete_rule entry sl =
+let delete_rule entry sl =
match entry.edesc with
- [ Dlevels levs -> do {
+ Dlevels levs ->
let levs = Gramext.delete_rule_in_level_list entry sl levs in
- entry.edesc := Dlevels levs;
- entry.estart :=
- fun lev strm -> do {
- let f = start_parser_of_entry entry in
- entry.estart := f;
- f lev strm
- };
- entry.econtinue :=
- fun lev bp a strm -> do {
- let f = continue_parser_of_entry entry in
- entry.econtinue := f;
- f lev bp a strm
- };
- entry.fstart :=
- fun lev err strm -> do {
- let f = fstart_parser_of_entry entry in
- entry.fstart := f;
- f lev err strm
- };
- entry.fcontinue :=
- fun lev bp a err strm -> do {
- let f = fcontinue_parser_of_entry entry in
- entry.fcontinue := f;
- f lev bp a err strm
- };
- entry.bstart :=
- fun lev err strm -> do {
- let f = bstart_parser_of_entry entry in
- entry.bstart := f;
- f lev err strm
- };
- entry.bcontinue :=
- fun lev bp a err strm -> do {
- let f = bcontinue_parser_of_entry entry in
- entry.bcontinue := f;
- f lev bp a err strm
- }
- }
- | Dparser _ -> () ]
-;
-
-value safe_delete_rule = delete_rule;
-
-type parse_algorithm = Gramext.parse_algorithm ==
- [ Predictive | Functional | Backtracking | DefaultAlgorithm ]
-;
-
-value warning_verbose = Gramext.warning_verbose;
+ entry.edesc <- Dlevels levs;
+ entry.estart <-
+ (fun lev strm ->
+ let f = start_parser_of_entry entry in
+ entry.estart <- f; f lev strm);
+ entry.econtinue <-
+ (fun lev bp a strm ->
+ let f = continue_parser_of_entry entry in
+ entry.econtinue <- f; f lev bp a strm);
+ entry.fstart <-
+ (fun lev err strm ->
+ let f = fstart_parser_of_entry entry in
+ entry.fstart <- f; f lev err strm);
+ entry.fcontinue <-
+ (fun lev bp a err strm ->
+ let f = fcontinue_parser_of_entry entry in
+ entry.fcontinue <- f; f lev bp a err strm);
+ entry.bstart <-
+ (fun lev err strm ->
+ let f = bstart_parser_of_entry entry in
+ entry.bstart <- f; f lev err strm);
+ entry.bcontinue <-
+ (fun lev bp a err strm ->
+ let f = bcontinue_parser_of_entry entry in
+ entry.bcontinue <- f; f lev bp a err strm)
+ | Dparser _ -> ()
+
+let safe_delete_rule = delete_rule
+
+type parse_algorithm =
+ Gramext.parse_algorithm =
+ Predictive | Functional | Backtracking | DefaultAlgorithm
+
+let warning_verbose = Gramext.warning_verbose
(* Normal interface *)
-type token = (string * string);
-type g = Gramext.grammar token;
+type token = string * string
+type g = token Gramext.grammar
-type ty_symbol 'self 'a = Gramext.g_symbol token;
-type ty_rule 'self 'f 'r = list (ty_symbol 'self Obj.t);
-type ty_production 'a = (ty_rule 'a Obj.t Obj.t * Gramext.g_action);
+type ('self, 'a) ty_symbol = token Gramext.g_symbol
+type ('self, 'f, 'r) ty_rule = ('self, Obj.t) ty_symbol list
+type 'a ty_production = ('a, Obj.t, Obj.t) ty_rule * Gramext.g_action
type ty_extension =
- (Gramext.g_entry token * option Gramext.position * list (option string * option Gramext.g_assoc * list (ty_production Obj.t)));
-
-value s_facto s = Sfacto s;
-value s_nterm e = Snterm e;
-value s_nterml e l = Snterml e l;
-value s_list0 s = Slist0 s;
-value s_list0sep s sep b = Slist0sep s sep b;
-value s_list1 s = Slist1 s;
-value s_list1sep s sep b = Slist1sep s sep b;
-value s_opt s = Sopt s;
-value s_flag s = Sflag s;
-value s_self = Sself;
-value s_next = Snext;
-value s_token tok = Stoken tok;
-value s_rules (t : list (ty_production Obj.t)) = Gramext.srules (Obj.magic t);
-value s_vala sl s = Svala sl s;
-
-value r_stop = [];
-value r_next r s = r @ [s];
-value r_cut r = r @ [Scut];
-
-value production (p : (ty_rule 'a 'f (Ploc.t -> 'a) * 'f)) = (Obj.magic p : ty_production 'a);
-value extension e pos (r : list (option string * option Gramext.g_assoc * list (ty_production Obj.t))) = ((e, pos, Obj.magic r) : ty_extension);
-
-value safe_extend (l : list ty_extension) = extend (Obj.magic l);
-
-value create_toktab () = Hashtbl.create 301;
-value gcreate glexer =
+ token Gramext.g_entry * Gramext.position option *
+ (string option * Gramext.g_assoc option * Obj.t ty_production list) list
+
+let s_facto s = Sfacto s
+let s_nterm e = Snterm e
+let s_nterml e l = Snterml (e, l)
+let s_list0 s = Slist0 s
+let s_list0sep s sep b = Slist0sep (s, sep, b)
+let s_list1 s = Slist1 s
+let s_list1sep s sep b = Slist1sep (s, sep, b)
+let s_opt s = Sopt s
+let s_flag s = Sflag s
+let s_self = Sself
+let s_next = Snext
+let s_token tok = Stoken tok
+let s_rules (t : Obj.t ty_production list) = Gramext.srules (Obj.magic t)
+let s_vala sl s = Svala (sl, s)
+
+let r_stop = []
+let r_next r s = r @ [s]
+let r_cut r = r @ [Scut]
+
+let production (p : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f) : 'a ty_production =
+ Obj.magic p
+let extension e pos
+ (r :
+ (string option * Gramext.g_assoc option * Obj.t ty_production list)
+ list) : ty_extension =
+ e, pos, Obj.magic r
+
+let safe_extend (l : ty_extension list) = extend (Obj.magic l)
+
+let create_toktab () = Hashtbl.create 301
+let gcreate glexer =
{gtokens = create_toktab (); glexer = glexer; galgo = DefaultAlgorithm}
-;
-value set_algorithm g algo = g.galgo := algo;
+let set_algorithm g algo = g.galgo <- algo
-value tokens g con = do {
+let tokens g con =
let list = ref [] in
Hashtbl.iter
- (fun (p_con, p_prm) c ->
- if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ())
+ (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list)
g.gtokens;
- list.val
-};
+ !list
-value glexer g = g.glexer;
+let glexer g = g.glexer
-type gen_parsable 'te =
- { pa_chr_strm : Stream.t char;
- pa_tok_strm : Stream.t 'te;
- pa_tok_fstrm : mutable Fstream.t 'te;
+type 'te gen_parsable =
+ { pa_chr_strm : char Stream.t;
+ pa_tok_strm : 'te Stream.t;
+ mutable pa_tok_fstrm : 'te Fstream.t;
pa_loc_func : Plexing.location_function }
-;
-type parsable = gen_parsable token;
+type parsable = token gen_parsable
-value fstream_of_stream ts =
+let fstream_of_stream ts =
Fstream.from
(fun _ ->
match Stream.peek ts with
- | None -> None
- | x -> do { Stream.junk ts; x }
- end)
-;
+ None -> None
+ | x -> Stream.junk ts; x)
-value parsable g cs =
+let parsable g cs =
let (ts, lf) = g.glexer.Plexing.tok_func cs in
let fts = fstream_of_stream ts in
{pa_chr_strm = cs; pa_tok_strm = ts; pa_tok_fstrm = fts; pa_loc_func = lf}
-;
-value parse_parsable entry p = do {
+let parse_parsable entry p =
let efun = entry.estart 0 in
let ts = p.pa_tok_strm in
let cs = p.pa_chr_strm in
let fun_loc = p.pa_loc_func in
let restore =
- let old_floc = floc.val in
- let old_tc = token_count.val in
- fun () -> do {
- floc.val := old_floc;
- token_count.val := old_tc;
- }
+ let old_floc = !floc in
+ let old_tc = !token_count in
+ fun () -> floc := old_floc; token_count := old_tc
in
let get_loc () =
try
let cnt = Stream.count ts in
let loc = fun_loc cnt in
- if token_count.val - 1 <= cnt then loc
- else Ploc.encl loc (fun_loc (token_count.val - 1))
- with
- [ Failure _ -> Ploc.make_unlined (Stream.count cs, Stream.count cs + 1) ]
+ if !token_count - 1 <= cnt then loc
+ else Ploc.encl loc (fun_loc (!token_count - 1))
+ with Failure _ -> Ploc.make_unlined (Stream.count cs, Stream.count cs + 1)
in
- floc.val := fun_loc;
- token_count.val := 0;
- try do {
- let r = efun ts in
- restore ();
- r
- }
- with
- [ Stream.Failure -> do {
+ floc := fun_loc;
+ token_count := 0;
+ try let r = efun ts in restore (); r with
+ Stream.Failure ->
let loc = get_loc () in
restore ();
Ploc.raise loc (Stream.Error ("illegal begin of " ^ entry.ename))
- }
- | Stream.Error _ as exc -> do {
- let loc = get_loc () in
- restore ();
- Ploc.raise loc exc
- }
- | exc -> do {
- let loc = (Stream.count cs, Stream.count cs + 1) in
- restore ();
- Ploc.raise (Ploc.make_unlined loc) exc
- } ]
-};
+ | Stream.Error _ as exc ->
+ let loc = get_loc () in restore (); Ploc.raise loc exc
+ | exc ->
+ let loc = Stream.count cs, Stream.count cs + 1 in
+ restore (); Ploc.raise (Ploc.make_unlined loc) exc
-value bfparse entry efun restore2 p = do {
+let bfparse entry efun restore2 p =
let default_loc () =
let cs = p.pa_chr_strm in
Ploc.make_unlined (Stream.count cs, Stream.count cs + 1)
in
let restore =
- let old_tc = token_count.val in
- let old_nb_ftry = nb_ftry.val in
- fun () -> do {
- token_count.val := old_tc;
- nb_ftry.val := old_nb_ftry;
- restore2 ();
- }
+ let old_tc = !token_count in
+ let old_nb_ftry = !nb_ftry in
+ fun () -> token_count := old_tc; nb_ftry := old_nb_ftry; restore2 ()
in
let get_loc cnt =
try
let loc = p.pa_loc_func cnt in
- if token_count.val - 1 <= cnt then loc
- else Ploc.encl loc (p.pa_loc_func (token_count.val - 1))
+ if !token_count - 1 <= cnt then loc
+ else Ploc.encl loc (p.pa_loc_func (!token_count - 1))
with
- [ Failure _ -> default_loc ()
- | e -> do { restore (); raise e } ]
+ Failure _ -> default_loc ()
+ | e -> restore (); raise e
in
- token_count.val := 0;
- nb_ftry.val := 0;
- if backtrack_trace_try.val then do {
- Printf.eprintf "\n";
- flush stderr;
- }
- else ();
+ token_count := 0;
+ nb_ftry := 0;
+ if !backtrack_trace_try then begin Printf.eprintf "\n"; flush stderr end;
let r =
let fts = p.pa_tok_fstrm in
try efun no_err fts with
- [ Stream.Failure | Fstream.Cut -> do {
+ Stream.Failure | Fstream.Cut ->
let cnt = Fstream.count fts + Fstream.count_unfrozen fts - 1 in
let loc = get_loc cnt in
let mess =
- match max_fcount.val with
- | Some (cnt, entry, err) ->
+ match !max_fcount with
+ Some (cnt, entry, err) ->
let mess = err () in
let mess =
if mess = "" then sprintf "failure in [%s]" entry.ename
else mess
in
- if backtrack_trace.val then
+ if !backtrack_trace then
mess ^ Printf.sprintf " (max token count %d)" cnt
else mess
- | None ->
- sprintf "[%s] failed" entry.ename
- end
+ | None -> sprintf "[%s] failed" entry.ename
in
let mess =
- if backtrack_trace.val then
- mess ^ Printf.sprintf " (cnt %d) (cnt+unfrozen %d)"
- token_count.val cnt
+ if !backtrack_trace then
+ mess ^
+ Printf.sprintf " (cnt %d) (cnt+unfrozen %d)" !token_count cnt
else mess
in
- restore ();
- Ploc.raise loc (Stream.Error mess)
- }
- | exc -> do {
- restore ();
- Ploc.raise (default_loc ()) exc
- } ]
+ restore (); Ploc.raise loc (Stream.Error mess)
+ | exc -> restore (); Ploc.raise (default_loc ()) exc
in
restore (); r
-};
-value bfparse_token_stream entry efun ts = do {
+let bfparse_token_stream entry efun ts =
let restore2 () = () in
- if backtrack_trace.val then
- Printf.eprintf "%sbfparse_token_stream [%s]\n%!" tind.val entry.ename
- else ();
+ if !backtrack_trace then
+ Printf.eprintf "%sbfparse_token_stream [%s]\n%!" !tind entry.ename;
let p =
- {pa_chr_strm = [: :];
- pa_tok_strm = ts;
- pa_tok_fstrm = fstream_of_stream ts;
- pa_loc_func = floc.val}
+ {pa_chr_strm = Stream.sempty; pa_tok_strm = ts;
+ pa_tok_fstrm = fstream_of_stream ts; pa_loc_func = !floc}
in
bfparse entry efun restore2 p
-};
-value bfparse_parsable entry p efun = do {
+let bfparse_parsable entry p efun =
let restore2 =
- let old_floc = floc.val in
- let old_max_fcount = max_fcount.val in
- fun () -> do {
- floc.val := old_floc;
- max_fcount.val := old_max_fcount;
- }
+ let old_floc = !floc in
+ let old_max_fcount = !max_fcount in
+ fun () -> floc := old_floc; max_fcount := old_max_fcount
in
- floc.val := p.pa_loc_func;
- max_fcount.val := None;
- if backtrack_trace.val then
- Printf.eprintf "%sbfparse_parsable [%s]\n%!" tind.val entry.ename
- else ();
+ floc := p.pa_loc_func;
+ max_fcount := None;
+ if !backtrack_trace then
+ Printf.eprintf "%sbfparse_parsable [%s]\n%!" !tind entry.ename;
bfparse entry efun restore2 p
-};
-value fparse_token_stream entry ts =
+let fparse_token_stream entry ts =
let efun err fts =
match entry.fstart 0 err fts with
- | Some (a, _) -> Obj.magic a
+ Some (a, _) -> Obj.magic a
| None -> raise Stream.Failure
- end
in
bfparse_token_stream entry efun ts
-;
-value fparse_parsable entry p =
+let fparse_parsable entry p =
let efun err fts =
match entry.fstart 0 err fts with
- [ Some (r, strm) -> do { p.pa_tok_fstrm := strm; r }
- | None -> raise Stream.Failure ]
+ Some (r, strm) -> p.pa_tok_fstrm <- strm; r
+ | None -> raise Stream.Failure
in
bfparse_parsable entry p efun
-;
-value bparse_token_stream entry ts =
+let bparse_token_stream entry ts =
let efun err fts =
match entry.bstart 0 err fts with
- | Some (a, _, _) -> Obj.magic a
+ Some (a, _, _) -> Obj.magic a
| None -> raise Stream.Failure
- end
in
bfparse_token_stream entry efun ts
-;
-value bparse_parsable entry p =
+let bparse_parsable entry p =
let efun err fts =
match entry.bstart 0 err fts with
- [ Some (r, strm, _) -> do { p.pa_tok_fstrm := strm; r }
- | None -> raise Stream.Failure ]
+ Some (r, strm, _) -> p.pa_tok_fstrm <- strm; r
+ | None -> raise Stream.Failure
in
bfparse_parsable entry p efun
-;
-value bparse_parsable_all entry p = do {
+let bparse_parsable_all entry p =
let efun = entry.bstart 0 in
let fts = p.pa_tok_fstrm in
let cs = p.pa_chr_strm in
let fun_loc = p.pa_loc_func in
let restore =
- let old_floc = floc.val in
- let old_tc = token_count.val in
- let old_max_fcount = max_fcount.val in
- let old_nb_ftry = nb_ftry.val in
- fun () -> do {
- floc.val := old_floc;
- token_count.val := old_tc;
- max_fcount.val := old_max_fcount;
- nb_ftry.val := old_nb_ftry;
- }
+ let old_floc = !floc in
+ let old_tc = !token_count in
+ let old_max_fcount = !max_fcount in
+ let old_nb_ftry = !nb_ftry in
+ fun () ->
+ floc := old_floc;
+ token_count := old_tc;
+ max_fcount := old_max_fcount;
+ nb_ftry := old_nb_ftry
in
- floc.val := fun_loc;
- token_count.val := 0;
- max_fcount.val := None;
- if backtrack_trace.val then
+ floc := fun_loc;
+ token_count := 0;
+ max_fcount := None;
+ if !backtrack_trace then
Printf.eprintf "%sbparse_parsable_all [%s]: max token count reset\n%!"
- tind.val entry.ename
- else
- nb_ftry.val := 0;
- if backtrack_trace_try.val then do {
- Printf.eprintf "\n";
- flush stderr;
- }
- else ();
- try do {
+ !tind entry.ename
+ else nb_ftry := 0;
+ if !backtrack_trace_try then begin Printf.eprintf "\n"; flush stderr end;
+ try
let rl =
- loop [] (efun no_err fts) where rec loop rev_rl =
- fun
- [ Some (r, strm, k) ->
+ let rec loop rev_rl =
+ function
+ Some (r, strm, k) ->
let _ =
- if backtrack_trace.val then do {
- Printf.eprintf "result found !\n\n";
- flush stderr;
- }
- else ()
+ if !backtrack_trace then
+ begin Printf.eprintf "result found !\n\n"; flush stderr end
in
- loop [r :: rev_rl] (Fstream.bcontinue k)
- | None -> List.rev rev_rl ]
+ loop (r :: rev_rl) (Fstream.bcontinue k)
+ | None -> List.rev rev_rl
+ in
+ loop [] (efun no_err fts)
in
- restore ();
- rl
- }
- with exc -> do {
- let loc = (Stream.count cs, Stream.count cs + 1) in
- restore ();
- Ploc.raise (Ploc.make_unlined loc) exc
- }
-};
-
-value find_entry e s =
+ restore (); rl
+ with exc ->
+ let loc = Stream.count cs, Stream.count cs + 1 in
+ restore (); Ploc.raise (Ploc.make_unlined loc) exc
+
+let find_entry e s =
let rec find_levels =
- fun
- [ [] -> None
- | [lev :: levs] ->
+ function
+ [] -> None
+ | lev :: levs ->
match find_tree lev.lsuffix with
- [ None ->
- match find_tree lev.lprefix with
- [ None -> find_levels levs
- | x -> x ]
- | x -> x ] ]
+ None ->
+ begin match find_tree lev.lprefix with
+ None -> find_levels levs
+ | x -> x
+ end
+ | x -> x
and find_symbol =
- fun
- [ Sfacto s -> find_symbol s
+ function
+ Sfacto s -> find_symbol s
| Snterm e -> if e.ename = s then Some e else None
- | Snterml e _ -> if e.ename = s then Some e else None
- | Smeta _ sl _ -> find_symbol_list sl
+ | Snterml (e, _) -> if e.ename = s then Some e else None
+ | Smeta (_, sl, _) -> find_symbol_list sl
| Slist0 s -> find_symbol s
- | Slist0sep s _ _ -> find_symbol s
+ | Slist0sep (s, _, _) -> find_symbol s
| Slist1 s -> find_symbol s
- | Slist1sep s _ _ -> find_symbol s
+ | Slist1sep (s, _, _) -> find_symbol s
| Sopt s -> find_symbol s
| Sflag s -> find_symbol s
| Stree t -> find_tree t
- | Svala _ s -> find_symbol s
- | Sself | Snext | Scut | Stoken _ -> None ]
+ | Svala (_, s) -> find_symbol s
+ | Sself | Snext | Scut | Stoken _ -> None
and find_symbol_list =
- fun
- [ [s :: sl] ->
- match find_symbol s with
- [ None -> find_symbol_list sl
- | x -> x ]
- | [] -> None ]
+ function
+ s :: sl ->
+ begin match find_symbol s with
+ None -> find_symbol_list sl
+ | x -> x
+ end
+ | [] -> None
and find_tree =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- match find_symbol s with
- [ None ->
- match find_tree bro with
- [ None -> find_tree son
- | x -> x ]
- | x -> x ]
- | LocAct _ _ | DeadEnd -> None ]
+ function
+ Node {node = s; brother = bro; son = son} ->
+ begin match find_symbol s with
+ None ->
+ begin match find_tree bro with
+ None -> find_tree son
+ | x -> x
+ end
+ | x -> x
+ end
+ | LocAct (_, _) | DeadEnd -> None
in
match e.edesc with
- [ Dlevels levs ->
- match find_levels levs with
- [ Some e -> e
- | None -> raise Not_found ]
- | Dparser _ -> raise Not_found ]
-;
-
-value bfparser_of_parser p fstrm return_value = do {
+ Dlevels levs ->
+ begin match find_levels levs with
+ Some e -> e
+ | None -> raise Not_found
+ end
+ | Dparser _ -> raise Not_found
+
+let bfparser_of_parser p fstrm return_value =
let shift_token_number = Fstream.count fstrm in
- let old_floc = floc.val in
- let restore () = floc.val := old_floc in
- floc.val := fun i -> old_floc (shift_token_number + i);
+ let old_floc = !floc in
+ let restore () = floc := old_floc in
+ floc := (fun i -> old_floc (shift_token_number + i));
let ts =
let fts = ref fstrm in
Stream.from
(fun _ ->
- match Fstream.next fts.val with
- [ Some (v, fstrm) -> do { fts.val := fstrm; Some v }
- | None -> None ])
+ match Fstream.next !fts with
+ Some (v, fstrm) -> fts := fstrm; Some v
+ | None -> None)
in
let r =
try
- let r = (Obj.magic p ts : Obj.t) in
+ let r : Obj.t = Obj.magic p ts in
let fstrm =
- loop fstrm (Stream.count ts) where rec loop fstrm i =
+ let rec loop fstrm i =
if i = 0 then fstrm
else
match Fstream.next fstrm with
- [ Some (_, fstrm) -> loop fstrm (i - 1)
- | None -> failwith "internal error in Entry.of_parser" ]
+ Some (_, fstrm) -> loop fstrm (i - 1)
+ | None -> failwith "internal error in Entry.of_parser"
+ in
+ loop fstrm (Stream.count ts)
in
return_value r fstrm
- with e -> do {
+ with e ->
restore ();
match e with
- | Stream.Failure -> None
+ Stream.Failure -> None
| _ -> raise e
- end
- }
in
- do { restore (); r }
-};
+ restore (); r
-value fparser_of_parser p err fstrm =
- let return_value r fstrm = match fstrm with fparser [: :] -> r in
+let fparser_of_parser p err fstrm =
+ let return_value r fstrm =
+ let (strm__ : _ Fstream.t) = fstrm in Some (r, strm__)
+ in
bfparser_of_parser p fstrm return_value
-;
-value bparser_of_parser p err fstrm =
- let return_value r fstrm = match fstrm with bparser [: :] -> r in
+let bparser_of_parser p err fstrm =
+ let return_value r fstrm =
+ let (strm__ : _ Fstream.t) = fstrm in Fstream.b_act r strm__
+ in
bfparser_of_parser p fstrm return_value
-;
module Entry =
struct
- type te = token;
- type e 'a = g_entry te;
- value create g n =
- {egram = g; ename = n; elocal = False; estart = empty_entry n;
- econtinue _ _ _ = parser []; fstart _ _ = fparser [];
- fcontinue _ _ _ _ = fparser []; bstart _ _ = bparser [];
- bcontinue _ _ _ _ = bparser []; edesc = Dlevels []}
- ;
- value parse_parsable (entry : e 'a) p : 'a =
+ type te = token
+ type 'a e = te g_entry
+ let create g n =
+ {egram = g; ename = n; elocal = false; estart = empty_entry n;
+ econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
+ fstart = (fun _ _ (strm__ : _ Fstream.t) -> None);
+ fcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ bstart = (fun _ _ (strm__ : _ Fstream.t) -> None);
+ bcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ edesc = Dlevels []}
+ let parse_parsable (entry : 'a e) p : 'a =
let _ = compatible_deprecated_backtrack_parse () in
match entry.egram.galgo with
- [ DefaultAlgorithm ->
- match default_algorithm_var.val with
- | Predictive | DefaultAlgorithm ->
+ DefaultAlgorithm ->
+ begin match !default_algorithm_var with
+ Predictive | DefaultAlgorithm ->
Obj.magic (parse_parsable entry p : Obj.t)
- | Backtracking ->
- Obj.magic (bparse_parsable entry p : Obj.t)
- | Functional ->
- Obj.magic (fparse_parsable entry p : Obj.t)
+ | Backtracking -> Obj.magic (bparse_parsable entry p : Obj.t)
+ | Functional -> Obj.magic (fparse_parsable entry p : Obj.t)
end
- | Predictive ->
- Obj.magic (parse_parsable entry p : Obj.t)
- | Functional ->
- Obj.magic (fparse_parsable entry p : Obj.t)
- | Backtracking ->
- Obj.magic (bparse_parsable entry p : Obj.t) ]
- ;
- value parse (entry : e 'a) cs : 'a =
- let parsable = parsable entry.egram cs in
- parse_parsable entry parsable
- ;
- value parse_parsable_all (entry : e 'a) p : 'a =
+ | Predictive -> Obj.magic (parse_parsable entry p : Obj.t)
+ | Functional -> Obj.magic (fparse_parsable entry p : Obj.t)
+ | Backtracking -> Obj.magic (bparse_parsable entry p : Obj.t)
+ let parse (entry : 'a e) cs : 'a =
+ let parsable = parsable entry.egram cs in parse_parsable entry parsable
+ let parse_parsable_all (entry : 'a e) p : 'a =
let _ = compatible_deprecated_backtrack_parse () in
match entry.egram.galgo with
- [ DefaultAlgorithm ->
- match default_algorithm_var.val with
- | Predictive | DefaultAlgorithm ->
- try Obj.magic [(parse_parsable entry p : Obj.t)] with
- [ Stream.Failure | Stream.Error _ -> [] ]
+ DefaultAlgorithm ->
+ begin match !default_algorithm_var with
+ Predictive | DefaultAlgorithm ->
+ begin try Obj.magic [(parse_parsable entry p : Obj.t)] with
+ Stream.Failure | Stream.Error _ -> []
+ end
| Backtracking ->
- Obj.magic (bparse_parsable_all entry p : list Obj.t)
+ Obj.magic (bparse_parsable_all entry p : Obj.t list)
| Functional ->
failwith "Entry.parse_parsable_all: func parsing not impl"
end
| Predictive ->
- try Obj.magic [(parse_parsable entry p : Obj.t)] with
- [ Stream.Failure | Stream.Error _ -> [] ]
+ begin try Obj.magic [(parse_parsable entry p : Obj.t)] with
+ Stream.Failure | Stream.Error _ -> []
+ end
| Functional ->
failwith "parse_parsable_all: functional parsing not impl"
- | Backtracking ->
- Obj.magic (bparse_parsable_all entry p : list Obj.t) ]
- ;
- value parse_all (entry : e 'a) cs : 'a =
+ | Backtracking -> Obj.magic (bparse_parsable_all entry p : Obj.t list)
+ let parse_all (entry : 'a e) cs : 'a =
let parsable = parsable entry.egram cs in
parse_parsable_all entry parsable
- ;
- value parse_token_stream (entry : e 'a) ts : 'a =
+ let parse_token_stream (entry : 'a e) ts : 'a =
let _ = compatible_deprecated_backtrack_parse () in
match entry.egram.galgo with
- | DefaultAlgorithm ->
- match default_algorithm_var.val with
- | Predictive | DefaultAlgorithm ->
+ DefaultAlgorithm ->
+ begin match !default_algorithm_var with
+ Predictive | DefaultAlgorithm ->
Obj.magic (entry.estart 0 ts : Obj.t)
| Backtracking ->
failwith "not impl Entry.parse_token_stream default backtrack"
@@ -2414,14 +2622,10 @@ module Entry =
failwith "Entry.parse_token_stream: func parsing not impl"
end
| Predictive -> Obj.magic (entry.estart 0 ts : Obj.t)
- | Functional ->
- failwith "not impl Entry.parse_token_stream functional"
- | Backtracking ->
- failwith "not impl Entry.parse_token_stream backtrack"
- end
- ;
- value warned_using_parse_token = ref False;
- value parse_token (entry : e 'a) ts : 'a = do {
+ | Functional -> failwith "not impl Entry.parse_token_stream functional"
+ | Backtracking -> failwith "not impl Entry.parse_token_stream backtrack"
+ let warned_using_parse_token = ref false
+ let parse_token (entry : 'a e) ts : 'a =
(* commented: too often warned in Coq...
if not warned_using_parse_token.val then do {
eprintf "<W> use of Grammar.Entry.parse_token ";
@@ -2432,205 +2636,179 @@ module Entry =
else ();
*)
parse_token_stream entry ts
- };
- value name e = e.ename;
- value of_parser g n (p : Stream.t te -> 'a) : e 'a =
- {egram = g; ename = n; elocal = False;
- estart _ = (Obj.magic p : Stream.t te -> Obj.t);
- econtinue _ _ _ = parser [];
- fstart _ = fparser_of_parser p;
- fcontinue _ _ _ _ = fparser [];
- bstart _ = bparser_of_parser p;
- bcontinue _ _ _ _ = bparser [];
- edesc = Dparser (Obj.magic p : Stream.t te -> Obj.t)}
- ;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- value print ppf e = fprintf ppf "%a@." print_entry (obj e);
- value find e s = find_entry (obj e) s;
+ let name e = e.ename
+ let of_parser g n (p : te Stream.t -> 'a) : 'a e =
+ {egram = g; ename = n; elocal = false;
+ estart = (fun _ -> (Obj.magic p : te Stream.t -> Obj.t));
+ econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
+ fstart = (fun _ -> fparser_of_parser p);
+ fcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ bstart = (fun _ -> bparser_of_parser p);
+ bcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ edesc = Dparser (Obj.magic p : te Stream.t -> Obj.t)}
+ external obj : 'a e -> te Gramext.g_entry = "%identity"
+ let print ppf e = fprintf ppf "%a@." print_entry (obj e)
+ let find e s = find_entry (obj e) s
end
-;
-value of_entry e = e.egram;
+let of_entry e = e.egram
-value create_local_entry g n =
- {egram = g; ename = n; elocal = True; estart = empty_entry n;
- econtinue _ _ _ = parser []; fstart _ _ = fparser [];
- fcontinue _ _ _ _ = fparser []; bstart _ _ = bparser [];
- bcontinue _ _ _ _ = bparser []; edesc = Dlevels []}
-;
+let create_local_entry g n =
+ {egram = g; ename = n; elocal = true; estart = empty_entry n;
+ econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
+ fstart = (fun _ _ (strm__ : _ Fstream.t) -> None);
+ fcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ bstart = (fun _ _ (strm__ : _ Fstream.t) -> None);
+ bcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ edesc = Dlevels []}
(* Unsafe *)
-value clear_entry e = do {
- e.estart := fun _ -> parser [];
- e.econtinue := fun _ _ _ -> parser [];
- e.fstart := fun _ _ -> fparser [];
- e.fcontinue := fun _ _ _ _ -> fparser [];
- e.bstart := fun _ _ -> bparser [];
- e.bcontinue := fun _ _ _ _ -> bparser [];
+let clear_entry e =
+ e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure);
+ e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
+ e.fstart <- (fun _ _ (strm__ : _ Fstream.t) -> None);
+ e.fcontinue <- (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ e.bstart <- (fun _ _ (strm__ : _ Fstream.t) -> None);
+ e.bcontinue <- (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
match e.edesc with
- [ Dlevels _ -> e.edesc := Dlevels []
- | Dparser _ -> () ]
-};
+ Dlevels _ -> e.edesc <- Dlevels []
+ | Dparser _ -> ()
-value gram_reinit g glexer = do {
- Hashtbl.clear g.gtokens;
- g.glexer := glexer
-};
+let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer
module Unsafe =
struct
- value gram_reinit = gram_reinit;
- value clear_entry = clear_entry;
+ let gram_reinit = gram_reinit
+ let clear_entry = clear_entry
end
-;
(* Functorial interface *)
-module type GLexerType =
- sig
- type te = 'x;
- value lexer : Plexing.lexer te;
- end
-;
+module type GLexerType = sig type te val lexer : te Plexing.lexer end
module type S =
sig
- type te = 'x;
- type parsable = 'x;
- value parsable : Stream.t char -> parsable;
- value tokens : string -> list (string * int);
- value glexer : Plexing.lexer te;
- value set_algorithm : parse_algorithm -> unit;
+ type te
+ type parsable
+ val parsable : char Stream.t -> parsable
+ val tokens : string -> (string * int) list
+ val glexer : te Plexing.lexer
+ val set_algorithm : parse_algorithm -> unit
module Entry :
sig
- type e 'a = 'x;
- value create : string -> e 'a;
- value parse : e 'a -> parsable -> 'a;
- value name : e 'a -> string;
- value of_parser : string -> (Stream.t te -> 'a) -> e 'a;
- value parse_token_stream : e 'a -> Stream.t te -> 'a;
- value print : Format.formatter -> e 'a -> unit;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- value parse_token : e 'a -> Stream.t te -> 'a;
+ type 'a e
+ val create : string -> 'a e
+ val parse : 'a e -> parsable -> 'a
+ val name : 'a e -> string
+ val of_parser : string -> (te Stream.t -> 'a) -> 'a e
+ val parse_token_stream : 'a e -> te Stream.t -> 'a
+ val print : Format.formatter -> 'a e -> unit
+ external obj : 'a e -> te Gramext.g_entry = "%identity"
+ val parse_token : 'a e -> te Stream.t -> 'a
end
- ;
- type ty_symbol 'self 'a = 'x;
- (** Type of grammar symbols. A type-safe wrapper around Gramext.symbol. The
- first type argument is the type of the ambient entry, the second one is the
- type of the produced value. *)
-
- type ty_rule 'self 'f 'r = 'x;
-
- type ty_production 'a = 'x;
-
- value s_facto : ty_symbol 'self 'a -> ty_symbol 'self 'a;
- (* | Smeta of string and list (g_symbol 'te) and Obj.t *)
- value s_nterm : Entry.e 'a -> ty_symbol 'self 'a;
- value s_nterml : Entry.e 'a -> string -> ty_symbol 'self 'a;
- value s_list0 : ty_symbol 'self 'a -> ty_symbol 'self (list 'a);
- value s_list0sep : ty_symbol 'self 'a -> ty_symbol 'self 'b -> bool -> ty_symbol 'self (list 'a);
- value s_list1 : ty_symbol 'self 'a -> ty_symbol 'self (list 'a);
- value s_list1sep : ty_symbol 'self 'a -> ty_symbol 'self 'b -> bool -> ty_symbol 'self (list 'a);
- value s_opt : ty_symbol 'self 'a -> ty_symbol 'self (option 'a);
- value s_flag : ty_symbol 'self 'a -> ty_symbol 'self bool;
- value s_self : ty_symbol 'self 'self;
- value s_next : ty_symbol 'self 'self;
- value s_token : Plexing.pattern -> ty_symbol 'self string;
- value s_rules : list (ty_production 'a) -> ty_symbol 'self 'a;
- value s_vala : list string -> ty_symbol 'self 'a -> ty_symbol 'self (Ploc.vala 'a);
-
- value r_stop : ty_rule 'self 'r 'r;
- value r_next : ty_rule 'self 'a 'r -> ty_symbol 'self 'b -> ty_rule 'self ('b -> 'a) 'r;
- value r_cut : ty_rule 'self 'a 'r -> ty_rule 'self 'a 'r;
-
- value production : (ty_rule 'a 'f (Ploc.t -> 'a) * 'f) -> ty_production 'a;
-
+ type ('self, 'a) ty_symbol
+ type ('self, 'f, 'r) ty_rule
+ type 'a ty_production
+ val s_facto : ('self, 'a) ty_symbol -> ('self, 'a) ty_symbol
+ val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol
+ val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol
+ val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol
+ val s_list0sep :
+ ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool ->
+ ('self, 'a list) ty_symbol
+ val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol
+ val s_list1sep :
+ ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool ->
+ ('self, 'a list) ty_symbol
+ val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol
+ val s_flag : ('self, 'a) ty_symbol -> ('self, bool) ty_symbol
+ val s_self : ('self, 'self) ty_symbol
+ val s_next : ('self, 'self) ty_symbol
+ val s_token : Plexing.pattern -> ('self, string) ty_symbol
+ val s_rules : 'a ty_production list -> ('self, 'a) ty_symbol
+ val s_vala :
+ string list -> ('self, 'a) ty_symbol -> ('self, 'a Ploc.vala) ty_symbol
+ val r_stop : ('self, 'r, 'r) ty_rule
+ val r_next :
+ ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol ->
+ ('self, 'b -> 'a, 'r) ty_rule
+ val r_cut : ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule
+ val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production
module Unsafe :
sig
- value gram_reinit : Plexing.lexer te -> unit;
- value clear_entry : Entry.e 'a -> unit;
+ val gram_reinit : te Plexing.lexer -> unit
+ val clear_entry : 'a Entry.e -> unit
end
- ;
- value extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol te) * Gramext.g_action)) ->
- unit;
- value safe_extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (ty_production 'a)) ->
- unit;
- value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit;
- value safe_delete_rule : Entry.e 'a -> ty_rule 'a 'r 'f -> unit;
+ val extend :
+ 'a Entry.e -> Gramext.position option ->
+ (string option * Gramext.g_assoc option *
+ (te Gramext.g_symbol list * Gramext.g_action) list)
+ list ->
+ unit
+ val safe_extend :
+ 'a Entry.e -> Gramext.position option ->
+ (string option * Gramext.g_assoc option * 'a ty_production list)
+ list ->
+ unit
+ val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit
+ val safe_delete_rule : 'a Entry.e -> ('a, 'r, 'f) ty_rule -> unit
end
-;
module GMake (L : GLexerType) =
struct
- type te = L.te;
- type parsable = gen_parsable te;
- value gram = gcreate L.lexer;
- value parsable cs =
+ type te = L.te
+ type parsable = te gen_parsable
+ let gram = gcreate L.lexer
+ let parsable cs =
let (ts, lf) = L.lexer.Plexing.tok_func cs in
let fts = fstream_of_stream ts in
{pa_chr_strm = cs; pa_tok_strm = ts; pa_tok_fstrm = fts;
pa_loc_func = lf}
- ;
- value tokens = tokens gram;
- value glexer = glexer gram;
- value set_algorithm algo = gram.galgo := algo;
+ let tokens = tokens gram
+ let glexer = glexer gram
+ let set_algorithm algo = gram.galgo <- algo
module Entry =
struct
- type e 'a = g_entry te;
- value create n =
- {egram = gram; ename = n; elocal = False; estart = empty_entry n;
- econtinue _ _ _ = parser []; fstart _ _ = fparser [];
- fcontinue _ _ _ _ = bparser []; bstart _ _ = bparser [];
- bcontinue _ _ _ _ = bparser []; edesc = Dlevels []}
- ;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- value parse (e : e 'a) p : 'a =
+ type 'a e = te g_entry
+ let create n =
+ {egram = gram; ename = n; elocal = false; estart = empty_entry n;
+ econtinue =
+ (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
+ fstart = (fun _ _ (strm__ : _ Fstream.t) -> None);
+ fcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ bstart = (fun _ _ (strm__ : _ Fstream.t) -> None);
+ bcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ edesc = Dlevels []}
+ external obj : 'a e -> te Gramext.g_entry = "%identity"
+ let parse (e : 'a e) p : 'a =
let _ = compatible_deprecated_backtrack_parse () in
match gram.galgo with
- [ DefaultAlgorithm ->
- match default_algorithm_var.val with
- | Predictive | DefaultAlgorithm ->
+ DefaultAlgorithm ->
+ begin match !default_algorithm_var with
+ Predictive | DefaultAlgorithm ->
Obj.magic (parse_parsable e p : Obj.t)
- | Backtracking ->
- Obj.magic (bparse_parsable e p : Obj.t)
- | Functional ->
- Obj.magic (fparse_parsable e p : Obj.t)
+ | Backtracking -> Obj.magic (bparse_parsable e p : Obj.t)
+ | Functional -> Obj.magic (fparse_parsable e p : Obj.t)
end
- | Predictive ->
- Obj.magic (parse_parsable e p : Obj.t)
- | Functional ->
- Obj.magic (fparse_parsable e p : Obj.t)
- | Backtracking ->
- Obj.magic (bparse_parsable e p : Obj.t) ]
- ;
- value parse_token_stream (e : e 'a) ts : 'a =
+ | Predictive -> Obj.magic (parse_parsable e p : Obj.t)
+ | Functional -> Obj.magic (fparse_parsable e p : Obj.t)
+ | Backtracking -> Obj.magic (bparse_parsable e p : Obj.t)
+ let parse_token_stream (e : 'a e) ts : 'a =
let _ = compatible_deprecated_backtrack_parse () in
match e.egram.galgo with
- | DefaultAlgorithm ->
- match default_algorithm_var.val with
- | Predictive | DefaultAlgorithm ->
+ DefaultAlgorithm ->
+ begin match !default_algorithm_var with
+ Predictive | DefaultAlgorithm ->
Obj.magic (e.estart 0 ts : Obj.t)
- | Backtracking ->
- bparse_token_stream e ts
- | Functional ->
- fparse_token_stream e ts
+ | Backtracking -> bparse_token_stream e ts
+ | Functional -> fparse_token_stream e ts
end
| Predictive -> Obj.magic (e.estart 0 ts : Obj.t)
| Functional -> fparse_token_stream e ts
| Backtracking -> bparse_token_stream e ts
- end
- ;
- value warned_using_parse_token = ref False;
- value parse_token (entry : e 'a) ts : 'a = do {
+ let warned_using_parse_token = ref false
+ let parse_token (entry : 'a e) ts : 'a =
(* commented: too often warned in Coq...
if not warned_using_parse_token.val then do {
eprintf "<W> use of Entry.parse_token ";
@@ -2641,55 +2819,53 @@ module GMake (L : GLexerType) =
else ();
*)
parse_token_stream entry ts
- };
- value name e = e.ename;
- value of_parser n (p : Stream.t te -> 'a) : e 'a =
- {egram = gram; ename = n; elocal = False;
- estart _ = (Obj.magic p : Stream.t te -> Obj.t);
- econtinue _ _ _ = parser [];
- fstart _ = fparser_of_parser p;
- fcontinue _ _ _ _ = fparser [];
- bstart _ = bparser_of_parser p;
- bcontinue _ _ _ _ = bparser [];
- edesc = Dparser (Obj.magic p : Stream.t te -> Obj.t)}
- ;
- value print ppf e = fprintf ppf "%a@." print_entry (obj e);
+ let name e = e.ename
+ let of_parser n (p : te Stream.t -> 'a) : 'a e =
+ {egram = gram; ename = n; elocal = false;
+ estart = (fun _ -> (Obj.magic p : te Stream.t -> Obj.t));
+ econtinue =
+ (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
+ fstart = (fun _ -> fparser_of_parser p);
+ fcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ bstart = (fun _ -> bparser_of_parser p);
+ bcontinue = (fun _ _ _ _ (strm__ : _ Fstream.t) -> None);
+ edesc = Dparser (Obj.magic p : te Stream.t -> Obj.t)}
+ let print ppf e = fprintf ppf "%a@." print_entry (obj e)
end
- ;
- type ty_symbol 'self 'a = Gramext.g_symbol te;
- type ty_rule 'self 'f 'r = list (ty_symbol 'self Obj.t);
- type ty_production 'a = (ty_rule 'a Obj.t Obj.t * Gramext.g_action);
-
- value s_facto s = Sfacto s;
- value s_nterm e = Snterm e;
- value s_nterml e l = Snterml e l;
- value s_list0 s = Slist0 s;
- value s_list0sep s sep b = Slist0sep s sep b;
- value s_list1 s = Slist1 s;
- value s_list1sep s sep b = Slist1sep s sep b;
- value s_opt s = Sopt s;
- value s_flag s = Sflag s;
- value s_self = Sself;
- value s_next = Snext;
- value s_token tok = Stoken tok;
- value s_rules (t : list (ty_production Obj.t)) = Gramext.srules (Obj.magic t);
- value s_vala sl s = Svala sl s;
-
- value r_stop = [];
- value r_next r s = r @ [s];
- value r_cut r = r @ [Scut];
-
- value production (p : (ty_rule 'a 'f (Ploc.t -> 'a) * 'f)) = (Obj.magic p : ty_production 'a);
-
+ type ('self, 'a) ty_symbol = te Gramext.g_symbol
+ type ('self, 'f, 'r) ty_rule = ('self, Obj.t) ty_symbol list
+ type 'a ty_production = ('a, Obj.t, Obj.t) ty_rule * Gramext.g_action
+ let s_facto s = Sfacto s
+ let s_nterm e = Snterm e
+ let s_nterml e l = Snterml (e, l)
+ let s_list0 s = Slist0 s
+ let s_list0sep s sep b = Slist0sep (s, sep, b)
+ let s_list1 s = Slist1 s
+ let s_list1sep s sep b = Slist1sep (s, sep, b)
+ let s_opt s = Sopt s
+ let s_flag s = Sflag s
+ let s_self = Sself
+ let s_next = Snext
+ let s_token tok = Stoken tok
+ let s_rules (t : Obj.t ty_production list) = Gramext.srules (Obj.magic t)
+ let s_vala sl s = Svala (sl, s)
+ let r_stop = []
+ let r_next r s = r @ [s]
+ let r_cut r = r @ [Scut]
+ let production
+ (p : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f) : 'a ty_production =
+ Obj.magic p
module Unsafe =
struct
- value gram_reinit = gram_reinit gram;
- value clear_entry = clear_entry;
+ let gram_reinit = gram_reinit gram
+ let clear_entry = clear_entry
end
- ;
- value extend = extend_entry;
- value safe_extend e pos (r : list (option string * option Gramext.g_assoc * list (ty_production Obj.t))) = extend e pos (Obj.magic r);
- value delete_rule e r = delete_rule (Entry.obj e) r;
- value safe_delete_rule = delete_rule;
+ let extend = extend_entry
+ let safe_extend e pos
+ (r :
+ (string option * Gramext.g_assoc option * Obj.t ty_production list)
+ list) =
+ extend e pos (Obj.magic r)
+ let delete_rule e r = delete_rule (Entry.obj e) r
+ let safe_delete_rule = delete_rule
end
-;
diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli
index ae2fa25f2f..fcc98531b6 100644
--- a/gramlib/grammar.mli
+++ b/gramlib/grammar.mli
@@ -8,14 +8,14 @@
Grammars entries can be extended using the [EXTEND] statement,
added by loading the Camlp5 [pa_extend.cmo] file. *)
-type g = 'x;
+type g
(** The type for grammars, holding entries. *)
-type token = (string * string);
+type token = string * string
-value gcreate : Plexing.lexer token -> g;
+val gcreate : token Plexing.lexer -> g
(** Create a new grammar, without keywords, using the lexer given
as parameter. *)
-value tokens : g -> string -> list (string * int);
+val tokens : g -> string -> (string * int) list
(** Given a grammar and a token pattern constructor, returns the list of
the corresponding values currently used in all entries of this grammar.
The integer is the number of times this pattern value is used.
@@ -24,32 +24,30 @@ value tokens : g -> string -> list (string * int);
- The call [Grammar.tokens g ""] returns the keywords list.
- The call [Grammar.tokens g "IDENT"] returns the list of all usages
of the pattern "IDENT" in the [EXTEND] statements. *)
-value glexer : g -> Plexing.lexer token;
+val glexer : g -> token Plexing.lexer
(** Return the lexer used by the grammar *)
-type parsable = 'abstract;
-value parsable : g -> Stream.t char -> parsable;
+type parsable
+val parsable : g -> char Stream.t -> parsable
(** Type and value allowing to keep the same token stream between
several calls of entries of the same grammar, to prevent possible
loss of tokens. To be used with [Entry.parse_parsable] below *)
module Entry :
sig
- type e 'a = 'x;
- value create : g -> string -> e 'a;
- value parse : e 'a -> Stream.t char -> 'a;
- value parse_all : e 'a -> Stream.t char -> list 'a;
- value parse_parsable : e 'a -> parsable -> 'a;
- value name : e 'a -> string;
- value of_parser : g -> string -> (Stream.t token -> 'a) -> e 'a;
- value parse_token_stream : e 'a -> Stream.t token -> 'a;
- value print : Format.formatter -> e 'a -> unit;
- value find : e 'a -> string -> e Obj.t;
- external obj : e 'a -> Gramext.g_entry token = "%identity";
- (* deprecated since 2017-06-17 *)
- value parse_token : e 'a -> Stream.t token -> 'a;
+ type 'a e
+ val create : g -> string -> 'a e
+ val parse : 'a e -> char Stream.t -> 'a
+ val parse_all : 'a e -> char Stream.t -> 'a list
+ val parse_parsable : 'a e -> parsable -> 'a
+ val name : 'a e -> string
+ val of_parser : g -> string -> (token Stream.t -> 'a) -> 'a e
+ val parse_token_stream : 'a e -> token Stream.t -> 'a
+ val print : Format.formatter -> 'a e -> unit
+ val find : 'a e -> string -> Obj.t e
+ external obj : 'a e -> token Gramext.g_entry = "%identity"
+ val parse_token : 'a e -> token Stream.t -> 'a
end
-;
(** Module to handle entries.
- [Entry.e] is the type for entries returning values of type ['a].
- [Entry.create g n] creates a new entry named [n] in the grammar [g].
@@ -70,56 +68,64 @@ module Entry :
- [Entry.parse_token]: deprecated since 2017-06-16; old name for
[Entry.parse_token_stream] *)
-value of_entry : Entry.e 'a -> g;
+val of_entry : 'a Entry.e -> g
(** Return the grammar associated with an entry. *)
-type ty_symbol 'self 'a = 'x;
+type ('self, 'a) ty_symbol
(** Type of grammar symbols. A type-safe wrapper around Gramext.symbol. The
first type argument is the type of the ambient entry, the second one is the
type of the produced value. *)
-type ty_rule 'self 'f 'r = 'x;
+type ('self, 'f, 'r) ty_rule
-type ty_production 'a = 'x;
+type 'a ty_production
-type ty_extension = 'x;
+type ty_extension
-value s_facto : ty_symbol 'self 'a -> ty_symbol 'self 'a;
+val s_facto : ('self, 'a) ty_symbol -> ('self, 'a) ty_symbol
(* | Smeta of string and list (g_symbol 'te) and Obj.t *)
-value s_nterm : Entry.e 'a -> ty_symbol 'self 'a;
-value s_nterml : Entry.e 'a -> string -> ty_symbol 'self 'a;
-value s_list0 : ty_symbol 'self 'a -> ty_symbol 'self (list 'a);
-value s_list0sep : ty_symbol 'self 'a -> ty_symbol 'self 'b -> bool -> ty_symbol 'self (list 'a);
-value s_list1 : ty_symbol 'self 'a -> ty_symbol 'self (list 'a);
-value s_list1sep : ty_symbol 'self 'a -> ty_symbol 'self 'b -> bool -> ty_symbol 'self (list 'a);
-value s_opt : ty_symbol 'self 'a -> ty_symbol 'self (option 'a);
-value s_flag : ty_symbol 'self 'a -> ty_symbol 'self bool;
-value s_self : ty_symbol 'self 'self;
-value s_next : ty_symbol 'self 'self;
-value s_token : Plexing.pattern -> ty_symbol 'self string;
-value s_rules : list (ty_production 'a) -> ty_symbol 'self 'a;
-value s_vala : list string -> ty_symbol 'self 'a -> ty_symbol 'self (Ploc.vala 'a);
-
-value r_stop : ty_rule 'self 'r 'r;
-value r_next : ty_rule 'self 'a 'r -> ty_symbol 'self 'b -> ty_rule 'self ('b -> 'a) 'r;
-value r_cut : ty_rule 'self 'a 'r -> ty_rule 'self 'a 'r;
-
-value production : (ty_rule 'a 'f (Ploc.t -> 'a) * 'f) -> ty_production 'a;
-
-value extension : Entry.e 'a -> option Gramext.position ->
- list (option string * option Gramext.g_assoc * list (ty_production 'a)) -> ty_extension;
-
-value safe_extend : list ty_extension -> unit;
-value safe_delete_rule : Entry.e 'a -> ty_rule 'a 'f 'r -> unit;
+val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol
+val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol
+val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol
+val s_list0sep :
+ ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool ->
+ ('self, 'a list) ty_symbol
+val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol
+val s_list1sep :
+ ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool ->
+ ('self, 'a list) ty_symbol
+val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol
+val s_flag : ('self, 'a) ty_symbol -> ('self, bool) ty_symbol
+val s_self : ('self, 'self) ty_symbol
+val s_next : ('self, 'self) ty_symbol
+val s_token : Plexing.pattern -> ('self, string) ty_symbol
+val s_rules : 'a ty_production list -> ('self, 'a) ty_symbol
+val s_vala :
+ string list -> ('self, 'a) ty_symbol -> ('self, 'a Ploc.vala) ty_symbol
+
+val r_stop : ('self, 'r, 'r) ty_rule
+val r_next :
+ ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol ->
+ ('self, 'b -> 'a, 'r) ty_rule
+val r_cut : ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule
+
+val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production
+
+val extension :
+ 'a Entry.e -> Gramext.position option ->
+ (string option * Gramext.g_assoc option * 'a ty_production list) list ->
+ ty_extension
+
+val safe_extend : ty_extension list -> unit
+val safe_delete_rule : 'a Entry.e -> ('a, 'f, 'r) ty_rule -> unit
(** {6 Clearing grammars and entries} *)
module Unsafe :
sig
- value gram_reinit : g -> Plexing.lexer token -> unit;
- value clear_entry : Entry.e 'a -> unit;
+ val gram_reinit : g -> token Plexing.lexer -> unit
+ val clear_entry : 'a Entry.e -> unit
end
-;
(** Module for clearing grammars and entries. To be manipulated with
care, because: 1) reinitializing a grammar destroys all tokens
and there may have problems with the associated lexer if there
@@ -132,9 +138,9 @@ module Unsafe :
(** {6 Parsing algorithm} *)
-type parse_algorithm = Gramext.parse_algorithm ==
- [ Predictive | Functional | Backtracking | DefaultAlgorithm ]
-;
+type parse_algorithm =
+ Gramext.parse_algorithm =
+ Predictive | Functional | Backtracking | DefaultAlgorithm
(** Type of algorithm used in grammar entries.
[Predictive]: use imperative streams with predictive parsing
[Functional]: use functional streams with limited backtracking
@@ -144,18 +150,18 @@ type parse_algorithm = Gramext.parse_algorithm ==
variablefound in the variable CAMLP5PARAM.
The default, when a grammar is created, is [DefaultAlgorithm]. *)
-value set_algorithm : g -> parse_algorithm -> unit;
+val set_algorithm : g -> parse_algorithm -> unit
(** Set the parsing algorithm for all entries of a given grammar. *)
-value set_default_algorithm : parse_algorithm -> unit;
+val set_default_algorithm : parse_algorithm -> unit
(** Set the default parsing algorithm for all grammars.
If the environment variable CAMLP5PARAM contains "b", the
default is [Backtracking]; if it contains 'f', the default is
[Functional]; if it contains 'p', the default is [Predictive]. *)
-value default_algorithm : unit -> parse_algorithm;
+val default_algorithm : unit -> parse_algorithm
(** Return the current default algorithm. *)
-value backtrack_stalling_limit : ref int;
+val backtrack_stalling_limit : int ref
(** Limitation of backtracking to prevent stalling in case of syntax
error. In backtracking algorithm, when there is a syntax error,
the parsing continues trying to find another solution. It some
@@ -173,91 +179,77 @@ value backtrack_stalling_limit : ref int;
rule "an entry cannot call an entry of another grammar" by
normal OCaml typing. *)
-module type GLexerType =
- sig
- type te = 'x;
- value lexer : Plexing.lexer te;
- end
-;
+module type GLexerType = sig type te val lexer : te Plexing.lexer end
(** The input signature for the functor [Grammar.GMake]: [te] is the
type of the tokens. *)
module type S =
sig
- type te = 'x;
- type parsable = 'x;
- value parsable : Stream.t char -> parsable;
- value tokens : string -> list (string * int);
- value glexer : Plexing.lexer te;
- value set_algorithm : parse_algorithm -> unit;
+ type te
+ type parsable
+ val parsable : char Stream.t -> parsable
+ val tokens : string -> (string * int) list
+ val glexer : te Plexing.lexer
+ val set_algorithm : parse_algorithm -> unit
module Entry :
sig
- type e 'a = 'y;
- value create : string -> e 'a;
- value parse : e 'a -> parsable -> 'a;
- value name : e 'a -> string;
- value of_parser : string -> (Stream.t te -> 'a) -> e 'a;
- value parse_token_stream : e 'a -> Stream.t te -> 'a;
- value print : Format.formatter -> e 'a -> unit;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- (* deprecated since 2017-06-17 *)
- value parse_token : e 'a -> Stream.t te -> 'a;
+ type 'a e
+ val create : string -> 'a e
+ val parse : 'a e -> parsable -> 'a
+ val name : 'a e -> string
+ val of_parser : string -> (te Stream.t -> 'a) -> 'a e
+ val parse_token_stream : 'a e -> te Stream.t -> 'a
+ val print : Format.formatter -> 'a e -> unit
+ external obj : 'a e -> te Gramext.g_entry = "%identity"
+ val parse_token : 'a e -> te Stream.t -> 'a
end
- ;
-
- type ty_symbol 'self 'a = 'x;
- (** Type of grammar symbols. A type-safe wrapper around Gramext.symbol. The
- first type argument is the type of the ambient entry, the second one is the
- type of the produced value. *)
-
- type ty_rule 'self 'f 'r = 'x;
-
- type ty_production 'a = 'x;
-
- value s_facto : ty_symbol 'self 'a -> ty_symbol 'self 'a;
- (* | Smeta of string and list (g_symbol 'te) and Obj.t *)
- value s_nterm : Entry.e 'a -> ty_symbol 'self 'a;
- value s_nterml : Entry.e 'a -> string -> ty_symbol 'self 'a;
- value s_list0 : ty_symbol 'self 'a -> ty_symbol 'self (list 'a);
- value s_list0sep : ty_symbol 'self 'a -> ty_symbol 'self 'b -> bool -> ty_symbol 'self (list 'a);
- value s_list1 : ty_symbol 'self 'a -> ty_symbol 'self (list 'a);
- value s_list1sep : ty_symbol 'self 'a -> ty_symbol 'self 'b -> bool -> ty_symbol 'self (list 'a);
- value s_opt : ty_symbol 'self 'a -> ty_symbol 'self (option 'a);
- value s_flag : ty_symbol 'self 'a -> ty_symbol 'self bool;
- value s_self : ty_symbol 'self 'self;
- value s_next : ty_symbol 'self 'self;
- value s_token : Plexing.pattern -> ty_symbol 'self string;
- value s_rules : list (ty_production 'a) -> ty_symbol 'self 'a;
- value s_vala : list string -> ty_symbol 'self 'a -> ty_symbol 'self (Ploc.vala 'a);
-
- value r_stop : ty_rule 'self 'r 'r;
- value r_next : ty_rule 'self 'a 'r -> ty_symbol 'self 'b -> ty_rule 'self ('b -> 'a) 'r;
- value r_cut : ty_rule 'self 'a 'r -> ty_rule 'self 'a 'r;
-
- value production : (ty_rule 'a 'f (Ploc.t -> 'a) * 'f) -> ty_production 'a;
-
+ type ('self, 'a) ty_symbol
+ type ('self, 'f, 'r) ty_rule
+ type 'a ty_production
+ val s_facto : ('self, 'a) ty_symbol -> ('self, 'a) ty_symbol
+ val s_nterm : 'a Entry.e -> ('self, 'a) ty_symbol
+ val s_nterml : 'a Entry.e -> string -> ('self, 'a) ty_symbol
+ val s_list0 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol
+ val s_list0sep :
+ ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool ->
+ ('self, 'a list) ty_symbol
+ val s_list1 : ('self, 'a) ty_symbol -> ('self, 'a list) ty_symbol
+ val s_list1sep :
+ ('self, 'a) ty_symbol -> ('self, 'b) ty_symbol -> bool ->
+ ('self, 'a list) ty_symbol
+ val s_opt : ('self, 'a) ty_symbol -> ('self, 'a option) ty_symbol
+ val s_flag : ('self, 'a) ty_symbol -> ('self, bool) ty_symbol
+ val s_self : ('self, 'self) ty_symbol
+ val s_next : ('self, 'self) ty_symbol
+ val s_token : Plexing.pattern -> ('self, string) ty_symbol
+ val s_rules : 'a ty_production list -> ('self, 'a) ty_symbol
+ val s_vala :
+ string list -> ('self, 'a) ty_symbol -> ('self, 'a Ploc.vala) ty_symbol
+ val r_stop : ('self, 'r, 'r) ty_rule
+ val r_next :
+ ('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol ->
+ ('self, 'b -> 'a, 'r) ty_rule
+ val r_cut : ('self, 'a, 'r) ty_rule -> ('self, 'a, 'r) ty_rule
+ val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production
module Unsafe :
sig
- value gram_reinit : Plexing.lexer te -> unit;
- value clear_entry : Entry.e 'a -> unit;
+ val gram_reinit : te Plexing.lexer -> unit
+ val clear_entry : 'a Entry.e -> unit
end
- ;
- value extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol te) * Gramext.g_action)) ->
- unit;
- value safe_extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (ty_production 'a)) ->
- unit;
- value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit;
- value safe_delete_rule : Entry.e 'a -> ty_rule 'a 'f 'r -> unit;
+ val extend :
+ 'a Entry.e -> Gramext.position option ->
+ (string option * Gramext.g_assoc option *
+ (te Gramext.g_symbol list * Gramext.g_action) list)
+ list ->
+ unit
+ val safe_extend :
+ 'a Entry.e -> Gramext.position option ->
+ (string option * Gramext.g_assoc option * 'a ty_production list)
+ list ->
+ unit
+ val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit
+ val safe_delete_rule : 'a Entry.e -> ('a, 'f, 'r) ty_rule -> unit
end
-;
(** Signature type of the functor [Grammar.GMake]. The types and
functions are almost the same than in generic interface, but:
- Grammars are not values. Functions holding a grammar as parameter
@@ -268,11 +260,11 @@ module type S =
type (instead of (string * string)); the module parameter
must specify a way to show them as (string * string) *)
-module GMake (L : GLexerType) : S with type te = L.te;
+module GMake (L : GLexerType) : S with type te = L.te
(** {6 Miscellaneous} *)
-value skip_item : 'a -> 'a;
+val skip_item : 'a -> 'a
(** [Grammar.skip_item x] can be called in a semantic action of
a grammar rule to ask the grammar to skip that item if it
is called in a list (LIST0 or LIST1). The function returns
@@ -280,59 +272,58 @@ value skip_item : 'a -> 'a;
This function is used to allow IFDEF and IFNDEF for cases of
constructor declarations and pattern matchings. *)
-value error_verbose : ref bool;
+val error_verbose : bool ref
(** Flag for displaying more information in case of parsing error;
default = [False] *)
-value warning_verbose : ref bool;
+val warning_verbose : bool ref
(** Flag for displaying warnings while extension; default = [True] *)
-value strict_parsing : ref bool;
+val strict_parsing : bool ref
(** Flag to apply strict parsing, without trying to recover errors;
default = [False] *)
-value utf8_print : ref bool;
+val utf8_print : bool ref
(** Flag to consider strings as utf8-encoded when printing them;
default = [True] *)
-value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit;
+val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit
(** General printer for all kinds of entries (obj entries) *)
-value iter_entry :
- (Gramext.g_entry 'te -> unit) -> Gramext.g_entry 'te -> unit;
+val iter_entry : ('te Gramext.g_entry -> unit) -> 'te Gramext.g_entry -> unit
(** [Grammar.iter_entry f e] applies [f] to the entry [e] and
transitively all entries called by [e]. The order in which
the entries are passed to [f] is the order they appear in
each entry. Each entry is passed only once. *)
-value fold_entry :
- (Gramext.g_entry 'te -> 'a -> 'a) -> Gramext.g_entry 'te -> 'a -> 'a;
+val fold_entry :
+ ('te Gramext.g_entry -> 'a -> 'a) -> 'te Gramext.g_entry -> 'a -> 'a
(** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))],
where [e1 .. eN] are [e] and transitively all entries called by [e].
The order in which the entries are passed to [f] is the order they
appear in each entry. Each entry is passed only once. *)
-value reinit_entry_functions : Gramext.g_entry 'te -> unit;
+val reinit_entry_functions : 'te Gramext.g_entry -> unit
(*** For system use *)
-value loc_of_token_interval : int -> int -> Ploc.t;
-value extend :
- list
- (Gramext.g_entry 'te * option Gramext.position *
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol 'te) * Gramext.g_action))) ->
- unit;
-value delete_rule : Entry.e 'a -> list (Gramext.g_symbol token) -> unit;
-
-value parse_top_symb :
- Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Stream.t 'te -> Obj.t;
-value symb_failed_txt :
- Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Gramext.g_symbol 'te ->
- string;
-value create_local_entry : g -> string -> Entry.e 'a;
+val loc_of_token_interval : int -> int -> Ploc.t
+val extend :
+ ('te Gramext.g_entry * Gramext.position option *
+ (string option * Gramext.g_assoc option *
+ ('te Gramext.g_symbol list * Gramext.g_action) list)
+ list)
+ list ->
+ unit
+val delete_rule : 'a Entry.e -> token Gramext.g_symbol list -> unit
+
+val parse_top_symb :
+ 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Stream.t -> Obj.t
+val symb_failed_txt :
+ 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Gramext.g_symbol ->
+ string
+val create_local_entry : g -> string -> 'a Entry.e
(* deprecated since 2017-06-06 *)
(* rather use "set_default_algorithm Backtracking" *)
-value backtrack_parse : ref bool;
+val backtrack_parse : bool ref
diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml
index 947e1980b5..db8e9591b7 100644
--- a/gramlib/plexing.ml
+++ b/gramlib/plexing.ml
@@ -2,240 +2,218 @@
(* plexing.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)
-open Versdep;
+open Versdep
-type pattern = (string * string);
+type pattern = string * string
-exception Error of string;
+exception Error of string
-type location = Ploc.t;
-type location_function = int -> location;
-type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function);
+type location = Ploc.t
+type location_function = int -> location
+type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function
-type lexer 'te =
- { tok_func : lexer_func 'te;
+type 'te lexer =
+ { tok_func : 'te lexer_func;
tok_using : pattern -> unit;
tok_removing : pattern -> unit;
- tok_match : mutable pattern -> 'te -> string;
+ mutable tok_match : pattern -> 'te -> string;
tok_text : pattern -> string;
- tok_comm : mutable option (list location) }
-;
+ mutable tok_comm : location list option }
-value make_loc = Ploc.make_unlined;
-value dummy_loc = Ploc.dummy;
+let make_loc = Ploc.make_unlined
+let dummy_loc = Ploc.dummy
-value lexer_text (con, prm) =
+let lexer_text (con, prm) =
if con = "" then "'" ^ prm ^ "'"
else if prm = "" then con
else con ^ " '" ^ prm ^ "'"
-;
-value locerr () = failwith "Lexer: location function";
-value loct_create () = (ref (array_create 1024 None), ref False);
-value loct_func (loct, ov) i =
+let locerr () = failwith "Lexer: location function"
+let loct_create () = ref (array_create 1024 None), ref false
+let loct_func (loct, ov) i =
match
- if i < 0 || i >= Array.length loct.val then
- if ov.val then Some dummy_loc else None
- else Array.unsafe_get loct.val i
+ if i < 0 || i >= Array.length !loct then
+ if !ov then Some dummy_loc else None
+ else Array.unsafe_get !loct i
with
- [ Some loc -> loc
- | None -> locerr () ]
-;
-value loct_add (loct, ov) i loc =
- if i >= Array.length loct.val then
- let new_tmax = Array.length loct.val * 2 in
- if new_tmax < Sys.max_array_length then do {
+ Some loc -> loc
+ | None -> locerr ()
+let loct_add (loct, ov) i loc =
+ if i >= Array.length !loct then
+ let new_tmax = Array.length !loct * 2 in
+ if new_tmax < Sys.max_array_length then
let new_loct = array_create new_tmax None in
- Array.blit loct.val 0 new_loct 0 (Array.length loct.val);
- loct.val := new_loct;
- loct.val.(i) := Some loc
- }
- else ov.val := True
- else loct.val.(i) := Some loc
-;
-
-value make_stream_and_location next_token_loc =
+ Array.blit !loct 0 new_loct 0 (Array.length !loct);
+ loct := new_loct;
+ !loct.(i) <- Some loc
+ else ov := true
+ else !loct.(i) <- Some loc
+
+let make_stream_and_location next_token_loc =
let loct = loct_create () in
let ts =
Stream.from
- (fun i -> do {
- let (tok, loc) = next_token_loc () in
- loct_add loct i loc;
- Some tok
- })
+ (fun i ->
+ let (tok, loc) = next_token_loc () in loct_add loct i loc; Some tok)
in
- (ts, loct_func loct)
-;
+ ts, loct_func loct
-value lexer_func_of_parser next_token_loc cs =
+let lexer_func_of_parser next_token_loc cs =
let line_nb = ref 1 in
let bolpos = ref 0 in
make_stream_and_location (fun () -> next_token_loc (cs, line_nb, bolpos))
-;
-value lexer_func_of_ocamllex lexfun cs =
+let lexer_func_of_ocamllex lexfun cs =
let lb =
Lexing.from_function
(fun s n ->
- try do { string_set s 0 (Stream.next cs); 1 } with
- [ Stream.Failure -> 0 ])
+ try string_set s 0 (Stream.next cs); 1 with Stream.Failure -> 0)
in
let next_token_loc _ =
let tok = lexfun lb in
let loc = make_loc (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in
- (tok, loc)
+ tok, loc
in
make_stream_and_location next_token_loc
-;
(* Char and string tokens to real chars and string *)
-value buff = ref (string_create 80);
-value store len x = do {
- if len >= string_length buff.val then
- buff.val := string_cat buff.val (string_create (string_length buff.val))
- else ();
- string_set buff.val len x;
+let buff = ref (string_create 80)
+let store len x =
+ if len >= string_length !buff then
+ buff := string_cat !buff (string_create (string_length !buff));
+ string_set !buff len x;
succ len
-};
-value get_buff len = string_sub buff.val 0 len;
+let get_buff len = string_sub !buff 0 len
-value valch x = Char.code x - Char.code '0';
-value valch_a x = Char.code x - Char.code 'a' + 10;
-value valch_A x = Char.code x - Char.code 'A' + 10;
+let valch x = Char.code x - Char.code '0'
+let valch_a x = Char.code x - Char.code 'a' + 10
+let valch_A x = Char.code x - Char.code 'A' + 10
-value rec backslash s i =
+let rec backslash s i =
if i = String.length s then raise Not_found
else
match s.[i] with
- [ 'n' -> ('\n', i + 1)
- | 'r' -> ('\r', i + 1)
- | 't' -> ('\t', i + 1)
- | 'b' -> ('\b', i + 1)
- | '\\' -> ('\\', i + 1)
- | '"' -> ('"', i + 1)
- | ''' -> (''', i + 1)
+ 'n' -> '\n', i + 1
+ | 'r' -> '\r', i + 1
+ | 't' -> '\t', i + 1
+ | 'b' -> '\b', i + 1
+ | '\\' -> '\\', i + 1
+ | '"' -> '"', i + 1
+ | '\'' -> '\'', i + 1
| '0'..'9' as c -> backslash1 (valch c) s (i + 1)
| 'x' -> backslash1h s (i + 1)
- | _ -> raise Not_found ]
+ | _ -> raise Not_found
and backslash1 cod s i =
- if i = String.length s then ('\\', i - 1)
+ if i = String.length s then '\\', i - 1
else
match s.[i] with
- [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1)
- | _ -> ('\\', i - 1) ]
+ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1)
+ | _ -> '\\', i - 1
and backslash2 cod s i =
- if i = String.length s then ('\\', i - 2)
+ if i = String.length s then '\\', i - 2
else
match s.[i] with
- [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1)
- | _ -> ('\\', i - 2) ]
+ '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1
+ | _ -> '\\', i - 2
and backslash1h s i =
- if i = String.length s then ('\\', i - 1)
+ if i = String.length s then '\\', i - 1
else
match s.[i] with
- [ '0'..'9' as c -> backslash2h (valch c) s (i + 1)
+ '0'..'9' as c -> backslash2h (valch c) s (i + 1)
| 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1)
| 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1)
- | _ -> ('\\', i - 1) ]
+ | _ -> '\\', i - 1
and backslash2h cod s i =
- if i = String.length s then ('\\', i - 2)
+ if i = String.length s then '\\', i - 2
else
match s.[i] with
- [ '0'..'9' as c -> (Char.chr (16 * cod + valch c), i + 1)
- | 'a'..'f' as c -> (Char.chr (16 * cod + valch_a c), i + 1)
- | 'A'..'F' as c -> (Char.chr (16 * cod + valch_A c), i + 1)
- | _ -> ('\\', i - 2) ]
-;
+ '0'..'9' as c -> Char.chr (16 * cod + valch c), i + 1
+ | 'a'..'f' as c -> Char.chr (16 * cod + valch_a c), i + 1
+ | 'A'..'F' as c -> Char.chr (16 * cod + valch_A c), i + 1
+ | _ -> '\\', i - 2
-value rec skip_indent s i =
+let rec skip_indent s i =
if i = String.length s then i
else
match s.[i] with
- [ ' ' | '\t' -> skip_indent s (i + 1)
- | _ -> i ]
-;
+ ' ' | '\t' -> skip_indent s (i + 1)
+ | _ -> i
-value skip_opt_linefeed s i =
+let skip_opt_linefeed s i =
if i = String.length s then i else if s.[i] = '\010' then i + 1 else i
-;
-value eval_char s =
+let eval_char s =
if String.length s = 1 then s.[0]
else if String.length s = 0 then failwith "invalid char token"
else if s.[0] = '\\' then
- if String.length s = 2 && s.[1] = ''' then '''
+ if String.length s = 2 && s.[1] = '\'' then '\''
else
try
let (c, i) = backslash s 1 in
if i = String.length s then c else raise Not_found
- with
- [ Not_found -> failwith "invalid char token" ]
+ with Not_found -> failwith "invalid char token"
else failwith "invalid char token"
-;
-value eval_string loc s =
- bytes_to_string (loop 0 0) where rec loop len i =
+let eval_string loc s =
+ let rec loop len i =
if i = String.length s then get_buff len
else
let (len, i) =
if s.[i] = '\\' then
let i = i + 1 in
if i = String.length s then failwith "invalid string token"
- else if s.[i] = '"' then (store len '"', i + 1)
+ else if s.[i] = '"' then store len '"', i + 1
else
match s.[i] with
- [ '\010' -> (len, skip_indent s (i + 1))
- | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1)))
+ '\010' -> len, skip_indent s (i + 1)
+ | '\013' -> len, skip_indent s (skip_opt_linefeed s (i + 1))
| c ->
- try
- let (c, i) = backslash s i in
- (store len c, i)
- with
- [ Not_found -> (store (store len '\\') c, i + 1) ] ]
- else (store len s.[i], i + 1)
+ try let (c, i) = backslash s i in store len c, i with
+ Not_found -> store (store len '\\') c, i + 1
+ else store len s.[i], i + 1
in
loop len i
-;
-
-value default_match =
- fun
- [ ("ANY", "") -> fun (con, prm) -> prm
- | ("ANY", v) ->
- fun (con, prm) -> if v = prm then v else raise Stream.Failure
- | (p_con, "") ->
- fun (con, prm) -> if con = p_con then prm else raise Stream.Failure
- | (p_con, p_prm) ->
+ in
+ bytes_to_string (loop 0 0)
+
+let default_match =
+ function
+ "ANY", "" -> (fun (con, prm) -> prm)
+ | "ANY", v ->
+ (fun (con, prm) -> if v = prm then v else raise Stream.Failure)
+ | p_con, "" ->
+ (fun (con, prm) -> if con = p_con then prm else raise Stream.Failure)
+ | p_con, p_prm ->
fun (con, prm) ->
- if con = p_con && prm = p_prm then prm else raise Stream.Failure ]
-;
+ if con = p_con && prm = p_prm then prm else raise Stream.Failure
-value input_file = ref "";
-value line_nb = ref (ref 0);
-value bol_pos = ref (ref 0);
-value restore_lexing_info = ref None;
+let input_file = ref ""
+let line_nb = ref (ref 0)
+let bol_pos = ref (ref 0)
+let restore_lexing_info = ref None
(* The lexing buffer used by pa_lexer.cmo *)
-value rev_implode l =
+let rev_implode l =
let s = string_create (List.length l) in
- bytes_to_string (loop (string_length s - 1) l) where rec loop i =
- fun
- [ [c :: l] -> do { string_unsafe_set s i c; loop (i - 1) l }
- | [] -> s ]
-;
+ let rec loop i =
+ function
+ c :: l -> string_unsafe_set s i c; loop (i - 1) l
+ | [] -> s
+ in
+ bytes_to_string (loop (string_length s - 1) l)
module Lexbuf :
sig
- type t = 'abstract;
- value empty : t;
- value add : char -> t -> t;
- value get : t -> string;
+ type t
+ val empty : t
+ val add : char -> t -> t
+ val get : t -> string
end =
struct
- type t = list char;
- value empty = [];
- value add c l = [c :: l];
- value get = rev_implode;
+ type t = char list
+ let empty = []
+ let add c l = c :: l
+ let get = rev_implode
end
-;
diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli
index f0a03da583..6b5f718bc3 100644
--- a/gramlib/plexing.mli
+++ b/gramlib/plexing.mli
@@ -8,7 +8,7 @@
grammars (see module [Grammar]). It also provides some useful functions
to create lexers. *)
-type pattern = (string * string);
+type pattern = string * string
(* Type for values used by the generated code of the EXTEND
statement to represent terminals in entry rules.
- The first string is the constructor name (must start with
@@ -19,61 +19,27 @@ type pattern = (string * string);
- The way tokens patterns are interpreted to parse tokens is done
by the lexer, function [tok_match] below. *)
-exception Error of string;
+exception Error of string
(** A lexing error exception to be used by lexers. *)
(** Lexer type *)
-type lexer 'te =
- { tok_func : lexer_func 'te;
+type 'te lexer =
+ { tok_func : 'te lexer_func;
tok_using : pattern -> unit;
tok_removing : pattern -> unit;
- tok_match : mutable pattern -> 'te -> string;
+ mutable tok_match : pattern -> 'te -> string;
tok_text : pattern -> string;
- tok_comm : mutable option (list Ploc.t) }
- (** The type for lexers compatible with camlp5 grammars. The parameter
- type ['te] is the type of the tokens.
-- The field [tok_func] is the main lexer function. See [lexer_func]
- type below.
-- The field [tok_using] is a function called by the [EXTEND]
- statement to warn the lexer that a rule uses this pattern
- (given as parameter). This allow the lexer 1/ to check that
- the pattern constructor is really among its possible constructors
- 2/ to enter the keywords in its tables.
-- The field [tok_removing] is a function possibly called by the
- [DELETE_RULE] statement to warn the lexer that this pattern
- (given as parameter) is no more used in the grammar (the grammar
- system maintains a number of usages of all patterns and calls this
- function when this number falls to zero). If it is a keyword, this
- allow the lexer to remove it in its tables.
-- The field [tok_match] is a function called by the camlp5
- grammar system to ask the lexer how the input tokens have to
- be matched against the patterns. Warning: for efficiency, this
- function has to be written as a function taking patterns as
- parameters and, for each pattern value, returning a function
- matching a token, *not* as a function with two parameters.
-- The field [tok_text] is a function called by the grammar
- system to get the name of the tokens for the error messages,
- in case of syntax error, or for the displaying of the rules
- of an entry.
-- The field [tok_comm] is a mutable place where the lexer can
- put the locations of the comments, if its initial value is not
- [None]. If it is [None], nothing has to be done by the lexer. *)
-
-and lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function)
- (** The type of a lexer function (field [tok_func] of the type
- [glexer]). The character stream is the input stream to be
- lexed. The result is a pair of a token stream and a location
- function (see below) for this tokens stream. *)
-
-and location_function = int -> Ploc.t;
+ mutable tok_comm : Ploc.t list option }
+and 'te lexer_func = char Stream.t -> 'te Stream.t * location_function
+and location_function = int -> Ploc.t
(** The type of a function giving the location of a token in the
source from the token number in the stream (starting from zero). *)
-value lexer_text : pattern -> string;
+val lexer_text : pattern -> string
(** A simple [tok_text] function. *)
-value default_match : pattern -> (string * string) -> string;
+val default_match : pattern -> string * string -> string
(** A simple [tok_match] function, appling to the token type
[(string * string)] *)
@@ -95,35 +61,35 @@ value default_match : pattern -> (string * string) -> string;
[tok_removing], [tok_match] and [tok_text] may have other implementations
as well. *)
-value lexer_func_of_parser :
- ((Stream.t char * ref int * ref int) -> ('te * Ploc.t)) -> lexer_func 'te;
+val lexer_func_of_parser :
+ (char Stream.t * int ref * int ref -> 'te * Ploc.t) -> 'te lexer_func
(** A lexer function from a lexer written as a char stream parser
returning the next token and its location. The two references
with the char stream contain the current line number and the
position of the beginning of the current line. *)
-value lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> lexer_func 'te;
+val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func
(** A lexer function from a lexer created by [ocamllex] *)
(** Function to build a stream and a location function *)
-value make_stream_and_location :
- (unit -> ('te * Ploc.t)) -> (Stream.t 'te * location_function);
+val make_stream_and_location :
+ (unit -> 'te * Ploc.t) -> 'te Stream.t * location_function
(** General function *)
(** Useful functions and values *)
-value eval_char : string -> char;
-value eval_string : Ploc.t -> string -> string;
+val eval_char : string -> char
+val eval_string : Ploc.t -> string -> string
(** Convert a char or a string token, where the backslashes had not
been interpreted into a real char or string; raise [Failure] if
bad backslash sequence found; [Plexing.eval_char (Char.escaped c)]
would return [c] and [Plexing.eval_string (String.escaped s)] would
return [s] *)
-value restore_lexing_info : ref (option (int * int));
-value input_file : ref string;
-value line_nb : ref (ref int);
-value bol_pos : ref (ref int);
+val restore_lexing_info : (int * int) option ref
+val input_file : string ref
+val line_nb : int ref ref
+val bol_pos : int ref ref
(** Special variables used to reinitialize line numbers and position
of beginning of line with their correct current values when a parser
is called several times with the same character stream. Necessary
@@ -135,9 +101,8 @@ value bol_pos : ref (ref int);
module Lexbuf :
sig
- type t = 'a;
- value empty : t;
- value add : char -> t -> t;
- value get : t -> string;
+ type t
+ val empty : t
+ val add : char -> t -> t
+ val get : t -> string
end
-;
diff --git a/gramlib/ploc.ml b/gramlib/ploc.ml
index 30ae4eaa21..43bfa0dd1f 100644
--- a/gramlib/ploc.ml
+++ b/gramlib/ploc.ml
@@ -2,7 +2,7 @@
(* ploc.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)
-#load "pa_macro.cmo";
+(* #load "pa_macro.cmo" *)
type t =
{ fname : string;
@@ -14,204 +14,178 @@ type t =
ep : int;
comm : string;
ecomm : string }
-;
-value make_loc fname line_nb bol_pos (bp, ep) comm =
+let make_loc fname line_nb bol_pos (bp, ep) comm =
{fname = fname; line_nb = line_nb; bol_pos = bol_pos;
- line_nb_last = line_nb; bol_pos_last = bol_pos;
- bp = bp; ep = ep; comm = comm; ecomm = ""}
-;
+ line_nb_last = line_nb; bol_pos_last = bol_pos; bp = bp; ep = ep;
+ comm = comm; ecomm = ""}
-value make_unlined (bp, ep) =
+let make_unlined (bp, ep) =
{fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
bp = bp; ep = ep; comm = ""; ecomm = ""}
-;
-value dummy =
+let dummy =
{fname = ""; line_nb = 1; bol_pos = 0; line_nb_last = -1; bol_pos_last = 0;
bp = 0; ep = 0; comm = ""; ecomm = ""}
-;
-
-value file_name loc = loc.fname;
-value first_pos loc = loc.bp;
-value last_pos loc = loc.ep;
-value line_nb loc = loc.line_nb;
-value bol_pos loc = loc.bol_pos;
-value line_nb_last loc = loc.line_nb_last;
-value bol_pos_last loc = loc.bol_pos_last;
-value comment loc = loc.comm;
-value comment_last loc = loc.ecomm;
-
-IFDEF OCAML_VERSION <= OCAML_1_07 OR COMPATIBLE_WITH_OLD_OCAML THEN
- value with_bp_ep l bp ep =
- {fname = l.fname; line_nb = l.line_nb; bol_pos = l.bol_pos;
- line_nb_last = l.line_nb_last; bol_pos_last = l.bol_pos_last; bp = bp;
- ep = ep; comm = l.comm; ecomm = l.ecomm}
- ;
- value with_comm l comm =
- {fname = l.fname; line_nb = l.line_nb; bol_pos = l.bol_pos;
- line_nb_last = l.line_nb_last; bol_pos_last = l.bol_pos_last; bp = l.bp;
- ep = l.ep; comm = comm; ecomm = l.ecomm}
- ;
-END;
-
-value encl loc1 loc2 =
+
+let file_name loc = loc.fname
+let first_pos loc = loc.bp
+let last_pos loc = loc.ep
+let line_nb loc = loc.line_nb
+let bol_pos loc = loc.bol_pos
+let line_nb_last loc = loc.line_nb_last
+let bol_pos_last loc = loc.bol_pos_last
+let comment loc = loc.comm
+let comment_last loc = loc.ecomm
+
+(* *)
+
+let encl loc1 loc2 =
if loc1.bp < loc2.bp then
if loc1.ep < loc2.ep then
{fname = loc1.fname; line_nb = loc1.line_nb; bol_pos = loc1.bol_pos;
line_nb_last = loc2.line_nb_last; bol_pos_last = loc2.bol_pos_last;
bp = loc1.bp; ep = loc2.ep; comm = loc1.comm; ecomm = loc2.comm}
- else
- loc1
- else
- if loc2.ep < loc1.ep then
- {fname = loc2.fname; line_nb = loc2.line_nb; bol_pos = loc2.bol_pos;
- line_nb_last = loc1.line_nb_last; bol_pos_last = loc1.bol_pos_last;
- bp = loc2.bp; ep = loc1.ep; comm = loc2.comm; ecomm = loc1.comm}
- else
- loc2
-;
-value shift sh loc = {(loc) with bp = sh + loc.bp; ep = sh + loc.ep};
-value sub loc sh len = {(loc) with bp = loc.bp + sh; ep = loc.bp + sh + len};
-value after loc sh len =
- {(loc) with bp = loc.ep + sh; ep = loc.ep + sh + len}
-;
-value with_comment loc comm = {(loc) with comm = comm};
-
-value name = ref "loc";
-
-value from_file fname loc =
- let (bp, ep) = (first_pos loc, last_pos loc) in
+ else loc1
+ else if loc2.ep < loc1.ep then
+ {fname = loc2.fname; line_nb = loc2.line_nb; bol_pos = loc2.bol_pos;
+ line_nb_last = loc1.line_nb_last; bol_pos_last = loc1.bol_pos_last;
+ bp = loc2.bp; ep = loc1.ep; comm = loc2.comm; ecomm = loc1.comm}
+ else loc2
+let shift sh loc = {loc with bp = sh + loc.bp; ep = sh + loc.ep}
+let sub loc sh len = {loc with bp = loc.bp + sh; ep = loc.bp + sh + len}
+let after loc sh len = {loc with bp = loc.ep + sh; ep = loc.ep + sh + len}
+let with_comment loc comm = {loc with comm = comm}
+
+let name = ref "loc"
+
+let from_file fname loc =
+ let (bp, ep) = first_pos loc, last_pos loc in
try
let ic = open_in_bin fname in
let strm = Stream.of_channel ic in
let rec loop fname lin =
- let rec not_a_line_dir col =
- parser cnt
- [ [: `c; s :] ->
+ let rec not_a_line_dir col (strm__ : _ Stream.t) =
+ let cnt = Stream.count strm__ in
+ match Stream.peek strm__ with
+ Some c ->
+ Stream.junk strm__;
+ let s = strm__ in
if cnt < bp then
if c = '\n' then loop fname (lin + 1)
else not_a_line_dir (col + 1) s
- else
- let col = col - (cnt - bp) in
- (fname, lin, col, col + ep - bp)
- | [: :] ->
- (fname, lin, col, col + 1) ]
+ else let col = col - (cnt - bp) in fname, lin, col, col + ep - bp
+ | _ -> fname, lin, col, col + 1
in
- let rec a_line_dir str n col =
- parser
- [ [: `'\n' :] -> loop str n
- | [: `_; s :] -> a_line_dir str n (col + 1) s ]
+ let rec a_line_dir str n col (strm__ : _ Stream.t) =
+ match Stream.peek strm__ with
+ Some '\n' -> Stream.junk strm__; loop str n
+ | Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__
+ | _ -> raise Stream.Failure
in
- let rec spaces col =
- parser
- [ [: `' '; s :] -> spaces (col + 1) s
- | [: :] -> col ]
+ let rec spaces col (strm__ : _ Stream.t) =
+ match Stream.peek strm__ with
+ Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__
+ | _ -> col
in
- let rec check_string str n col =
- parser
- [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s
- | [: `c when c <> '\n'; s :] ->
- check_string (str ^ String.make 1 c) n (col + 1) s
- | [: a = not_a_line_dir col :] -> a ]
+ let rec check_string str n col (strm__ : _ Stream.t) =
+ match Stream.peek strm__ with
+ Some '"' ->
+ Stream.junk strm__;
+ let col =
+ try spaces (col + 1) strm__ with
+ Stream.Failure -> raise (Stream.Error "")
+ in
+ a_line_dir str n col strm__
+ | Some c when c <> '\n' ->
+ Stream.junk strm__;
+ check_string (str ^ String.make 1 c) n (col + 1) strm__
+ | _ -> not_a_line_dir col strm__
in
- let check_quote n col =
- parser
- [ [: `'"'; s :] -> check_string "" n (col + 1) s
- | [: a = not_a_line_dir col :] -> a ]
+ let check_quote n col (strm__ : _ Stream.t) =
+ match Stream.peek strm__ with
+ Some '"' -> Stream.junk strm__; check_string "" n (col + 1) strm__
+ | _ -> not_a_line_dir col strm__
in
- let rec check_num n col =
- parser
- [ [: `('0'..'9' as c); s :] ->
- check_num (10 * n + Char.code c - Char.code '0') (col + 1) s
- | [: col = spaces col; s :] -> check_quote n col s ]
+ let rec check_num n col (strm__ : _ Stream.t) =
+ match Stream.peek strm__ with
+ Some ('0'..'9' as c) ->
+ Stream.junk strm__;
+ check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__
+ | _ -> let col = spaces col strm__ in check_quote n col strm__
in
- let begin_line =
- parser
- [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s
- | [: a = not_a_line_dir 0 :] -> a ]
+ let begin_line (strm__ : _ Stream.t) =
+ match Stream.peek strm__ with
+ Some '#' ->
+ Stream.junk strm__;
+ let col =
+ try spaces 1 strm__ with
+ Stream.Failure -> raise (Stream.Error "")
+ in
+ check_num 0 col strm__
+ | _ -> not_a_line_dir 0 strm__
in
begin_line strm
in
let r =
try loop fname 1 with
- [ Stream.Failure ->
- let bol = bol_pos loc in
- (fname, line_nb loc, bp - bol, ep - bol) ]
+ Stream.Failure ->
+ let bol = bol_pos loc in fname, line_nb loc, bp - bol, ep - bol
in
- do { close_in ic; r }
- with
- [ Sys_error _ -> (fname, 1, bp, ep) ]
-;
+ close_in ic; r
+ with Sys_error _ -> fname, 1, bp, ep
-value second_line fname ep0 (line, bp) ep = do {
+let second_line fname ep0 (line, bp) ep =
let ic = open_in fname in
seek_in ic bp;
- loop line bp bp where rec loop line bol p =
- if p = ep then do {
- close_in ic;
- if bol = bp then (line, ep0)
- else (line, ep - bol)
- }
- else do {
+ let rec loop line bol p =
+ if p = ep then
+ begin close_in ic; if bol = bp then line, ep0 else line, ep - bol end
+ else
let (line, bol) =
match input_char ic with
- [ '\n' -> (line + 1, p + 1)
- | _ -> (line, bol) ]
+ '\n' -> line + 1, p + 1
+ | _ -> line, bol
in
loop line bol (p + 1)
- }
-};
-
-value get loc = do {
- if loc.fname = "" || loc.fname = "-" then do {
- (loc.line_nb, loc.bp - loc.bol_pos, loc.line_nb, loc.ep - loc.bol_pos,
- loc.ep - loc.bp)
- }
- else do {
+ in
+ loop line bp bp
+
+let get loc =
+ if loc.fname = "" || loc.fname = "-" then
+ loc.line_nb, loc.bp - loc.bol_pos, loc.line_nb, loc.ep - loc.bol_pos,
+ loc.ep - loc.bp
+ else
let (bl, bc, ec) =
- (loc.line_nb, loc.bp - loc.bol_pos, loc.ep - loc.bol_pos)
+ loc.line_nb, loc.bp - loc.bol_pos, loc.ep - loc.bol_pos
in
let (el, eep) = second_line loc.fname ec (bl, loc.bp) loc.ep in
- (bl, bc, el, eep, ec - bc)
- }
-};
-
-value call_with r v f a =
- let saved = r.val in
- try do {
- r.val := v;
- let b = f a in
- r.val := saved;
- b
- }
- with e -> do { r.val := saved; raise e }
-;
-
-exception Exc of t and exn;
-
-value raise loc exc =
+ bl, bc, el, eep, ec - bc
+
+let call_with r v f a =
+ let saved = !r in
+ try r := v; let b = f a in r := saved; b with e -> r := saved; raise e
+
+exception Exc of t * exn
+
+let raise loc exc =
match exc with
- [ Exc _ _ -> raise exc
- | _ -> raise (Exc loc exc) ]
-;
-
-type vala 'a =
- [ VaAnt of string
- | VaVal of 'a ]
-;
-
-value warned = ref True;
-value warning_deprecated_since_6_00 name =
- if not warned.val then do {
- Printf.eprintf "<W> %s deprecated since version 6.00" name;
- warned.val := True
- }
- else ()
-;
-
-value make line_nb bol_pos (bp, ep) =
+ Exc (_, _) -> raise exc
+ | _ -> raise (Exc (loc, exc))
+
+type 'a vala =
+ VaAnt of string
+ | VaVal of 'a
+
+let warned = ref true
+let warning_deprecated_since_6_00 name =
+ if not !warned then
+ begin
+ Printf.eprintf "<W> %s deprecated since version 6.00" name;
+ warned := true
+ end
+
+let make line_nb bol_pos (bp, ep) =
let _ = warning_deprecated_since_6_00 "Ploc.make" in
{fname = ""; line_nb = line_nb; bol_pos = bol_pos; line_nb_last = line_nb;
bol_pos_last = bol_pos; bp = bp; ep = ep; comm = ""; ecomm = ""}
-;
diff --git a/gramlib/ploc.mli b/gramlib/ploc.mli
index 1d6df4d322..aec6b4e8b8 100644
--- a/gramlib/ploc.mli
+++ b/gramlib/ploc.mli
@@ -4,102 +4,102 @@
(** Locations and some pervasive type and value. *)
-type t = 'abstract;
+type t
(* located exceptions *)
-exception Exc of t and exn;
+exception Exc of t * exn
(** [Ploc.Exc loc e] is an encapsulation of the exception [e] with
the input location [loc]. To be used to specify a location
for an error. This exception must not be raised by [raise] but
rather by [Ploc.raise] (see below), to prevent the risk of several
encapsulations of [Ploc.Exc]. *)
-value raise : t -> exn -> 'a;
+val raise : t -> exn -> 'a
(** [Ploc.raise loc e], if [e] is already the exception [Ploc.Exc],
re-raise it (ignoring the new location [loc]), else raise the
exception [Ploc.Exc loc e]. *)
(* making locations *)
-value make_loc : string -> int -> int -> (int * int) -> string -> t;
+val make_loc : string -> int -> int -> int * int -> string -> t
(** [Ploc.make_loc fname line_nb bol_pos (bp, ep) comm] creates a location
starting at line number [line_nb], where the position of the beginning
of the line is [bol_pos] and between the positions [bp] (included) and
[ep] excluded. And [comm] is the comment before the location. The
positions are in number of characters since the begin of the stream. *)
-value make_unlined : (int * int) -> t;
+val make_unlined : int * int -> t
(** [Ploc.make_unlined] is like [Ploc.make] except that the line number
is not provided (to be used e.g. when the line number is unknown. *)
-value dummy : t;
+val dummy : t
(** [Ploc.dummy] is a dummy location, used in situations when location
has no meaning. *)
(* getting location info *)
-value file_name : t -> string;
+val file_name : t -> string
(** [Ploc.file_name loc] returns the file name of the location. *)
-value first_pos : t -> int;
+val first_pos : t -> int
(** [Ploc.first_pos loc] returns the position of the begin of the location
in number of characters since the beginning of the stream. *)
-value last_pos : t -> int;
+val last_pos : t -> int
(** [Ploc.last_pos loc] returns the position of the first character not
in the location in number of characters since the beginning of the
stream. *)
-value line_nb : t -> int;
+val line_nb : t -> int
(** [Ploc.line_nb loc] returns the line number of the location or [-1] if
the location does not contain a line number (i.e. built with
[Ploc.make_unlined]. *)
-value bol_pos : t -> int;
+val bol_pos : t -> int
(** [Ploc.bol_pos loc] returns the position of the beginning of the line
of the location in number of characters since the beginning of
the stream, or [0] if the location does not contain a line number
(i.e. built with [Ploc.make_unlined]. *)
-value line_nb_last : t -> int;
-value bol_pos_last : t -> int;
+val line_nb_last : t -> int
+val bol_pos_last : t -> int
(** Return the line number and the position of the beginning of the line
of the last position. *)
-value comment : t -> string;
+val comment : t -> string
(** [Ploc.comment loc] returns the comment before the location. *)
-value comment_last : t -> string;
+val comment_last : t -> string
(** [Ploc.comment loc] returns the last comment of the location. *)
(* combining locations *)
-value encl : t -> t -> t;
+val encl : t -> t -> t
(** [Ploc.encl loc1 loc2] returns the location starting at the
smallest start of [loc1] and [loc2] and ending at the greatest end
of them. In other words, it is the location enclosing [loc1] and
[loc2]. *)
-value shift : int -> t -> t;
+val shift : int -> t -> t
(** [Ploc.shift sh loc] returns the location [loc] shifted with [sh]
characters. The line number is not recomputed. *)
-value sub : t -> int -> int -> t;
+val sub : t -> int -> int -> t
(** [Ploc.sub loc sh len] is the location [loc] shifted with [sh]
characters and with length [len]. The previous ending position
of the location is lost. *)
-value after : t -> int -> int -> t;
+val after : t -> int -> int -> t
(** [Ploc.after loc sh len] is the location just after loc (starting at
the end position of [loc]) shifted with [sh] characters and of length
[len]. *)
-value with_comment : t -> string -> t;
+val with_comment : t -> string -> t
(** Change the comment part of the given location *)
(* miscellaneous *)
-value name : ref string;
+val name : string ref
(** [Ploc.name.val] is the name of the location variable used in grammars
and in the predefined quotations for OCaml syntax trees. Default:
["loc"] *)
-value get : t -> (int * int * int * int * int);
+val get : t -> int * int * int * int * int
(** [Ploc.get loc] returns in order: 1/ the line number of the begin
of the location, 2/ its column, 3/ the line number of the first
character not in the location, 4/ its column and 5/ the length
of the location. The file where the location occurs (if any) may
be read during this operation. *)
-value from_file : string -> t -> (string * int * int * int);
+val from_file : string -> t -> string * int * int * int
(** [Ploc.from_file fname loc] reads the file [fname] up to the
location [loc] and returns the real input file, the line number
and the characters location in the line; the real input file
@@ -108,15 +108,14 @@ value from_file : string -> t -> (string * int * int * int);
(* pervasives *)
-type vala 'a =
- [ VaAnt of string
- | VaVal of 'a ]
-;
+type 'a vala =
+ VaAnt of string
+ | VaVal of 'a
(** Encloser of many abstract syntax tree nodes types, in "strict" mode.
This allow the system of antiquotations of abstract syntax tree
quotations to work when using the quotation kit [q_ast.cmo]. *)
-value call_with : ref 'a -> 'a -> ('b -> 'c) -> 'b -> 'c;
+val call_with : 'a ref -> 'a -> ('b -> 'c) -> 'b -> 'c
(** [Ploc.call_with r v f a] sets the reference [r] to the value [v],
then call [f a], and resets [r] to its initial value. If [f a] raises
an exception, its initial value is also reset and the exception is
@@ -124,6 +123,6 @@ value call_with : ref 'a -> 'a -> ('b -> 'c) -> 'b -> 'c;
(**/**)
-value make : int -> int -> (int * int) -> t;
+val make : int -> int -> int * int -> t
(** deprecated function since version 6.00; use [make_loc] instead
with the empty string *)
diff --git a/gramlib/token.ml b/gramlib/token.ml
index 9c1664ccd9..77c737b880 100644
--- a/gramlib/token.ml
+++ b/gramlib/token.ml
@@ -2,36 +2,36 @@
(* token.ml,v *)
(* Copyright (c) INRIA 2007-2017 *)
-type pattern = Plexing.pattern;
+type pattern = Plexing.pattern
-exception Error of string;
+exception Error of string
-type location = Ploc.t;
-type location_function = int -> location;
-type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function);
+type location = Ploc.t
+type location_function = int -> location
+type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function
-type glexer 'te = Plexing.lexer 'te ==
- { tok_func : lexer_func 'te;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : mutable pattern -> 'te -> string;
- tok_text : pattern -> string;
- tok_comm : mutable option (list location) }
-;
+type 'te glexer =
+ 'te Plexing.lexer =
+ { tok_func : 'te lexer_func;
+ tok_using : pattern -> unit;
+ tok_removing : pattern -> unit;
+ mutable tok_match : pattern -> 'te -> string;
+ tok_text : pattern -> string;
+ mutable tok_comm : location list option }
-value make_loc = Ploc.make_unlined;
-value dummy_loc = Ploc.dummy;
+let make_loc = Ploc.make_unlined
+let dummy_loc = Ploc.dummy
-value make_stream_and_location = Plexing.make_stream_and_location;
-value lexer_func_of_parser = Plexing.lexer_func_of_parser;
-value lexer_func_of_ocamllex = Plexing.lexer_func_of_ocamllex;
+let make_stream_and_location = Plexing.make_stream_and_location
+let lexer_func_of_parser = Plexing.lexer_func_of_parser
+let lexer_func_of_ocamllex = Plexing.lexer_func_of_ocamllex
-value eval_char = Plexing.eval_char;
-value eval_string = Plexing.eval_string;
+let eval_char = Plexing.eval_char
+let eval_string = Plexing.eval_string
-value lexer_text = Plexing.lexer_text;
-value default_match = Plexing.default_match;
+let lexer_text = Plexing.lexer_text
+let default_match = Plexing.default_match
-value line_nb = Plexing.line_nb;
-value bol_pos = Plexing.bol_pos;
-value restore_lexing_info = Plexing.restore_lexing_info;
+let line_nb = Plexing.line_nb
+let bol_pos = Plexing.bol_pos
+let restore_lexing_info = Plexing.restore_lexing_info
diff --git a/gramlib/token.mli b/gramlib/token.mli
index 333d53ce86..c1de5cefff 100644
--- a/gramlib/token.mli
+++ b/gramlib/token.mli
@@ -5,52 +5,52 @@
(** Module deprecated since Camlp5 version 5.00. Use now module Plexing.
Compatibility assumed. *)
-type pattern = Plexing.pattern;
+type pattern = Plexing.pattern
-exception Error of string;
+exception Error of string
(** Use now [Plexing.Error] *)
-type glexer 'te = Plexing.lexer 'te ==
- { tok_func : Plexing.lexer_func 'te;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : mutable pattern -> 'te -> string;
- tok_text : pattern -> string;
- tok_comm : mutable option (list Ploc.t) }
-;
+type 'te glexer =
+ 'te Plexing.lexer =
+ { tok_func : 'te Plexing.lexer_func;
+ tok_using : pattern -> unit;
+ tok_removing : pattern -> unit;
+ mutable tok_match : pattern -> 'te -> string;
+ tok_text : pattern -> string;
+ mutable tok_comm : Ploc.t list option }
-type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function)
-and location_function = int -> Ploc.t;
+type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function
+and location_function = int -> Ploc.t
-value lexer_text : pattern -> string;
+val lexer_text : pattern -> string
(** Use now [Plexing.lexer_text] *)
-value default_match : pattern -> (string * string) -> string;
+val default_match : pattern -> string * string -> string
(** Use now [Plexing.default_match] *)
-value lexer_func_of_parser :
- ((Stream.t char * ref int * ref int) -> ('te * Ploc.t)) -> lexer_func 'te;
+val lexer_func_of_parser :
+ (char Stream.t * int ref * int ref -> 'te * Ploc.t) -> 'te lexer_func
(** Use now [Plexing.lexer_func_of_parser] *)
-value lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> lexer_func 'te;
+val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func
(** Use now [Plexing.lexer_func_of_ocamllex] *)
-value make_stream_and_location :
- (unit -> ('te * Ploc.t)) -> (Stream.t 'te * location_function);
+val make_stream_and_location :
+ (unit -> 'te * Ploc.t) -> 'te Stream.t * location_function
(** Use now [Plexing.make_stream_and_location] *)
-value eval_char : string -> char;
+val eval_char : string -> char
(** Use now [Plexing.eval_char] *)
-value eval_string : Ploc.t -> string -> string;
+val eval_string : Ploc.t -> string -> string
(** Use now [Plexing.eval_string] *)
-value restore_lexing_info : ref (option (int * int));
+val restore_lexing_info : (int * int) option ref
(** Use now [Plexing.restore_lexing_info] *)
-value line_nb : ref (ref int);
+val line_nb : int ref ref
(** Use now [Plexing.line_nb] *)
-value bol_pos : ref (ref int);
+val bol_pos : int ref ref
(** Use now [Plexing.bol_pos] *)
(* deprecated since version 4.08 *)
-type location = Ploc.t;
-value make_loc : (int * int) -> Ploc.t;
-value dummy_loc : Ploc.t;
+type location = Ploc.t
+val make_loc : int * int -> Ploc.t
+val dummy_loc : Ploc.t