diff options
| author | Emilio Jesus Gallego Arias | 2018-10-07 07:50:16 +0200 |
|---|---|---|
| committer | Emilio Jesus Gallego Arias | 2018-10-29 01:25:34 +0100 |
| commit | 46ac5393bf8d3dfef069c4190e3bfe6a3b4dcd90 (patch) | |
| tree | 4a7e7e27a48b542fb28992002acd807117df043c /gramlib | |
| parent | 641042302f05f6ec42f61a4bdb73fad70bb90c41 (diff) | |
[gramlib] Cleanup, remove unused parsing infrastructure.
We remove the functional and backtracking parsers as they are not used
in Coq.
Diffstat (limited to 'gramlib')
| -rw-r--r-- | gramlib/fstream.ml | 146 | ||||
| -rw-r--r-- | gramlib/fstream.mli | 96 | ||||
| -rw-r--r-- | gramlib/gramext.ml | 12 | ||||
| -rw-r--r-- | gramlib/gramext.mli | 12 | ||||
| -rw-r--r-- | gramlib/grammar.ml | 1672 | ||||
| -rw-r--r-- | gramlib/grammar.mli | 161 | ||||
| -rw-r--r-- | gramlib/ploc.ml | 15 | ||||
| -rw-r--r-- | gramlib/ploc.mli | 6 |
8 files changed, 15 insertions, 2105 deletions
diff --git a/gramlib/fstream.ml b/gramlib/fstream.ml deleted file mode 100644 index 94e25ffd54..0000000000 --- a/gramlib/fstream.ml +++ /dev/null @@ -1,146 +0,0 @@ -(* camlp5r *) -(* fstream.ml,v *) -(* Copyright (c) INRIA 2007-2017 *) - -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 - | Clazy 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 - | Clazy l -> - 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)} - in - loop 0 - -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) -> - match next s1 with - 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 - -let empty s = - match next s with - Some _ -> None - | None -> Some ((), s) - -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} - -let of_list l = List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil - -let of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) - -let of_channel ic = - from (fun _ -> try Some (input_char ic) with End_of_file -> None) - -let iter f = - let rec do_rec strm = - match next strm with - Some (a, strm) -> let _ = f a in do_rec strm - | None -> () - in - do_rec - -let count s = s.count - -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 - else cnt - in - loop 0 s - -(* backtracking parsers *) - -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 - -let bcontinue = - function - K k -> k () - -let bparse_all p strm = - let rec loop p = - match p () with - Some (r, _, K k) -> r :: loop k - | None -> [] - in - loop (fun () -> p 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 - 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 () - in - app_a (fun () -> a strm) () - -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 - in - loop (fun () -> a strm) () - -let b_term f strm = - match next strm with - 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 deleted file mode 100644 index 2fefd4bcfc..0000000000 --- a/gramlib/fstream.mli +++ /dev/null @@ -1,96 +0,0 @@ -(* camlp5r *) -(* fstream.mli,v *) -(* Copyright (c) INRIA 2007-2017 *) - -(* Module [Fstream]: functional streams *) - -(* This module implement functional streams and parsers together with - backtracking parsers. To be used with syntax [pa_fstream.cmo]. The - syntax is: - For functional streams: -- stream: [fstream [: ... :]] - For functional parsers: -- parser: [fparser [ [: ... :] -> ... | ... ]] - For backtracking parsers: -- parser: [bparser [ [: ... :] -> ... | ... ]] - - Functional parsers are of type: - [Fstream.t 'a -> option ('b * Fstream.t 'a)] - Backtracking parsers are of type: - [Fstream.t 'a -> option ('b * Fstream.t 'a * Fstream.kont 'a 'b)] - - Functional parsers have limited backtrack, i.e if a rule fails, the - next rule is tested with the initial stream; limited because when - in case of a rule with two consecutive symbols [a] and [b], if [b] - fails, the rule fails: there is no try with the next rule of [a]. - - Backtracking parsers have full backtrack. If a rule fails, the next - case of the previous rule is tested. -*) - -exception Cut - -(** Functional streams *) - -type 'a t - (* The type of 'a functional streams *) -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. *) - -val of_list : 'a list -> 'a t - (* Return the stream holding the elements of the list in the same - order. *) -val of_string : string -> char t - (* Return the stream of the characters of the string parameter. *) -val of_channel : in_channel -> char t - (* Return the stream of the characters read from the input channel. *) - -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. *) - -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. *) -val empty : 'a t -> (unit * 'a t) option - (* Return [Some ((), s)] if the stream is empty where [s] is itself, - else [None] *) -val count : 'a t -> int - (* Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) -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 ('a, 'b) kont = - K of (unit -> ('b * 'a t * ('a, 'b) kont) option) - (* The type of continuation of a backtracking parser. *) -type ('a, 'b) bp = 'a t -> ('b * 'a t * ('a, 'b) kont) option - (* The type of a backtracking parser. *) - -val bcontinue : ('a, 'b) kont -> ('b * 'a t * ('a, 'b) kont) option - (* [bcontinue k] return the next solution of a backtracking parser. *) - -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. *) - -(*--*) - -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 - -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 39da1de56d..8960d4f257 100644 --- a/gramlib/gramext.ml +++ b/gramlib/gramext.ml @@ -5,16 +5,10 @@ open Printf 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 type 'te grammar = { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Plexing.lexer; - mutable galgo : parse_algorithm } + mutable glexer : 'te Plexing.lexer } type 'te g_entry = { egram : 'te grammar; @@ -22,10 +16,6 @@ type 'te g_entry = elocal : bool; 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 diff --git a/gramlib/gramext.mli b/gramlib/gramext.mli index 0852709bf4..a76b7da9a2 100644 --- a/gramlib/gramext.mli +++ b/gramlib/gramext.mli @@ -3,16 +3,10 @@ (* Copyright (c) INRIA 2007-2017 *) 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 type 'te grammar = { gtokens : (Plexing.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Plexing.lexer; - mutable galgo : parse_algorithm } + mutable glexer : 'te Plexing.lexer } type 'te g_entry = { egram : 'te grammar; @@ -20,10 +14,6 @@ type 'te g_entry = elocal : bool; 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 diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 0f68c95021..04ec1049ed 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -2,15 +2,9 @@ (* grammar.ml,v *) (* Copyright (c) INRIA 2007-2017 *) -(* #load "pa_fstream.cmo" *) - -let pervasives_stderr = stderr - open Gramext open Format -let stderr = pervasives_stderr - let rec flatten_tree = function DeadEnd -> [] @@ -149,81 +143,6 @@ let print_entry ppf e = end; fprintf ppf " ]@]" -let iter_entry f e = - let treated = ref [] in - let rec do_entry e = - 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 = - 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 = - function - Sfacto s -> do_symbol s - | Smeta (_, sl, _) -> List.iter do_symbol sl - | Snterm 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_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 _ -> () - in - do_entry e - -let fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - 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 - and do_tree 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 - and do_symbol accu = - 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 - | 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 - | Stree t -> do_tree accu t - | Svala (_, s) -> do_symbol accu s - | Sself | Snext | Scut | Stoken _ -> accu - in - do_entry init e - let floc = ref (fun _ -> failwith "internal error when computing location") let loc_of_token_interval bp ep = @@ -501,37 +420,12 @@ let peek_nth n strm = loop list n let item_skipped = ref false -let skip_item a = item_skipped := true; a let call_and_push ps al strm = item_skipped := false; let a = ps strm in let al = if !item_skipped then al else a :: al in item_skipped := false; al -let fcall_and_push ps al err strm = - item_skipped := false; - match ps err strm with - 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) -> - let rec kont2 kont () = - item_skipped := false; - match kont () with - 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 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 @@ -873,8 +767,6 @@ and parser_of_token entry tok = | None -> raise Stream.Failure and parse_top_symb entry symb = parser_of_symbol entry 0 (top_symb entry symb) -let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2 - let rec start_parser_of_levels entry clevn = function [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) @@ -960,1146 +852,8 @@ let start_parser_of_entry entry = | Dlevels elev -> start_parser_of_levels entry 0 elev | Dparser p -> fun levn strm -> p strm -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 *) -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 *) - -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 - -let no_err () = "" -let ftree_failed entry prev_symb_result prev_symb tree () = - tree_failed entry prev_symb_result prev_symb tree -let fsymb_failed entry prev_symb_result prev_symb symb () = - symb_failed entry prev_symb_result prev_symb symb - -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 then - begin - Printf.eprintf "%stesting (\"%s\", \"%s\") ..." !tind (fst tok) - (snd tok); - flush stderr - end - in - let _ = - if !backtrack_stalling_limit > 0 || !backtrack_trace_try then - let m = - match !max_fcount with - Some (m, _, _) -> m - | None -> 0 - in - 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) -> - begin try - let r = f tok in - let _ = - if !backtrack_trace then Printf.eprintf " yes \"%s\"\n%!" r - in - 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 then - begin Printf.eprintf " eos\n"; flush stderr end - in - 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 *) - -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 - -let ftop_tree entry son strm = - match son with - 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 then - Printf.eprintf "%srecovering pos %d\n%!" !tind - (Fstream.count strm) - 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 - -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 (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 (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 (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 (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 = - 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 - (List.fold_left - (fun act symb -> - Obj.magic act (fparser_of_symbol entry next_levn symb)) - act symbl) - | Slist0 s -> - let ps = fparser_of_symbol entry next_levn s in - let ps = fcall_and_push ps in - 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 (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 (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 (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 (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 (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) -> - 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 (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 (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 (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 (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 (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 (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 (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" - | Sopt _ -> Some "V OPT" - | Slist0 _ | Slist0sep (_, _, _) -> Some "V LIST" - | Slist1 _ | Slist1sep (_, _, _) -> Some "V LIST" - | Stoken (con, "") -> Some ("V " ^ con) - | _ -> None - in - begin match t with - Some t -> fparser_of_token entry (t, "") - | None -> fun err (strm__ : _ Fstream.t) -> None - end - | al -> - let rec loop = - function - a :: al -> - let pa = fparser_of_token entry ("V", a) in - let pal = loop al in - (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 (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 (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 - | tree -> - let alevn = - match lev.assoc with - 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 -> - 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 - 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 - | tree -> - let alevn = - match lev.assoc with - 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 - 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 (strm__ : _ Fstream.t) -> None) - | Dlevels elev -> fstart_parser_of_levels entry 0 elev - | Dparser p -> fun levn err strm -> failwith "Dparser for Fstream" - -let fcontinue_parser_of_entry entry = - match entry.edesc with - Dlevels elev -> - let p = fcontinue_parser_of_levels entry 0 elev in - (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 *) - -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} -> - begin match btop_symb entry s with - Some sy -> - let r = Node {node = sy; brother = bro; son = son} in - let _ = - if !backtrack_trace then - Printf.eprintf "%srecovering pos %d\n%!" !tind - (Fstream.count strm) - 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 - -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 (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 (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 (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 (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 = - 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 - (List.fold_left - (fun act symb -> - Obj.magic act (bparser_of_symbol entry next_levn symb)) - act symbl) - | Slist0 s -> - let ps = bparser_of_symbol entry next_levn s in - let ps = bcall_and_push ps in - 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 (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 (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 (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 (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 (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) -> - 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 (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 (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 (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 (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 (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 (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 (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" - | Sopt _ -> Some "V OPT" - | Slist0 _ | Slist0sep (_, _, _) -> Some "V LIST" - | Slist1 _ | Slist1sep (_, _, _) -> Some "V LIST" - | Stoken (con, "") -> Some ("V " ^ con) - | _ -> None - in - begin match t with - Some t -> bparser_of_token entry (t, "") - | None -> fun err (strm__ : _ Fstream.t) -> None - end - | al -> - let rec loop = - function - a :: al -> - let pa = bparser_of_token entry ("V", a) in - let pal = loop al in - (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 (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 (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 (strm__ : _ Fstream.t) -> None - -let bcount strm = - let (strm__ : _ Fstream.t) = strm in - Fstream.b_act (Fstream.count strm) strm__ - -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 - | tree -> - let alevn = - match lev.assoc with - 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 -> - 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 - 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 - | tree -> - let alevn = - match lev.assoc with - 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 - 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 (strm__ : _ Fstream.t) -> None) - | Dlevels elev -> bstart_parser_of_levels entry 0 elev - | Dparser p -> fun levn err strm -> failwith "Dparser for Fstream" - -let bcontinue_parser_of_entry entry = - match entry.edesc with - Dlevels elev -> - let p = bcontinue_parser_of_levels entry 0 elev in - (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 *) -let trace_entry_lev_name entry lev = - match entry.edesc with - Dlevels ll -> - if lev < List.length ll then - let glev = List.nth ll lev in - begin match glev.lname with - Some "" | None -> () - | Some s -> Printf.eprintf " (\"%s\")" s - end - | Dparser _ -> () - -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 := !tind ^ " "; - try - let r = f lev err strm in - 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 -> - tind := t; - Printf.eprintf "%sexception \"%s\"\n" !tind (Printexc.to_string e); - flush stderr; - raise e - else f - -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 := !tind ^ " "; - try - let r = f lev bp a err strm in - 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 -> - tind := t; - Printf.eprintf "%sexception \"%s\"" !tind (Printexc.to_string e); - trace_entry_lev_name entry lev; - Printf.eprintf "\n%!"; - raise e - else f - let init_entry_functions entry = entry.estart <- (fun lev strm -> @@ -2107,30 +861,7 @@ let init_entry_functions entry = 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 - -let reinit_entry_functions entry = - match entry.edesc with - Dlevels elev -> init_entry_functions entry - | _ -> () + entry.econtinue <- f; f lev bp a strm) let extend_entry entry position rules = try @@ -2141,23 +872,6 @@ let extend_entry entry position rules = flush stderr; failwith "Grammar.extend" -let extend entry_rules_list = - let gram = ref None in - List.iter - (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 *) let delete_rule entry sl = @@ -2172,33 +886,9 @@ let delete_rule entry sl = 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) + entry.econtinue <- f; f lev bp a 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 @@ -2207,44 +897,10 @@ type g = token Gramext.grammar 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 = - 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} - -let set_algorithm g algo = g.galgo <- algo + {gtokens = create_toktab (); glexer = glexer } let tokens g con = let list = ref [] in @@ -2258,22 +914,13 @@ let glexer g = g.glexer 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 = token gen_parsable -let fstream_of_stream ts = - Fstream.from - (fun _ -> - match Stream.peek ts with - None -> None - | x -> Stream.junk ts; x) - 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} + {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} let parse_parsable entry p = let efun = entry.estart 0 in @@ -2306,155 +953,6 @@ let parse_parsable entry p = let loc = Stream.count cs, Stream.count cs + 1 in restore (); Ploc.raise (Ploc.make_unlined loc) exc -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 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 - 1 <= cnt then loc - else Ploc.encl loc (p.pa_loc_func (!token_count - 1)) - with - Failure _ -> default_loc () - | e -> restore (); raise e - in - 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 -> - let cnt = Fstream.count fts + Fstream.count_unfrozen fts - 1 in - let loc = get_loc cnt in - let mess = - 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 then - mess ^ Printf.sprintf " (max token count %d)" cnt - else mess - | None -> sprintf "[%s] failed" entry.ename - in - let mess = - 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 -> restore (); Ploc.raise (default_loc ()) exc - in - restore (); r - -let bfparse_token_stream entry efun ts = - let restore2 () = () in - if !backtrack_trace then - Printf.eprintf "%sbfparse_token_stream [%s]\n%!" !tind entry.ename; - let p = - {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 - -let bfparse_parsable entry p efun = - let restore2 = - let old_floc = !floc in - let old_max_fcount = !max_fcount in - fun () -> floc := old_floc; max_fcount := old_max_fcount - in - 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 - -let fparse_token_stream entry ts = - let efun err fts = - match entry.fstart 0 err fts with - Some (a, _) -> Obj.magic a - | None -> raise Stream.Failure - in - bfparse_token_stream entry efun ts - -let fparse_parsable entry p = - let efun err fts = - match entry.fstart 0 err fts with - Some (r, strm) -> p.pa_tok_fstrm <- strm; r - | None -> raise Stream.Failure - in - bfparse_parsable entry p efun - -let bparse_token_stream entry ts = - let efun err fts = - match entry.bstart 0 err fts with - Some (a, _, _) -> Obj.magic a - | None -> raise Stream.Failure - in - bfparse_token_stream entry efun ts - -let bparse_parsable entry p = - let efun err fts = - match entry.bstart 0 err fts with - Some (r, strm, _) -> p.pa_tok_fstrm <- strm; r - | None -> raise Stream.Failure - in - bfparse_parsable entry p efun - -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 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 := fun_loc; - token_count := 0; - max_fcount := None; - if !backtrack_trace then - Printf.eprintf "%sbparse_parsable_all [%s]: max token count reset\n%!" - !tind entry.ename - else nb_ftry := 0; - if !backtrack_trace_try then begin Printf.eprintf "\n"; flush stderr end; - try - let rl = - let rec loop rev_rl = - function - Some (r, strm, k) -> - let _ = - 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 - in - loop [] (efun no_err fts) - in - 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 = function @@ -2510,54 +1008,6 @@ let find_entry e s = | 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 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 with - Some (v, fstrm) -> fts := fstrm; Some v - | None -> None) - in - let r = - try - let r : Obj.t = Obj.magic p ts in - let fstrm = - 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" - in - loop fstrm (Stream.count ts) - in - return_value r fstrm - with e -> - restore (); - match e with - Stream.Failure -> None - | _ -> raise e - in - restore (); r - -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 - -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 @@ -2565,65 +1015,20 @@ module 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 -> - 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) - 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) + Obj.magic (parse_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 -> - 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 : Obj.t list) - | Functional -> - failwith "Entry.parse_parsable_all: func parsing not impl" - end - | Predictive -> - 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 : Obj.t list) + begin try Obj.magic [(parse_parsable entry p : Obj.t)] with + Stream.Failure | Stream.Error _ -> [] + end let parse_all (entry : 'a e) cs : 'a = let parsable = parsable entry.egram cs in parse_parsable_all entry parsable let parse_token_stream (entry : 'a e) ts : 'a = - let _ = compatible_deprecated_backtrack_parse () in - match entry.egram.galgo with - 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" - | Functional -> - 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" + Obj.magic (entry.estart 0 ts : Obj.t) let _warned_using_parse_token = ref false let parse_token (entry : 'a e) ts : 'a = (* commented: too often warned in Coq... @@ -2641,36 +1046,17 @@ module Entry = {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 -let of_entry e = e.egram - -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 *) 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 _ -> () @@ -2694,7 +1080,6 @@ module type S = 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 'a e @@ -2762,12 +1147,9 @@ module GMake (L : GLexerType) = 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} + {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} let tokens = tokens gram let glexer = glexer gram - let set_algorithm algo = gram.galgo <- algo module Entry = struct type 'a e = te g_entry @@ -2775,38 +1157,12 @@ module GMake (L : GLexerType) = {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 -> - 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) - 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) + Obj.magic (parse_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 -> - 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 - end - | Predictive -> Obj.magic (e.estart 0 ts : Obj.t) - | Functional -> fparse_token_stream e ts - | Backtracking -> bparse_token_stream e ts + Obj.magic (e.estart 0 ts : Obj.t) let _warned_using_parse_token = ref false let parse_token (entry : 'a e) ts : 'a = (* commented: too often warned in Coq... @@ -2825,10 +1181,6 @@ module GMake (L : GLexerType) = 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 diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index fcc98531b6..54b7eb5539 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -12,21 +12,6 @@ type g (** The type for grammars, holding entries. *) type token = string * string -val gcreate : token Plexing.lexer -> g - (** Create a new grammar, without keywords, using the lexer given - as parameter. *) -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. - - Examples: -- 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. *) -val glexer : g -> token Plexing.lexer - (** Return the lexer used by the grammar *) - type parsable val parsable : g -> char Stream.t -> parsable (** Type and value allowing to keep the same token stream between @@ -68,9 +53,6 @@ module Entry : - [Entry.parse_token]: deprecated since 2017-06-16; old name for [Entry.parse_token_stream] *) -val of_entry : 'a Entry.e -> g - (** Return the grammar associated with an entry. *) - 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 @@ -80,45 +62,6 @@ type ('self, 'f, 'r) ty_rule type 'a ty_production -type ty_extension - -val s_facto : ('self, 'a) ty_symbol -> ('self, 'a) ty_symbol -(* | Smeta of string and list (g_symbol 'te) and Obj.t *) -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 : @@ -136,42 +79,6 @@ module Unsafe : - itself is not reinitialized. - [Unsafe.clear_entry e] removes all rules of the entry [e]. *) -(** {6 Parsing algorithm} *) - -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 - [Backtracking]: use functional streams with full backtracking - [DefaultAlgorithm]: use the general default algorithm set by the - function [set_default_algorithm] below or through the environment - variablefound in the variable CAMLP5PARAM. - The default, when a grammar is created, is [DefaultAlgorithm]. *) - -val set_algorithm : g -> parse_algorithm -> unit - (** Set the parsing algorithm for all entries of a given grammar. *) - -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]. *) -val default_algorithm : unit -> parse_algorithm - (** Return the current default algorithm. *) - -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 - grammars, it can be very long before checking all possibilities. - This number limits the number of tokens tests after a backtrack. - (The number of tokens tests is reset to zero when the token - stream overtakes the last reached token.) The default is 10000. - If set to 0, there is no limit. Can be set by the environment - variable CAMLP5PARAM by "l=value". *) - (** {6 Functorial interface} *) (** Alternative for grammars use. Grammars are no more Ocaml values: @@ -190,7 +97,6 @@ module type S = 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 'a e @@ -231,6 +137,7 @@ module type S = ('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 val gram_reinit : te Plexing.lexer -> unit @@ -261,69 +168,3 @@ module type S = must specify a way to show them as (string * string) *) module GMake (L : GLexerType) : S with type te = L.te - -(** {6 Miscellaneous} *) - -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 - the item itself (for typing reasons) but its value is ignored. - This function is used to allow IFDEF and IFNDEF for cases of - constructor declarations and pattern matchings. *) - -val error_verbose : bool ref - (** Flag for displaying more information in case of parsing error; - default = [False] *) - -val warning_verbose : bool ref - (** Flag for displaying warnings while extension; default = [True] *) - -val strict_parsing : bool ref - (** Flag to apply strict parsing, without trying to recover errors; - default = [False] *) - -val utf8_print : bool ref - (** Flag to consider strings as utf8-encoded when printing them; - default = [True] *) - -val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit - (** General printer for all kinds of entries (obj entries) *) - -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. *) - -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. *) - -val reinit_entry_functions : 'te Gramext.g_entry -> unit - -(*** For system use *) - -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" *) -val backtrack_parse : bool ref diff --git a/gramlib/ploc.ml b/gramlib/ploc.ml index 43bfa0dd1f..cb71f72678 100644 --- a/gramlib/ploc.ml +++ b/gramlib/ploc.ml @@ -2,8 +2,6 @@ (* ploc.ml,v *) (* Copyright (c) INRIA 2007-2017 *) -(* #load "pa_macro.cmo" *) - type t = { fname : string; line_nb : int; @@ -176,16 +174,3 @@ let raise 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 aec6b4e8b8..d2ab62db06 100644 --- a/gramlib/ploc.mli +++ b/gramlib/ploc.mli @@ -120,9 +120,3 @@ val call_with : 'a ref -> 'a -> ('b -> 'c) -> 'b -> 'c 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 re-raised. The result is the result of [f a]. *) - -(**/**) - -val make : int -> int -> int * int -> t - (** deprecated function since version 6.00; use [make_loc] instead - with the empty string *) |