aboutsummaryrefslogtreecommitdiff
path: root/gramlib
diff options
context:
space:
mode:
Diffstat (limited to 'gramlib')
-rw-r--r--gramlib/gramext.ml68
-rw-r--r--gramlib/gramext.mli7
-rw-r--r--gramlib/grammar.ml22
-rw-r--r--gramlib/grammar.mli5
4 files changed, 50 insertions, 52 deletions
diff --git a/gramlib/gramext.ml b/gramlib/gramext.ml
index 43a70ca13b..c35c4bd18e 100644
--- a/gramlib/gramext.ml
+++ b/gramlib/gramext.ml
@@ -55,8 +55,6 @@ type position =
| Like of string
| Level of string
-let warning_verbose = ref true
-
let rec derive_eps =
function
Slist0 _ -> true
@@ -96,7 +94,7 @@ let is_before s1 s2 =
| Stoken _, _ -> true
| _ -> false
-let insert_tree entry_name gsymbols action tree =
+let insert_tree ~warning entry_name gsymbols action tree =
let rec insert symbols tree =
match symbols with
s :: sl -> insert_in_tree s sl tree
@@ -105,14 +103,16 @@ let insert_tree entry_name gsymbols action tree =
Node {node = s; son = son; brother = bro} ->
Node {node = s; son = son; brother = insert [] bro}
| 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)
+ begin match warning with
+ | None -> ()
+ | Some warn_fn ->
+ let msg =
+ "<W> Grammar extension: " ^
+ (if entry_name <> "" then "" else "in ["^entry_name^"%s], ") ^
+ "some rule has been masked" in
+ warn_fn msg
+ end;
+ LocAct (action, old_action :: action_list)
| DeadEnd -> LocAct (action, [])
and insert_in_tree s sl tree =
match try_insert s sl tree with
@@ -141,10 +141,10 @@ let insert_tree entry_name gsymbols action tree =
in
insert gsymbols tree
-let srules rl =
+let srules ~warning rl =
let t =
List.fold_left
- (fun tree (symbols, action) -> insert_tree "" symbols action tree)
+ (fun tree (symbols, action) -> insert_tree ~warning "" symbols action tree)
DeadEnd rl
in
Stree t
@@ -175,15 +175,15 @@ and token_exists_in_symbol f =
| Stree t -> token_exists_in_tree f t
| Snterm _ | Snterml (_, _) | Snext | Sself -> false
-let insert_level entry_name e1 symbols action slev =
+let insert_level ~warning entry_name e1 symbols action slev =
match e1 with
true ->
{assoc = slev.assoc; lname = slev.lname;
- lsuffix = insert_tree entry_name symbols action slev.lsuffix;
+ lsuffix = insert_tree ~warning entry_name symbols action slev.lsuffix;
lprefix = slev.lprefix}
| false ->
{assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
- lprefix = insert_tree entry_name symbols action slev.lprefix}
+ lprefix = insert_tree ~warning entry_name symbols action slev.lprefix}
let empty_lev lname assoc =
let assoc =
@@ -193,27 +193,33 @@ let empty_lev lname assoc =
in
{assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
-let change_lev lev n lname assoc =
+let change_lev ~warning lev n lname assoc =
let a =
match assoc with
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;
+ if a <> lev.assoc then
+ begin
+ match warning with
+ | None -> ()
+ | Some warn_fn ->
+ warn_fn ("<W> Changing associativity of level \""^n^"\"")
+ end;
a
in
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
+ if lname <> lev.lname then
+ begin match warning with
+ | None -> ()
+ | Some warn_fn ->
+ warn_fn ("<W> Level label \""^n^"\" ignored")
+ end;
| None -> ()
end;
{assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix}
-let get_level entry position levs =
+let get_level ~warning entry position levs =
match position with
Some First -> [], empty_lev, levs
| Some Last -> levs, empty_lev, []
@@ -226,7 +232,7 @@ let get_level entry position levs =
flush stderr;
failwith "Grammar.extend"
| lev :: levs ->
- if is_level_labelled n lev then [], change_lev lev n, levs
+ if is_level_labelled n lev then [], change_lev ~warning lev n, levs
else
let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2
in
@@ -268,14 +274,14 @@ let get_level entry position levs =
flush stderr;
failwith "Grammar.extend"
| lev :: levs ->
- if token_exists_in_level f lev then [], change_lev lev n, levs
+ if token_exists_in_level f lev then [], change_lev ~warning lev n, levs
else
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
+ lev :: levs -> [], change_lev ~warning lev "<top>", levs
| [] -> [], empty_lev, []
let rec check_gram entry =
@@ -347,7 +353,7 @@ let insert_tokens gram symbols =
in
List.iter insert symbols
-let levels_of_rules entry position rules =
+let levels_of_rules ~warning entry position rules =
let elev =
match entry.edesc with
Dlevels elev -> elev
@@ -358,7 +364,7 @@ let levels_of_rules entry position rules =
in
if rules = [] then elev
else
- let (levs1, make_lev, levs2) = get_level entry position elev in
+ let (levs1, make_lev, levs2) = get_level ~warning entry position elev in
let (levs, _) =
List.fold_left
(fun (levs, make_lev) (lname, assoc, level) ->
@@ -370,7 +376,7 @@ let levels_of_rules entry position rules =
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 ~warning entry.ename e1 symbols action lev)
lev level
in
lev :: levs, empty_lev)
diff --git a/gramlib/gramext.mli b/gramlib/gramext.mli
index 8361e21645..ecb95ec61b 100644
--- a/gramlib/gramext.mli
+++ b/gramlib/gramext.mli
@@ -53,15 +53,14 @@ type position =
| Like of string
| Level of string
-val levels_of_rules :
+val levels_of_rules : warning:(string -> unit) option ->
'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
+
+val srules : warning:(string -> unit) option -> ('te g_symbol list * g_action) list -> 'te g_symbol
val eq_symbol : 'a g_symbol -> 'a g_symbol -> bool
val delete_rule_in_level_list :
'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list
-
-val warning_verbose : bool ref
diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml
index dfce26a33a..285c14ec62 100644
--- a/gramlib/grammar.ml
+++ b/gramlib/grammar.ml
@@ -755,9 +755,9 @@ let init_entry_functions entry =
let f = continue_parser_of_entry entry in
entry.econtinue <- f; f lev bp a strm)
-let extend_entry entry position rules =
+let extend_entry ~warning entry position rules =
try
- let elev = Gramext.levels_of_rules entry position rules in
+ let elev = Gramext.levels_of_rules ~warning entry position rules in
entry.edesc <- Dlevels elev; init_entry_functions entry
with Plexing.Error s ->
Printf.eprintf "Lexer initialization error:\n- %s\n" s;
@@ -841,8 +841,6 @@ let clear_entry e =
Dlevels _ -> e.edesc <- Dlevels []
| Dparser _ -> ()
-let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer
-
(* Functorial interface *)
module type GLexerType = sig type te val lexer : te Plexing.lexer end
@@ -881,7 +879,7 @@ module type S =
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_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol
val r_stop : ('self, 'r, 'r) ty_rule
val r_next :
('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol ->
@@ -889,10 +887,9 @@ module type S =
val production : ('a, 'f, Ploc.t -> 'a) ty_rule * 'f -> 'a ty_production
module Unsafe :
sig
- val gram_reinit : te Plexing.lexer -> unit
val clear_entry : 'a Entry.e -> unit
end
- val safe_extend :
+ val safe_extend : warning:(string -> unit) option ->
'a Entry.e -> Gramext.position option ->
(string option * Gramext.g_assoc option * 'a ty_production list)
list ->
@@ -945,7 +942,7 @@ module GMake (L : GLexerType) =
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_rules ~warning (t : Obj.t ty_production list) = Gramext.srules ~warning (Obj.magic t)
let r_stop = []
let r_next r s = r @ [s]
let production
@@ -953,15 +950,12 @@ module GMake (L : GLexerType) =
Obj.magic p
module Unsafe =
struct
- let gram_reinit = gram_reinit gram
let clear_entry = clear_entry
end
- let extend = extend_entry
- let safe_extend e pos
+ let safe_extend ~warning 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
+ extend_entry ~warning e pos (Obj.magic r)
+ let safe_delete_rule e r = delete_rule (Entry.obj e) r
end
diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli
index 1e14e557bc..0c585a7c0d 100644
--- a/gramlib/grammar.mli
+++ b/gramlib/grammar.mli
@@ -53,7 +53,7 @@ module type S =
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_rules : warning:(string -> unit) option -> 'a ty_production list -> ('self, 'a) ty_symbol
val r_stop : ('self, 'r, 'r) ty_rule
val r_next :
('self, 'a, 'r) ty_rule -> ('self, 'b) ty_symbol ->
@@ -62,10 +62,9 @@ module type S =
module Unsafe :
sig
- val gram_reinit : te Plexing.lexer -> unit
val clear_entry : 'a Entry.e -> unit
end
- val safe_extend :
+ val safe_extend : warning:(string -> unit) option ->
'a Entry.e -> Gramext.position option ->
(string option * Gramext.g_assoc option * 'a ty_production list)
list ->
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-29 06:02:28 +0000