Guest User

Untitled

a guest
Feb 18th, 2019
101
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 8.63 KB | None | 0 0
  1. Index: typing/env.ml
  2. ===================================================================
  3. --- typing/env.ml (revision 15965)
  4. +++ typing/env.ml (working copy)
  5. @@ -122,14 +122,26 @@
  6. module EnvTbl =
  7. struct
  8. (* A table indexed by identifier, with an extra slot to record usage. *)
  9. - type 'a t = ('a * (unit -> unit)) Ident.tbl
  10. + type 'a t =
  11. + {
  12. + current: ('a * (unit -> unit)) Ident.tbl;
  13. + previous: 'a t option;
  14. + }
  15.  
  16. - let empty = Ident.empty
  17. + let empty =
  18. + {
  19. + current = Ident.empty;
  20. + previous = None;
  21. + }
  22. +
  23. let nothing = fun () -> ()
  24.  
  25. - let already_defined s tbl =
  26. - try ignore (Ident.find_name s tbl); true
  27. - with Not_found -> false
  28. + let rec already_defined s tbl =
  29. + try ignore (Ident.find_name s tbl.current); true
  30. + with Not_found ->
  31. + match tbl.previous with
  32. + | None -> false
  33. + | Some tbl -> already_defined s tbl
  34.  
  35. let add kind slot id x tbl ref_tbl =
  36. let slot =
  37. @@ -141,29 +153,79 @@
  38. f kind s (already_defined s ref_tbl)
  39. )
  40. in
  41. - Ident.add id (x, slot) tbl
  42. + {
  43. + current = Ident.add id (x, slot) tbl.current;
  44. + previous = tbl.previous;
  45. + }
  46.  
  47. let add_dont_track id x tbl =
  48. - Ident.add id (x, nothing) tbl
  49. + {
  50. + current = Ident.add id (x, nothing) tbl.current;
  51. + previous = tbl.previous;
  52. + }
  53.  
  54. - let find_same_not_using id tbl =
  55. - fst (Ident.find_same id tbl)
  56. + let rec find_same_not_using id tbl =
  57. + try fst (Ident.find_same id tbl.current)
  58. + with Not_found ->
  59. + match tbl.previous with
  60. + | None -> raise Not_found
  61. + | Some tbl -> find_same_not_using id tbl
  62.  
  63. - let find_same id tbl =
  64. - let (x, slot) = Ident.find_same id tbl in
  65. - slot ();
  66. - x
  67. + let rec find_same id tbl =
  68. + try
  69. + let (x, slot) = Ident.find_same id tbl.current in
  70. + slot ();
  71. + x
  72. + with Not_found ->
  73. + match tbl.previous with
  74. + | None -> raise Not_found
  75. + | Some tbl -> find_same id tbl
  76.  
  77. - let find_name s tbl =
  78. - let (x, slot) = Ident.find_name s tbl in
  79. - slot ();
  80. - x
  81. + let rec find_name s tbl =
  82. + try
  83. + let (x, slot) = Ident.find_name s tbl.current in
  84. + slot ();
  85. + x
  86. + with Not_found ->
  87. + match tbl.previous with
  88. + | None -> raise Not_found
  89. + | Some tbl -> find_name s tbl
  90.  
  91. - let find_all s tbl =
  92. - Ident.find_all s tbl
  93. + let rec find_all s tbl =
  94. + let l = Ident.find_all s tbl.current in
  95. + match tbl.previous with
  96. + | None -> l
  97. + | Some tbl -> l @ find_all s tbl
  98.  
  99. - let fold_name f = Ident.fold_name (fun k (d,_) -> f k d)
  100. - let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl []
  101. + let rec fold_name f tbl acc =
  102. + (* TODO: this is wrong, since duplicates are not removed! *)
  103. + let acc =
  104. + match tbl.previous with
  105. + | None -> acc
  106. + | Some tbl -> fold_name f tbl acc
  107. + in
  108. + Ident.fold_name (fun k (d,_) -> f k d) tbl.current acc
  109. +
  110. + let rec keys tbl =
  111. + let acc =
  112. + match tbl.previous with
  113. + | None -> []
  114. + | Some tbl -> keys tbl
  115. + in
  116. + Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc
  117. +
  118. + let merge tbl1 tbl2 =
  119. + assert(tbl1.previous == None);
  120. + {
  121. + current = tbl1.current;
  122. + previous = Some tbl2;
  123. + }
  124. +
  125. + let rec iter f tbl =
  126. + Ident.iter (fun id (d, _) -> f id d) tbl.current;
  127. + match tbl.previous with
  128. + | None -> ()
  129. + | Some tbl -> iter f tbl
  130. end
  131.  
  132. type type_descriptions =
  133. @@ -763,6 +825,7 @@
  134. | Lapply(l1, l2) ->
  135. raise Not_found
  136.  
  137. +(*
  138. let lookup_simple proj1 proj2 lid env =
  139. match lid with
  140. Lident s ->
  141. @@ -778,6 +841,7 @@
  142. end
  143. | Lapply(l1, l2) ->
  144. raise Not_found
  145. +*)
  146.  
  147. let lookup_all_simple proj1 proj2 shadow lid env =
  148. match lid with
  149. @@ -990,7 +1054,7 @@
  150. | _ -> true
  151.  
  152. let iter_env proj1 proj2 f env () =
  153. - Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env);
  154. + EnvTbl.iter (fun id x -> f (Pident id) x) (proj1 env);
  155. let rec iter_components path path' mcomps =
  156. let cont () =
  157. let safe =
  158. @@ -1018,8 +1082,8 @@
  159. let id = Pident (Ident.create_persistent s) in
  160. iter_components id id ps.ps_comps)
  161. persistent_structures;
  162. - Ident.iter
  163. - (fun id ((path, comps), _) -> iter_components (Pident id) path comps)
  164. + EnvTbl.iter
  165. + (fun id (path, comps) -> iter_components (Pident id) path comps)
  166. env.components
  167.  
  168. let run_iter_cont l =
  169. @@ -1050,7 +1114,7 @@
  170. let rec find_shadowed_comps path env =
  171. match path with
  172. Pident id ->
  173. - List.map fst (Ident.find_all (Ident.name id) env.components)
  174. + List.map fst (EnvTbl.find_all (Ident.name id) env.components)
  175. | Pdot (p, s, _) ->
  176. let l = find_shadowed_comps p env in
  177. let l' =
  178. @@ -1061,7 +1125,7 @@
  179. let find_shadowed proj1 proj2 path env =
  180. match path with
  181. Pident id ->
  182. - List.map fst (Ident.find_all (Ident.name id) (proj1 env))
  183. + List.map fst (EnvTbl.find_all (Ident.name id) (proj1 env))
  184. | Pdot (p, s, _) ->
  185. let l = find_shadowed_comps p env in
  186. let l' = List.map (find_all_comps proj2 s) l in
  187. @@ -1589,35 +1653,59 @@
  188.  
  189. (* Open a signature path *)
  190.  
  191. -let open_signature slot root sg env0 =
  192. +let open_sig_env root sg =
  193. + let env0 = empty in
  194. + let slot = None in
  195. +
  196. (* First build the paths and substitution *)
  197. let (pl, sub, sg) = prefix_idents_and_subst root Subst.identity sg in
  198. let sg = Lazy.force sg in
  199.  
  200. (* Then enter the components in the environment after substitution *)
  201. + List.fold_left2
  202. + (fun env item p ->
  203. + match item with
  204. + Sig_value(id, decl) ->
  205. + store_value slot (Ident.hide id) p decl env env0
  206. + | Sig_type(id, decl, _) ->
  207. + store_type ~check:false slot (Ident.hide id) p decl env env0
  208. + | Sig_typext(id, ext, _) ->
  209. + store_extension ~check:false slot (Ident.hide id) p ext env env0
  210. + | Sig_module(id, mty, _) ->
  211. + store_module slot (Ident.hide id) p mty env env0
  212. + | Sig_modtype(id, decl) ->
  213. + store_modtype slot (Ident.hide id) p decl env env0
  214. + | Sig_class(id, decl, _) ->
  215. + store_class slot (Ident.hide id) p decl env env0
  216. + | Sig_class_type(id, decl, _) ->
  217. + store_cltype slot (Ident.hide id) p decl env env0
  218. + )
  219. + empty sg pl
  220.  
  221. - let newenv =
  222. - List.fold_left2
  223. - (fun env item p ->
  224. - match item with
  225. - Sig_value(id, decl) ->
  226. - store_value slot (Ident.hide id) p decl env env0
  227. - | Sig_type(id, decl, _) ->
  228. - store_type ~check:false slot (Ident.hide id) p decl env env0
  229. - | Sig_typext(id, ext, _) ->
  230. - store_extension ~check:false slot (Ident.hide id) p ext env env0
  231. - | Sig_module(id, mty, _) ->
  232. - store_module slot (Ident.hide id) p mty env env0
  233. - | Sig_modtype(id, decl) ->
  234. - store_modtype slot (Ident.hide id) p decl env env0
  235. - | Sig_class(id, decl, _) ->
  236. - store_class slot (Ident.hide id) p decl env env0
  237. - | Sig_class_type(id, decl, _) ->
  238. - store_cltype slot (Ident.hide id) p decl env env0
  239. - )
  240. - env0 sg pl in
  241. - { newenv with summary = Env_open(env0.summary, root) }
  242. +let open_sig =
  243. + let tbl = Hashtbl.create 16 in
  244. + fun root sg ->
  245. + try Hashtbl.find tbl (root, sg)
  246. + with Not_found ->
  247. + let r = open_sig_env root sg in
  248. + Hashtbl.add tbl (root, sg) r;
  249. + r
  250.  
  251. +let open_signature slot root sg env0 =
  252. + let newenv = open_sig root sg in
  253. + { env0 with
  254. + values = EnvTbl.merge newenv.values env0.values;
  255. + constrs = EnvTbl.merge newenv.constrs env0.constrs;
  256. + labels = EnvTbl.merge newenv.labels env0.labels;
  257. + types = EnvTbl.merge newenv.types env0.types;
  258. + modules = EnvTbl.merge newenv.modules env0.modules;
  259. + modtypes = EnvTbl.merge newenv.modtypes env0.modtypes;
  260. + components = EnvTbl.merge newenv.components env0.components;
  261. + classes = EnvTbl.merge newenv.classes env0.classes;
  262. + cltypes = EnvTbl.merge newenv.cltypes env0.cltypes;
  263. + summary = Env_open(env0.summary, root);
  264. + }
  265. +
  266. (* Open a signature from a file *)
  267.  
  268. let open_pers_signature name env =
  269. @@ -1626,7 +1714,7 @@
  270. (Lazy.force ps.ps_sig) env
  271.  
  272. let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
  273. - if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
  274. + if false && not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
  275. && (Warnings.is_active (Warnings.Unused_open "")
  276. || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
  277. || Warnings.is_active (Warnings.Open_shadow_label_constructor ("","")))
Add Comment
Please, Sign In to add comment