Permalink
Browse files

Cleanup in the compiler hooks

  • Loading branch information...
1 parent 9aa51f3 commit 362a08d6dbe54f61171f5adc9e14b36d0b399389 Tiphaine Turpin committed Jul 7, 2011
@@ -188,6 +188,7 @@ let get_occurrences env idents lidents paths s =
(find_all_occurrences env idents paths s)
*)
+(*
let reverse t =
let r = Longident.LongidentTbl.create 1000 in
Env.PathTbl.iter
@@ -196,6 +197,7 @@ let reverse t =
Longident.LongidentTbl.add r lid (sort, p, env))
t;
r
+*)
let kind2kind = function
| Env.Value -> value_ops
@@ -222,34 +224,38 @@ let kind2str = function
let rec check_same = function
| [x] -> x
- | (kind, p, env) :: ((kind', p', env') :: _ as l) ->
+ | (kind, env) :: ((kind', env') :: _ as l) ->
if kind <> kind' then
failwith (kind2str kind ^ " <> " ^ kind2str kind');
- if p != p' then failwith "different paths";
if env != env' then failwith "different environments";
check_same l
| [] -> invalid_arg "check_same"
-let get_occurrences env idents lidents paths s =
- let lid2path = reverse paths in
+let get_occurrences lid2loc lid2env s =
(* We should check that keys are bound only once *)
Longident.LongidentTbl.fold
(fun lid loc acc ->
- match Longident.LongidentTbl.find_all lid2path lid with
+ let envs = Env.LongidentTbl.find_all lid2env lid in
+ let envs = List.filter (function kind, _ -> kind <> Env.Annot) envs in
+ match envs with
| [] ->
- debugln "lident %s has no environment" (lid_to_str lid);
+ Location.print Format.std_formatter loc;
+ Printf.printf "Warning: lident %s has no environment\n" (lid_to_str lid);
+(*
+ failwith ("lident" ^ lid_to_str lid ^ "has no environment");
+*)
acc
| l ->
debugln "testing %s" (lid_to_str lid);
- let kind, p, env = check_same l in
+ let kind, env = check_same l in
if kind = Env.Value || kind = Env.Type then
(loc, (env, kind)) :: acc
else
acc)
- lidents
+ lid2loc
[]
-let extract_longident (loc, s, (env, occ)) =
+let extract_longident (loc, text, (env, occ)) =
let kind = match occ with
| Env.Value -> value_ops
| Env.Module -> module_ops
@@ -258,16 +264,16 @@ let extract_longident (loc, s, (env, occ)) =
in
let ast =
try
- kind.parse_lid s
+ kind.parse_lid text
with _ ->
- failwith ("error parsing the following ident: " ^ s)
+ failwith ("error parsing the following ident: " ^ text)
in
(loc, ast, (env, kind))
-let get_lids env file idents lidents paths ast =
+let get_lids env file lidents paths ast =
List.map
extract_longident
- (source_locations file (get_occurrences env idents lidents paths ast))
+ (source_locations file (get_occurrences lidents paths ast))
let ident_of_subtree = function
| `pattern {pat_desc = Tpat_var id}
@@ -27,7 +27,7 @@ val get_occurrences :
val get_lids :
Env.t ->
string ->
- Location.string_table -> Location.t Longident.LongidentTbl.t -> Env.path2env ->
+ Location.t Longident.LongidentTbl.t -> Env.lid2env ->
[ `signature of Typedtree.signature | `structure of Typedtree.structure ]->
(Location.t * Longident.t * (Env.t * Resolve.specifics)) list
@@ -231,7 +231,7 @@ let backup file =
Edit.cp file backup
(* Rename an ident in a structure file, with given ast. *)
-let rename_in_file env renamed_kind id name' file (s, idents, lidents, paths) =
+let rename_in_file env renamed_kind id name' file (s, idents, lid2loc, paths) =
(* Collect constraints requiring simultaneous renaming *)
let constraints, includes = collect_signature_inclusions (`structure s) in
@@ -250,7 +250,7 @@ let rename_in_file env renamed_kind id name' file (s, idents, lidents, paths) =
check_renamed_implicit_references renamed_kind ids name' implicit_refs;
(* Collect all lids *)
- let lids = get_lids env file idents lidents paths (`structure s) in
+ let lids = get_lids env file lid2loc paths (`structure s) in
(* Check that our new name will not capture other occurrences *)
check_lids renamed_kind ids name' lids;
View
@@ -50,7 +50,9 @@ module LongidentTbl = Hashtbl.Make
let hash = Hashtbl.hash
end)
-let longident_table : Location.t LongidentTbl.t option ref = ref None
+type lid2loc = Location.t LongidentTbl.t
+
+let longident_table : lid2loc option ref = ref None
let record_longident_locations () =
longident_table := Some (LongidentTbl.create 1000)
@@ -60,8 +62,12 @@ let flush_longidents () =
longident_table := None;
idents
-let longident loc i =
- (match !longident_table with
+let add_longident loc i =
+ match !longident_table with
| Some t -> LongidentTbl.add t i loc
- | None -> ());
- i
+ | None -> ()
+
+let remove_longident i =
+ match !longident_table with
+ | Some t -> LongidentTbl.remove t i
+ | None -> ()
@@ -25,8 +25,11 @@ val parse: string -> t
module LongidentTbl : Hashtbl.S with type key = t
+type lid2loc = Location.t LongidentTbl.t
+
val record_longident_locations : unit -> unit
-val flush_longidents : unit -> Location.t LongidentTbl.t option
+val flush_longidents : unit -> lid2loc option
-val longident : Location.t -> t -> t
+val add_longident : Location.t -> t -> unit
+val remove_longident : t -> unit
View
@@ -21,9 +21,7 @@ val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
val implementation' :
Lexing.lexbuf ->
- Parsetree.structure * Location.string_table option
- * Location.t Longident.LongidentTbl.t option
+ Parsetree.structure * Location.string_table option * Longident.lid2loc option
val interface' :
Lexing.lexbuf ->
- Parsetree.signature * Location.string_table option
- * Location.t Longident.LongidentTbl.t option
+ Parsetree.signature * Location.string_table option * Longident.lid2loc option
View
@@ -48,19 +48,20 @@ let mkcf d =
let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
-
-(*
-let ghlongident = longident Location.none
-let ghlident = lident Location.none
-*)
+let longident loc lid = add_longident loc lid ; lid
let mkoperator name pos =
{ pexp_desc = Pexp_ident(longident (rhs_loc pos) (Lident name));
pexp_loc = rhs_loc pos }
let lident i = longident (symbol_rloc ()) (Lident i)
-let ldot lid i = longident (symbol_rloc ()) (Ldot (lid, i))
-let lapply lid lid' = longident (symbol_rloc ()) (Lapply (lid, lid'))
+let ldot lid i =
+ remove_longident lid;
+ longident (symbol_rloc ()) (Ldot (lid, i))
+let lapply lid lid' =
+ remove_longident lid;
+ remove_longident lid';
+ longident (symbol_rloc ()) (Lapply (lid, lid'))
(*
Ghost expressions and patterns:
View
@@ -491,11 +491,11 @@ let lookup_simple proj1 proj2 lid env =
| Lapply(l1, l2) ->
raise Not_found
-module PathTbl = Hashtbl.Make
+module LongidentTbl = Hashtbl.Make
(struct
- type t = Path.t
- let equal = ( == )
- let hash = Hashtbl.hash
+ type t = Longident.t
+ let equal = ( == )
+ let hash = Hashtbl.hash
end)
type path_sort =
@@ -509,41 +509,39 @@ type path_sort =
| Class
| Cltype
-type path2env = (path_sort * Longident.t * t) PathTbl.t
+type lid2env = (path_sort * t) LongidentTbl.t
-let path_table = ref None
+let lid2env = ref None
let record_path_environments () =
- path_table := Some (PathTbl.create 1000)
+ lid2env := Some (LongidentTbl.create 1000)
let flush_paths () =
- let paths = !path_table in
- path_table := None;
+ let paths = !lid2env in
+ lid2env := None;
paths
-let record p sort lid env =
- match !path_table with
- | Some t -> PathTbl.add t p (sort, lid, env)
+let record sort lid env =
+ match !lid2env with
+ | Some t ->
+ if
+ (try
+ let s, e = LongidentTbl.find t lid in
+ s != sort || e != env
+ with Not_found -> true)
+ then
+ LongidentTbl.add t lid (sort, env)
| None -> ()
-(*
-let lookup_module lid env =
- let path, _ as res = lookup_module lid env in
- record path env;
- res
-*)
-
let recording sort lookup lid env =
- let path, _ as res = lookup lid env in
- record path sort lid env;
- res
+ record sort lid env;
+ lookup lid env
let lookup_module = recording Module lookup_module
let lookup sort proj1 proj2 lid env =
- let path, _ as res = lookup proj1 proj2 lid env in
- record path sort lid env;
- res
+ record sort lid env;
+ lookup proj1 proj2 lid env
let lookup_value =
lookup Value (fun env -> env.values) (fun sc -> sc.comp_values)
View
@@ -172,7 +172,8 @@ val report_error: formatter -> error -> unit
val check_modtype_inclusion:
(t -> module_type -> Path.t -> module_type -> unit) ref
-module PathTbl : Hashtbl.S with type key = Path.t
+(* Duplicated from Longident (linking problem with genannot) *)
+module LongidentTbl : Hashtbl.S with type key = Longident.t
type path_sort =
| Value
@@ -185,8 +186,8 @@ type path_sort =
| Class
| Cltype
-type path2env = (path_sort * Longident.t * t) PathTbl.t
+type lid2env = (path_sort * t) LongidentTbl.t
val record_path_environments : unit -> unit
-val flush_paths : unit -> path2env option
+val flush_paths : unit -> lid2env option
View
@@ -361,8 +361,8 @@ type saved_type =
| Saved_pattern of pattern
| Saved_class_expr of class_expr
| Saved_ident_locations of Location.string_table option
-| Saved_longident_locations of Location.t Longident.LongidentTbl.t option
-| Saved_path_environments of Env.path2env option
+| Saved_longident_locations of Longident.lid2loc option
+| Saved_path_environments of Env.lid2env option
let saved_types = ref []
let get_saved_types () = !saved_types
@@ -378,8 +378,8 @@ type saved_type =
| Saved_pattern of pattern
| Saved_class_expr of class_expr
| Saved_ident_locations of Location.string_table option
-| Saved_longident_locations of Location.t Longident.LongidentTbl.t option
-| Saved_path_environments of Env.path2env option
+| Saved_longident_locations of Longident.lid2loc option
+| Saved_path_environments of Env.lid2env option
val get_saved_types : unit -> saved_type list
val set_saved_types : saved_type list -> unit
View
@@ -25,7 +25,7 @@ val type_structure:
val type_implementation:
string -> string -> string -> Env.t ->
(Parsetree.structure * Location.string_table option
- * Location.t Longident.LongidentTbl.t option) ->
+ * Longident.lid2loc option) ->
Typedtree.structure * Typedtree.module_coercion
val transl_signature:
Env.t -> Parsetree.signature -> Typedtree.signature
@@ -36,7 +36,7 @@ val simplify_signature: signature -> signature
val save_signature :
(Typedtree.signature * Location.string_table option
- * Location.t Longident.LongidentTbl.t option * Env.path2env option) ->
+ * Longident.lid2loc option * Env.lid2env option) ->
string -> unit
val package_units:

0 comments on commit 362a08d

Please sign in to comment.