l4/pkg/ocaml/contrib/camlp4/Camlp4/Struct/Grammar/Delete.ml

   1 (****************************************************************************)
   2 (*                                                                          *)
   3 (*                              Objective Caml                              *)
   4 (*                                                                          *)
   5 (*                            INRIA Rocquencourt                            *)
   6 (*                                                                          *)
   7 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
   9 (*  the terms of the GNU Library General Public License, with the special   *)
  10 (*  exception on linking described in LICENSE at the top of the Objective   *)
  11 (*  Caml source tree.                                                       *)
  12 (*                                                                          *)
  13 (****************************************************************************)
  14
  15 (* Authors:
  16  * - Daniel de Rauglaudre: initial version
  17  * - Nicolas Pouillard: refactoring
  18  *)
  19
  20 module Make (Structure : Structure.S) = struct
  21   module Tools  = Tools.Make Structure;
  22   module Parser = Parser.Make Structure;
  23   open Structure;
  24
  25 (* Deleting a rule *)
  26
  27 (* [delete_rule_in_tree] returns
  28      [Some (dsl, t)] if success
  29         [dsl] =
  30            Some (list of deleted nodes) if branch deleted
  31            None if action replaced by previous version of action
  32         [t] = remaining tree
  33      [None] if failure *)
  34
  35 value delete_rule_in_tree entry =
  36   let rec delete_in_tree symbols tree =
  37     match (symbols, tree) with
  38     [ ([s :: sl], Node n) ->
  39         if Tools.logically_eq_symbols entry s n.node then delete_son sl n
  40         else
  41           match delete_in_tree symbols n.brother with
  42           [ Some (dsl, t) ->
  43               Some (dsl, Node {node = n.node; son = n.son; brother = t})
  44           | None -> None ]
  45     | ([_ :: _], _) -> None
  46     | ([], Node n) ->
  47         match delete_in_tree [] n.brother with
  48         [ Some (dsl, t) ->
  49             Some (dsl, Node {node = n.node; son = n.son; brother = t})
  50         | None -> None ]
  51     | ([], DeadEnd) -> None
  52     | ([], LocAct _ []) -> Some (Some [], DeadEnd)
  53     | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ]
  54   and delete_son sl n =
  55     match delete_in_tree sl n.son with
  56     [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother)
  57     | Some (Some dsl, t) ->
  58         let t = Node {node = n.node; son = t; brother = n.brother} in
  59         Some (Some [n.node :: dsl], t)
  60     | Some (None, t) ->
  61         let t = Node {node = n.node; son = t; brother = n.brother} in
  62         Some (None, t)
  63     | None -> None ]
  64   in
  65   delete_in_tree
  66 ;
  67 value rec decr_keyw_use gram =
  68   fun
  69   [ Skeyword kwd -> removing gram kwd
  70   | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl
  71   | Slist0 s -> decr_keyw_use gram s
  72   | Slist1 s -> decr_keyw_use gram s
  73   | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
  74   | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
  75   | Sopt s -> decr_keyw_use gram s
  76   | Stree t -> decr_keyw_use_in_tree gram t
  77   | Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ]
  78 and decr_keyw_use_in_tree gram =
  79   fun
  80   [ DeadEnd | LocAct _ _ -> ()
  81   | Node n ->
  82       do {
  83         decr_keyw_use gram n.node;
  84         decr_keyw_use_in_tree gram n.son;
  85         decr_keyw_use_in_tree gram n.brother
  86       } ]
  87 ;
  88 value rec delete_rule_in_suffix entry symbols =
  89   fun
  90   [ [lev :: levs] ->
  91       match delete_rule_in_tree entry symbols lev.lsuffix with
  92       [ Some (dsl, t) ->
  93           do {
  94             match dsl with
  95             [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
  96             | None -> () ];
  97             match t with
  98             [ DeadEnd when lev.lprefix == DeadEnd -> levs
  99             | _ ->
 100                 let lev =
 101                   {assoc = lev.assoc; lname = lev.lname; lsuffix = t;
 102                    lprefix = lev.lprefix}
 103                 in
 104                 [lev :: levs] ]
 105           }
 106       | None ->
 107           let levs = delete_rule_in_suffix entry symbols levs in
 108           [lev :: levs] ]
 109   | [] -> raise Not_found ]
 110 ;
 111
 112 value rec delete_rule_in_prefix entry symbols =
 113   fun
 114   [ [lev :: levs] ->
 115       match delete_rule_in_tree entry symbols lev.lprefix with
 116       [ Some (dsl, t) ->
 117           do {
 118             match dsl with
 119             [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
 120             | None -> () ];
 121             match t with
 122             [ DeadEnd when lev.lsuffix == DeadEnd -> levs
 123             | _ ->
 124                 let lev =
 125                   {assoc = lev.assoc; lname = lev.lname;
 126                    lsuffix = lev.lsuffix; lprefix = t}
 127                 in
 128                 [lev :: levs] ]
 129           }
 130       | None ->
 131           let levs = delete_rule_in_prefix entry symbols levs in
 132           [lev :: levs] ]
 133   | [] -> raise Not_found ]
 134 ;
 135
 136 value rec delete_rule_in_level_list entry symbols levs =
 137   match symbols with
 138   [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs
 139   | [Snterm e :: symbols] when e == entry ->
 140       delete_rule_in_suffix entry symbols levs
 141   | _ -> delete_rule_in_prefix entry symbols levs ]
 142 ;
 143
 144
 145 value delete_rule entry sl =
 146   match entry.edesc with
 147   [ Dlevels levs ->
 148       let levs = delete_rule_in_level_list entry sl levs in
 149       do {
 150         entry.edesc := Dlevels levs;
 151         entry.estart :=
 152           fun lev c strm ->
 153             let f = Parser.start_parser_of_entry entry in
 154             do { entry.estart := f; f lev c strm };
 155         entry.econtinue :=
 156           fun lev bp a c strm ->
 157             let f = Parser.continue_parser_of_entry entry in
 158             do { entry.econtinue := f; f lev bp a c strm }
 159       }
 160   | Dparser _ -> () ]
 161 ;
 162
 163 end;