(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the Camlp4 *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
exception Rule_not_found of (string * string);
let () =
Printexc.register_printer
(fun
[ Rule_not_found (symbols, entry) ->
let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in
Some msg
| _ -> None ]) in ()
;
module Make (Structure : Structure.S) = struct
module Tools = Tools.Make Structure;
module Parser = Parser.Make Structure;
module Print = Print.Make Structure;
open Structure;
value raise_rule_not_found entry symbols =
let to_string f x =
let buff = Buffer.create 128 in
let ppf = Format.formatter_of_buffer buff in
do {
f ppf x;
Format.pp_print_flush ppf ();
Buffer.contents buff
} in
let entry = to_string Print.entry entry in
let symbols = to_string Print.print_rule symbols in
raise (Rule_not_found (symbols, entry))
;
(* Deleting a rule *)
(* [delete_rule_in_tree] returns
[Some (dsl, t)] if success
[dsl] =
Some (list of deleted nodes) if branch deleted
None if action replaced by previous version of action
[t] = remaining tree
[None] if failure *)
value delete_rule_in_tree entry =
let rec delete_in_tree symbols tree =
match (symbols, tree) with
[ ([s :: sl], Node n) ->
if Tools.logically_eq_symbols entry s n.node then delete_son sl n
else
match delete_in_tree symbols n.brother with
[ Some (dsl, t) ->
Some (dsl, Node {node = n.node; son = n.son; brother = t})
| None -> None ]
| ([_ :: _], _) -> None
| ([], Node n) ->
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) ]
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, t) ->
let t = Node {node = n.node; son = t; brother = n.brother} in
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 ]
in
delete_in_tree
;
value rec decr_keyw_use gram =
fun
[ Skeyword kwd -> removing gram kwd
| Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl
| Slist0 s | Slist1 s | Sopt s | Stry 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 }
| Stree t -> decr_keyw_use_in_tree gram t
| Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ]
and decr_keyw_use_in_tree gram =
fun
[ DeadEnd | LocAct _ _ -> ()
| Node n ->
do {
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 lev =
{assoc = lev.assoc; lname = lev.lname; lsuffix = t;
lprefix = lev.lprefix}
in
[lev :: levs] ]
}
| None ->
let levs = delete_rule_in_suffix entry symbols levs in
[lev :: levs] ]
| [] -> raise_rule_not_found entry symbols ]
;
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 lev =
{assoc = lev.assoc; lname = lev.lname;
lsuffix = lev.lsuffix; lprefix = t}
in
[lev :: levs] ]
}
| None ->
let levs = delete_rule_in_prefix entry symbols levs in
[lev :: levs] ]
| [] -> raise_rule_not_found entry symbols ]
;
value 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 ->
delete_rule_in_suffix entry symbols levs
| _ -> delete_rule_in_prefix entry symbols levs ]
;
value delete_rule entry sl =
match entry.edesc with
[ Dlevels levs ->
let levs = delete_rule_in_level_list entry sl levs in
do {
entry.edesc := Dlevels levs;
entry.estart :=
fun lev strm ->
let f = Parser.start_parser_of_entry entry in
do { entry.estart := f; f lev strm };
entry.econtinue :=
fun lev bp a strm ->
let f = Parser.continue_parser_of_entry entry in
do { entry.econtinue := f; f lev bp a strm }
}
| Dparser _ -> () ]
;
end;