--- /dev/null
+(****************************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* 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 Objective *)
+(* Caml source tree. *)
+(* *)
+(****************************************************************************)
+
+(* Authors:
+ * - Daniel de Rauglaudre: initial version
+ * - Nicolas Pouillard: refactoring
+ *)
+
+module Make (Structure : Structure.S) = struct
+ module Tools = Tools.Make Structure;
+ module Parser = Parser.Make Structure;
+ open Structure;
+
+(* 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 -> 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 }
+ | Sopt s -> decr_keyw_use gram s
+ | 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 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 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 Not_found ]
+;
+
+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 c strm ->
+ let f = Parser.start_parser_of_entry entry in
+ do { entry.estart := f; f lev c strm };
+ entry.econtinue :=
+ fun lev bp a c strm ->
+ let f = Parser.continue_parser_of_entry entry in
+ do { entry.econtinue := f; f lev bp a c strm }
+ }
+ | Dparser _ -> () ]
+;
+
+end;
projects / l4.git / blobdiff