Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Index: typing/env.ml
- ===================================================================
- --- typing/env.ml (revision 15965)
- +++ typing/env.ml (working copy)
- @@ -122,14 +122,26 @@
- module EnvTbl =
- struct
- (* A table indexed by identifier, with an extra slot to record usage. *)
- - type 'a t = ('a * (unit -> unit)) Ident.tbl
- + type 'a t =
- + {
- + current: ('a * (unit -> unit)) Ident.tbl;
- + previous: 'a t option;
- + }
- - let empty = Ident.empty
- + let empty =
- + {
- + current = Ident.empty;
- + previous = None;
- + }
- +
- let nothing = fun () -> ()
- - let already_defined s tbl =
- - try ignore (Ident.find_name s tbl); true
- - with Not_found -> false
- + let rec already_defined s tbl =
- + try ignore (Ident.find_name s tbl.current); true
- + with Not_found ->
- + match tbl.previous with
- + | None -> false
- + | Some tbl -> already_defined s tbl
- let add kind slot id x tbl ref_tbl =
- let slot =
- @@ -141,29 +153,79 @@
- f kind s (already_defined s ref_tbl)
- )
- in
- - Ident.add id (x, slot) tbl
- + {
- + current = Ident.add id (x, slot) tbl.current;
- + previous = tbl.previous;
- + }
- let add_dont_track id x tbl =
- - Ident.add id (x, nothing) tbl
- + {
- + current = Ident.add id (x, nothing) tbl.current;
- + previous = tbl.previous;
- + }
- - let find_same_not_using id tbl =
- - fst (Ident.find_same id tbl)
- + let rec find_same_not_using id tbl =
- + try fst (Ident.find_same id tbl.current)
- + with Not_found ->
- + match tbl.previous with
- + | None -> raise Not_found
- + | Some tbl -> find_same_not_using id tbl
- - let find_same id tbl =
- - let (x, slot) = Ident.find_same id tbl in
- - slot ();
- - x
- + let rec find_same id tbl =
- + try
- + let (x, slot) = Ident.find_same id tbl.current in
- + slot ();
- + x
- + with Not_found ->
- + match tbl.previous with
- + | None -> raise Not_found
- + | Some tbl -> find_same id tbl
- - let find_name s tbl =
- - let (x, slot) = Ident.find_name s tbl in
- - slot ();
- - x
- + let rec find_name s tbl =
- + try
- + let (x, slot) = Ident.find_name s tbl.current in
- + slot ();
- + x
- + with Not_found ->
- + match tbl.previous with
- + | None -> raise Not_found
- + | Some tbl -> find_name s tbl
- - let find_all s tbl =
- - Ident.find_all s tbl
- + let rec find_all s tbl =
- + let l = Ident.find_all s tbl.current in
- + match tbl.previous with
- + | None -> l
- + | Some tbl -> l @ find_all s tbl
- - let fold_name f = Ident.fold_name (fun k (d,_) -> f k d)
- - let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl []
- + let rec fold_name f tbl acc =
- + (* TODO: this is wrong, since duplicates are not removed! *)
- + let acc =
- + match tbl.previous with
- + | None -> acc
- + | Some tbl -> fold_name f tbl acc
- + in
- + Ident.fold_name (fun k (d,_) -> f k d) tbl.current acc
- +
- + let rec keys tbl =
- + let acc =
- + match tbl.previous with
- + | None -> []
- + | Some tbl -> keys tbl
- + in
- + Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc
- +
- + let merge tbl1 tbl2 =
- + assert(tbl1.previous == None);
- + {
- + current = tbl1.current;
- + previous = Some tbl2;
- + }
- +
- + let rec iter f tbl =
- + Ident.iter (fun id (d, _) -> f id d) tbl.current;
- + match tbl.previous with
- + | None -> ()
- + | Some tbl -> iter f tbl
- end
- type type_descriptions =
- @@ -763,6 +825,7 @@
- | Lapply(l1, l2) ->
- raise Not_found
- +(*
- let lookup_simple proj1 proj2 lid env =
- match lid with
- Lident s ->
- @@ -778,6 +841,7 @@
- end
- | Lapply(l1, l2) ->
- raise Not_found
- +*)
- let lookup_all_simple proj1 proj2 shadow lid env =
- match lid with
- @@ -990,7 +1054,7 @@
- | _ -> true
- let iter_env proj1 proj2 f env () =
- - Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env);
- + EnvTbl.iter (fun id x -> f (Pident id) x) (proj1 env);
- let rec iter_components path path' mcomps =
- let cont () =
- let safe =
- @@ -1018,8 +1082,8 @@
- let id = Pident (Ident.create_persistent s) in
- iter_components id id ps.ps_comps)
- persistent_structures;
- - Ident.iter
- - (fun id ((path, comps), _) -> iter_components (Pident id) path comps)
- + EnvTbl.iter
- + (fun id (path, comps) -> iter_components (Pident id) path comps)
- env.components
- let run_iter_cont l =
- @@ -1050,7 +1114,7 @@
- let rec find_shadowed_comps path env =
- match path with
- Pident id ->
- - List.map fst (Ident.find_all (Ident.name id) env.components)
- + List.map fst (EnvTbl.find_all (Ident.name id) env.components)
- | Pdot (p, s, _) ->
- let l = find_shadowed_comps p env in
- let l' =
- @@ -1061,7 +1125,7 @@
- let find_shadowed proj1 proj2 path env =
- match path with
- Pident id ->
- - List.map fst (Ident.find_all (Ident.name id) (proj1 env))
- + List.map fst (EnvTbl.find_all (Ident.name id) (proj1 env))
- | Pdot (p, s, _) ->
- let l = find_shadowed_comps p env in
- let l' = List.map (find_all_comps proj2 s) l in
- @@ -1589,35 +1653,59 @@
- (* Open a signature path *)
- -let open_signature slot root sg env0 =
- +let open_sig_env root sg =
- + let env0 = empty in
- + let slot = None in
- +
- (* First build the paths and substitution *)
- let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in
- let sg = Lazy.force sg in
- (* Then enter the components in the environment after substitution *)
- + List.fold_left2
- + (fun env item p ->
- + match item with
- + Sig_value(id, decl) ->
- + store_value slot (Ident.hide id) p decl env env0
- + | Sig_type(id, decl, _) ->
- + store_type ~check:false slot (Ident.hide id) p decl env env0
- + | Sig_typext(id, ext, _) ->
- + store_extension ~check:false slot (Ident.hide id) p ext env env0
- + | Sig_module(id, mty, _) ->
- + store_module slot (Ident.hide id) p mty env env0
- + | Sig_modtype(id, decl) ->
- + store_modtype slot (Ident.hide id) p decl env env0
- + | Sig_class(id, decl, _) ->
- + store_class slot (Ident.hide id) p decl env env0
- + | Sig_class_type(id, decl, _) ->
- + store_cltype slot (Ident.hide id) p decl env env0
- + )
- + empty sg pl
- - let newenv =
- - List.fold_left2
- - (fun env item p ->
- - match item with
- - Sig_value(id, decl) ->
- - store_value slot (Ident.hide id) p decl env env0
- - | Sig_type(id, decl, _) ->
- - store_type ~check:false slot (Ident.hide id) p decl env env0
- - | Sig_typext(id, ext, _) ->
- - store_extension ~check:false slot (Ident.hide id) p ext env env0
- - | Sig_module(id, mty, _) ->
- - store_module slot (Ident.hide id) p mty env env0
- - | Sig_modtype(id, decl) ->
- - store_modtype slot (Ident.hide id) p decl env env0
- - | Sig_class(id, decl, _) ->
- - store_class slot (Ident.hide id) p decl env env0
- - | Sig_class_type(id, decl, _) ->
- - store_cltype slot (Ident.hide id) p decl env env0
- - )
- - env0 sg pl in
- - { newenv with summary = Env_open(env0.summary, root) }
- +let open_sig =
- + let tbl = Hashtbl.create 16 in
- + fun root sg ->
- + try Hashtbl.find tbl (root, sg)
- + with Not_found ->
- + let r = open_sig_env root sg in
- + Hashtbl.add tbl (root, sg) r;
- + r
- +let open_signature slot root sg env0 =
- + let newenv = open_sig root sg in
- + { env0 with
- + values = EnvTbl.merge newenv.values env0.values;
- + constrs = EnvTbl.merge newenv.constrs env0.constrs;
- + labels = EnvTbl.merge newenv.labels env0.labels;
- + types = EnvTbl.merge newenv.types env0.types;
- + modules = EnvTbl.merge newenv.modules env0.modules;
- + modtypes = EnvTbl.merge newenv.modtypes env0.modtypes;
- + components = EnvTbl.merge newenv.components env0.components;
- + classes = EnvTbl.merge newenv.classes env0.classes;
- + cltypes = EnvTbl.merge newenv.cltypes env0.cltypes;
- + summary = Env_open(env0.summary, root);
- + }
- +
- (* Open a signature from a file *)
- let open_pers_signature name env =
- @@ -1626,7 +1714,7 @@
- (Lazy.force ps.ps_sig) env
- let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
- - if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
- + if false && not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
- && (Warnings.is_active (Warnings.Unused_open "")
- || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
- || Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")))
Add Comment
Please, Sign In to add comment