Permalink
Browse files

Getting longidets locs and envs from the compiler. All tests pass !

  • Loading branch information...
1 parent 0d04ec5 commit 9aa51f315bc43f1f9433aa3f849556020dc05809 Tiphaine Turpin committed Jul 7, 2011
Showing with 337 additions and 118 deletions.
  1. BIN boot/ocamlc
  2. BIN boot/ocamldep
  3. +20 −11 driver/compile.ml
  4. +19 −9 driver/optcompile.ml
  5. +1 −1 driver/pparse.ml
  6. +2 −2 driver/pparse.mli
  7. +1 −1 ocamldoc/odoc_analyse.ml
  8. +0 −1 ocamlwizard/TODO
  9. +100 −27 ocamlwizard/refactor/findName.ml
  10. +1 −1 ocamlwizard/refactor/findName.mli
  11. +7 −6 ocamlwizard/refactor/rename.ml
  12. +3 −5 ocamlwizard/test/Makefile
  13. +7 −4 ocamlwizard/test/README
  14. +3 −0 ocamlwizard/test/expected/renameIncludeNewCaptured_rres.ml
  15. +3 −0 ocamlwizard/test/expected/renameIncludeOldCaptured_rres.ml
  16. +2 −0 ocamlwizard/test/expected/renameMultiple_rres.ml
  17. +3 −0 ocamlwizard/test/expected/renameOpenNewCaptured_rres.ml
  18. +3 −0 ocamlwizard/test/expected/renameOpenOldCaptured_rres.ml
  19. +2 −0 ocamlwizard/test/expected/renamePropFunctorNoApp_rres.ml
  20. +2 −0 ocamlwizard/test/expected/renamePropFunctor_rres.ml
  21. +2 −0 ocamlwizard/test/expected/renameProp_rres.ml
  22. +3 −0 ocamlwizard/test/expected/renameSigNewCaptured_rres.ml
  23. +3 −0 ocamlwizard/test/expected/renameSigOldCaptured_rres.ml
  24. +2 −0 ocamlwizard/test/expected/renameSimple_rres.ml
  25. +8 −0 ocamlwizard/test/expected/renameType_rres.ml
  26. +6 −0 ocamlwizard/test/renameType.ml
  27. +24 −0 parsing/longident.ml
  28. +8 −0 parsing/longident.mli
  29. +2 −3 parsing/parse.ml
  30. +6 −2 parsing/parse.mli
  31. +34 −23 parsing/parser.mly
  32. +34 −14 typing/env.ml
  33. +12 −1 typing/env.mli
  34. +1 −0 typing/typedtree.ml
  35. +1 −0 typing/typedtree.mli
  36. +6 −3 typing/typemod.ml
  37. +6 −4 typing/typemod.mli
View
BIN boot/ocamlc
Binary file not shown.
View
BIN boot/ocamldep
Binary file not shown.
View
31 driver/compile.ml
@@ -71,6 +71,11 @@ let check_unit_name ppf filename name =
(* Compile a .mli file *)
+let transl_signature env (ast, loc, lloc) =
+ Env.record_path_environments ();
+ let tsg = Typemod.transl_signature env ast in
+ tsg, loc, lloc, (Env.flush_paths ())
+
let interface ppf sourcefile outputprefix =
Location.input_name := sourcefile;
init_path ();
@@ -80,11 +85,10 @@ let interface ppf sourcefile outputprefix =
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
try
- let ast, ident_locations =
+ let parsetree, _, _ as ast =
Pparse.file ppf inputfile Parse.interface' ast_intf_magic_number in
- if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
- Env.record_path_environments ();
- let tsg = Typemod.transl_signature (initial_env()) ast in
+ if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface parsetree;
+ let tsg, _, _, _ as s = transl_signature (initial_env()) ast in
let sg = tsg.sig_type in
if !Clflags.print_types then
fprintf std_formatter "%a@." Printtyp.signature
@@ -93,7 +97,8 @@ let interface ppf sourcefile outputprefix =
if not !Clflags.print_types then begin
Env.save_signature sg modulename (outputprefix ^ ".cmi");
Typemod.save_signature
- ident_locations (Env.flush_paths ()) tsg outputprefix;
+ s
+ outputprefix;
end;
Pparse.remove_preprocessed inputfile
with e ->
@@ -119,28 +124,32 @@ let implementation ppf sourcefile outputprefix =
let env = initial_env() in
if !Clflags.print_types then begin
try ignore(
- let ast, ident_locations =
+ let parsetree, _, _ as ast =
Pparse.file ppf inputfile Parse.implementation' ast_impl_magic_number
in
- ast
+ parsetree
++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ ignore;
+ ast
++ Typemod.type_implementation
- sourcefile outputprefix modulename env ident_locations)
+ sourcefile outputprefix modulename env)
with x ->
Pparse.remove_preprocessed_if_ast inputfile;
raise x
end else begin
let objfile = outputprefix ^ ".cmo" in
let oc = open_out_bin objfile in
try
- let ast, ident_locations =
+ let parsetree, _, _ as ast =
Pparse.file ppf inputfile Parse.implementation' ast_impl_magic_number
in
- ast
+ parsetree
++ print_if ppf Clflags.dump_parsetree Printast.implementation
++ Unused_var.warn ppf
+ ++ ignore;
+ ast
++ Typemod.type_implementation
- sourcefile outputprefix modulename env ident_locations
+ sourcefile outputprefix modulename env
++ Translmod.transl_implementation modulename
++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
++ Simplif.simplify_lambda
View
28 driver/optcompile.ml
@@ -68,6 +68,12 @@ let check_unit_name ppf filename name =
(* Compile a .mli file *)
+(* duplicated from compile *)
+let transl_signature env (ast, loc, lloc) =
+ Env.record_path_environments ();
+ let tsg = Typemod.transl_signature env ast in
+ tsg, loc, lloc, (Env.flush_paths ())
+
let interface ppf sourcefile outputprefix =
Location.input_name := sourcefile;
init_path ();
@@ -77,10 +83,10 @@ let interface ppf sourcefile outputprefix =
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
try
- let ast, ident_locations =
+ let parsetree, _, _ as ast =
Pparse.file ppf inputfile Parse.interface' ast_intf_magic_number in
- if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
- let sg = Typemod.transl_signature (initial_env()) ast in
+ if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface parsetree;
+ let sg, _, _, _ = transl_signature (initial_env()) ast in
if !Clflags.print_types then
fprintf std_formatter "%a@." Printtyp.signature
(Typemod.simplify_signature sg.sig_type);
@@ -117,25 +123,29 @@ let implementation ppf sourcefile outputprefix =
let objfile = outputprefix ^ ext_obj in
try
if !Clflags.print_types then ignore(
- let ast, ident_locations =
+ let parsetree, _, _ as ast =
Pparse.file
ppf inputfile Parse.implementation' ast_impl_magic_number
in
- ast
+ parsetree
++ print_if ppf Clflags.dump_parsetree Printast.implementation
++ Unused_var.warn ppf
+ ++ ignore;
+ ast
++ Typemod.type_implementation
- sourcefile outputprefix modulename env ident_locations)
+ sourcefile outputprefix modulename env)
else begin
- let ast, ident_locations =
+ let parsetree, _, _ as ast =
Pparse.file
ppf inputfile Parse.implementation' ast_impl_magic_number
in
- ast
+ parsetree
++ print_if ppf Clflags.dump_parsetree Printast.implementation
++ Unused_var.warn ppf
+ ++ ignore;
+ ast
++ Typemod.type_implementation
- sourcefile outputprefix modulename env ident_locations
+ sourcefile outputprefix modulename env
++ Translmod.transl_store_implementation modulename
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+++ Simplif.simplify_lambda
View
2 driver/pparse.ml
@@ -69,7 +69,7 @@ let file ppf inputfile parse_fun ast_magic =
fprintf ppf "@[Warning: %s@]@."
"option -unsafe used with a preprocessor returning a syntax tree";
Location.input_name := input_value ic;
- input_value ic, None
+ input_value ic, None, None
end else begin
seek_in ic 0;
Location.input_name := inputfile;
View
4 driver/pparse.mli
@@ -20,5 +20,5 @@ val preprocess : string -> string
val remove_preprocessed : string -> unit
val remove_preprocessed_if_ast : string -> unit
val file :
- formatter -> string -> (Lexing.lexbuf -> 'a * 'b option) -> string ->
- 'a * 'b option
+ formatter -> string -> (Lexing.lexbuf -> 'a * 'b option * 'c option) -> string ->
+ 'a * 'b option * 'c option
View
2 ocamldoc/odoc_analyse.ml
@@ -116,7 +116,7 @@ let process_implementation_file ppf sourcefile =
let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in
let typedtree =
Typemod.type_implementation
- sourcefile prefixname modulename env None parsetree
+ sourcefile prefixname modulename env (parsetree, None, None)
in
(Some (parsetree, typedtree), inputfile)
with
View
1 ocamlwizard/TODO
@@ -1,5 +1,4 @@
- Traverse directly the path table to get all occurrences with kind, loc, env
-- Git add renameType.ml
- Rename: rename in signatures
- Rename: replace in multiple files
- Rename: return a list of files that emacs should revert
View
127 ocamlwizard/refactor/findName.ml
@@ -22,18 +22,8 @@ open Typedtree
open TypedtreeOps
open Resolve
-type occurrence_kind = [
- `exp_ident
-| `mod_ident
-| `exp_open
-| `str_open
-| `sig_open
-| `mty_with
-| `mty_ident
-| `core_type_type
-| `pat_alias_type
-]
-
+(* An alternative technique for collecting occurrences. *)
+(*
(* Is that meaningful ? *)
let rec path2loc idents = function
| Path.Pident s -> Location.StringTbl.find idents (Ident.name s)
@@ -66,6 +56,19 @@ let rec env_of_node root_env father_table n =
| `bindings _ -> assert false
| _ -> failwith ("env_of_node: unsupported case " ^ node_kind n)
+let rec check_same = function
+ | [x] -> x
+ | (_, lid, env) :: ((_, lid', env') :: _ as l) ->
+ if lid != lid' then failwith "different longidents";
+ if env != env' then failwith "different environments";
+ check_same l
+ | [] -> invalid_arg "check_same"
+
+let lookup_path path_table p =
+ match Env.PathTbl.find_all path_table p with
+ | [] -> failwith ("path " ^ Path.name p ^ " not found")
+ | l -> debugln "checking path %s" (Path.name p) ; check_same l
+
let shift n loc =
let start = loc.Location.loc_start in
{ loc with Location.loc_start =
@@ -75,7 +78,7 @@ let shift n loc =
(* This should only be complete w.r.t. values and module paths ! But
we cannot have safe renaming for modules until we are complete
w.r.t. paths of all sorts. *)
-let find_all_occurrences env idents tree : ('a * ('b * occurrence_kind)) list =
+let find_all_occurrences env idents paths tree =
let father_table = reverse tree in
let found loc env occ = Some (loc, (env, occ))
(*
@@ -85,26 +88,35 @@ let find_all_occurrences env idents tree : ('a * ('b * occurrence_kind)) list =
debugln "loc = [%d, %d[" b e;
loc
*)
+(*
and env = env_of_node env father_table in
+*)
+ and env p =
+ let sort, lid, env = lookup_path paths p in
+(*
+ let loc = lid2loc
+*)
+ env
+ in
find_all_map
(function n ->
match n with
| `pattern p ->
(match p.pat_desc with
- | Tpat_alias (_, TPat_type _) ->
- found (shift 1 p.pat_loc) (env n) `pat_alias_type
+ | Tpat_alias (_, TPat_type path) ->
+ found (shift 1 p.pat_loc) (env path) Env.Type
| _ -> None)
| `core_type t ->
(match t.ctyp_desc with
| Ttyp_constr (p, _) ->
- found t.ctyp_loc (env n) `core_type_type
+ found t.ctyp_loc (env p) Env.Type
| _ -> None)
| `expression e ->
(match e.exp_desc with
- | Texp_ident _ -> found e.exp_loc e.exp_env `exp_ident
+ | Texp_ident _ -> found e.exp_loc e.exp_env Env.Value
(* If the renamed ident is not a module or modtype,
then we could filter according to the right_most
ident. Otherwise, there is no way to know if we
@@ -122,7 +134,7 @@ let find_all_occurrences env idents tree : ('a * ('b * occurrence_kind)) list =
| `module_expr m ->
(match m.mod_desc with
- | Tmod_ident _ -> found m.mod_loc m.mod_env `mod_ident
+ | Tmod_ident _ -> found m.mod_loc m.mod_env Env.Module
| _ -> None)
| `module_type t ->
@@ -149,7 +161,7 @@ let find_all_occurrences env idents tree : ('a * ('b * occurrence_kind)) list =
| `structure_item i ->
(match i.str_desc with
- | Tstr_open _ -> found i.str_loc i.str_env `str_open
+ | Tstr_open _ -> found (shift 4 i.str_loc) i.str_env Env.Module
| _ -> None)
(* needed for modules
@@ -168,19 +180,80 @@ let find_all_occurrences env idents tree : ('a * ('b * occurrence_kind)) list =
| _ -> None)
tree
-let get_occurrences env idents s =
+let get_occurrences env idents lidents paths s =
List.sort
(fun (loc, _) (loc', _) ->
let open Lexing in
compare loc.loc_start.pos_cnum loc.loc_end.pos_cnum)
- (find_all_occurrences env idents s)
+ (find_all_occurrences env idents paths s)
+*)
+
+let reverse t =
+ let r = Longident.LongidentTbl.create 1000 in
+ Env.PathTbl.iter
+ (fun p (sort, lid, env) ->
+ if sort <> Env.Annot then
+ Longident.LongidentTbl.add r lid (sort, p, env))
+ t;
+ r
+
+let kind2kind = function
+ | Env.Value -> value_ops
+ | Env.Type -> type_ops
+ | Env.Annot
+ | Env.Constructor
+ | Env.Label
+ | Env.Module
+ | Env.Modtype
+ | Env.Class
+ | Env.Cltype
+ -> raise Not_found
+
+let kind2str = function
+ | Env.Value -> "value"
+ | Env.Type -> "type"
+ | Env.Annot -> "annot"
+ | Env.Constructor -> "constructor"
+ | Env.Label -> "label"
+ | Env.Module -> "module"
+ | Env.Modtype -> "modtype"
+ | Env.Class -> "class"
+ | Env.Cltype -> "cltype"
+
+let rec check_same = function
+ | [x] -> x
+ | (kind, p, env) :: ((kind', p', 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
+ (* We should check that keys are bound only once *)
+ Longident.LongidentTbl.fold
+ (fun lid loc acc ->
+ match Longident.LongidentTbl.find_all lid2path lid with
+ | [] ->
+ debugln "lident %s has no environment" (lid_to_str lid);
+ acc
+ | l ->
+ debugln "testing %s" (lid_to_str lid);
+ let kind, p, env = check_same l in
+ if kind = Env.Value || kind = Env.Type then
+ (loc, (env, kind)) :: acc
+ else
+ acc)
+ lidents
+ []
let extract_longident (loc, s, (env, occ)) =
let kind = match occ with
- | `exp_ident -> value_ops
- | `mod_ident -> module_ops
- | `core_type_type -> type_ops
- | `pat_alias_type -> type_ops
+ | Env.Value -> value_ops
+ | Env.Module -> module_ops
+ | Env.Type -> type_ops
| _ -> failwith "not implemented"
in
let ast =
@@ -191,10 +264,10 @@ let extract_longident (loc, s, (env, occ)) =
in
(loc, ast, (env, kind))
-let get_lids env file idents ast =
+let get_lids env file idents lidents paths ast =
List.map
extract_longident
- (source_locations file (get_occurrences env idents ast))
+ (source_locations file (get_occurrences env idents lidents paths ast))
let ident_of_subtree = function
| `pattern {pat_desc = Tpat_var id}
View
2 ocamlwizard/refactor/findName.mli
@@ -27,7 +27,7 @@ val get_occurrences :
val get_lids :
Env.t ->
string ->
- Location.string_table ->
+ Location.string_table -> Location.t Longident.LongidentTbl.t -> Env.path2env ->
[ `signature of Typedtree.signature | `structure of Typedtree.structure ]->
(Location.t * Longident.t * (Env.t * Resolve.specifics)) list
View
13 ocamlwizard/refactor/rename.ml
@@ -183,10 +183,11 @@ let read_cmt file =
match data.(0) with
| Saved_implementation str ->
(try
- match data.(1), data.(2) with
+ match data.(1), data.(2), data.(3) with
| Saved_ident_locations (Some loc),
+ Saved_longident_locations (Some lloc),
Saved_path_environments (Some env) ->
- str, loc, env
+ str, loc, lloc, env
(*
| Saved_ident_locations None ->
failwith "ident location table is empty"
@@ -230,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) =
+let rename_in_file env renamed_kind id name' file (s, idents, lidents, paths) =
(* Collect constraints requiring simultaneous renaming *)
let constraints, includes = collect_signature_inclusions (`structure s) in
@@ -249,7 +250,7 @@ let rename_in_file env renamed_kind id name' file (s, idents) =
check_renamed_implicit_references renamed_kind ids name' implicit_refs;
(* Collect all lids *)
- let lids = get_lids env file idents (`structure s) in
+ let lids = get_lids env file idents lidents paths (`structure s) in
(* Check that our new name will not capture other occurrences *)
check_lids renamed_kind ids name' lids;
@@ -281,7 +282,7 @@ let rename loc name' file =
failwith "cmt file is older than source file";
(* Read the typedtree *)
- let s, idents, paths = read_cmt cmt_file in
+ let s, idents, lidents, paths = read_cmt cmt_file in
(* Get the "initial" id to rename and its sort *)
let renamed_kind, id = locate_renamed_id (`structure s) loc in
@@ -296,7 +297,7 @@ let rename loc name' file =
let name' = fix_case renamed_kind name' in
let def_replaces, occ_replaces =
- rename_in_file env renamed_kind id name' file (s, idents) in
+ rename_in_file env renamed_kind id name' file (s, idents, lidents, paths) in
(* We need to sort them again (they may interleave). *)
let replaces = sort_replaces (def_replaces @ occ_replaces) in
View
8 ocamlwizard/test/Makefile
@@ -7,8 +7,7 @@ R_CASES=renameSimple.ml renameSigNewCaptured.ml renameSigOldCaptured.ml \
renameIncludeNewCaptured.ml renameIncludeOldCaptured.ml \
renameOpenNewCaptured.ml renameOpenOldCaptured.ml \
renameMultiple.ml renameProp.ml renamePropFunctor.ml \
- renamePropFunctorNoApp.ml
-# renameType.ml
+ renamePropFunctorNoApp.ml renameType.ml
# renameModtype.ml
R_TESTS=$(subst .ml,_rres.ml, $(R_CASES))
@@ -136,9 +135,8 @@ errors_comp.ml: errors.ml errors_no_dollar.ml $(OWZ)
`grep -o -b \\\\$$ $< | cut -d : -f 1`-\
`tail -c +2 $< | grep -o -b € | cut -d : -f 1` \
y $@
-
-# cat ../../.ocamlwizard-stderr >> $@
-
+ cat ../../.ocamlwizard-stdout >>$@
+ /bin/echo -e \\n >>$@
# Old
View
11 ocamlwizard/test/README
@@ -1,4 +1,7 @@
-Tests cases are build from the two files prefix.ml and tests.ml as
-follows: each line of tests.ml which contains a $ is appended to
-prefix.ml to form a test case, with the -pos argument being the
-position of $.
+Tests cases are organised as follows:
+- the files prefix.ml and path.ml, expansion.ml and match_cases.ml are lists
+ of tests cases: each line of these files which contains a $ is appended to
+ prefix.ml to form a test case, with the -pos argument being the position of $
+ (and €, if relevant).
+- errors.ml and errors.ml.last_compiled form a single test (for backtracking)
+- the rename*.ml (without _rres) files are standalone test cases
View
3 ocamlwizard/test/expected/renameIncludeNewCaptured_rres.ml
@@ -7,3 +7,6 @@ end
include M
let _ = y
+File "renameIncludeNewCaptured_no_dollar.ml", line 4, characters 6-7:
+This definition of x that you are trying to rename would capture an occurrence of an existing definition of y
+
View
3 ocamlwizard/test/expected/renameIncludeOldCaptured_rres.ml
@@ -7,3 +7,6 @@ end
include M
let _ = x
+File "renameIncludeOldCaptured_no_dollar.ml", line 4, characters 6-7:
+This existing definition of y would capture an occurrence of x
+
View
2 ocamlwizard/test/expected/renameMultiple_rres.ml
@@ -5,3 +5,5 @@ module M : sig
end = struct
let y = ()
end
+Renamed 2 definition(s) and 0 reference(s)
+
View
3 ocamlwizard/test/expected/renameOpenNewCaptured_rres.ml
@@ -7,3 +7,6 @@ end
open M
let _ = y
+File "renameOpenNewCaptured_no_dollar.ml", line 4, characters 6-7:
+This definition of x that you are trying to rename would capture an occurrence of an existing definition of y
+
View
3 ocamlwizard/test/expected/renameOpenOldCaptured_rres.ml
@@ -7,3 +7,6 @@ end
open M
let _ = x
+File "renameOpenOldCaptured_no_dollar.ml", line 4, characters 6-7:
+This existing definition of y would capture an occurrence of x
+
View
2 ocamlwizard/test/expected/renamePropFunctorNoApp_rres.ml
@@ -7,3 +7,5 @@ module F(X : sig val x : int end) = struct let z = X.x end
module N = F(struct let x = 2 let tot = () end)
let _ = M.y
+Renamed 1 definition(s) and 1 reference(s)
+
View
2 ocamlwizard/test/expected/renamePropFunctor_rres.ml
@@ -9,3 +9,5 @@ module N = F(struct let y = 2 let tot = () end)
module O = F(M)
let _ = M.y
+Renamed 3 definition(s) and 2 reference(s)
+
View
2 ocamlwizard/test/expected/renameProp_rres.ml
@@ -5,3 +5,5 @@ end
module N = (M : sig val y : int end)
let _ = N.y
+Renamed 2 definition(s) and 1 reference(s)
+
View
3 ocamlwizard/test/expected/renameSigNewCaptured_rres.ml
@@ -5,3 +5,6 @@ module M = struct
end
let _ = M.y
+File "renameSigNewCaptured_no_dollar.ml", line 4, characters 6-7:
+This definition of x that you are trying to rename would capture an occurrence of an existing definition of y
+
View
3 ocamlwizard/test/expected/renameSigOldCaptured_rres.ml
@@ -5,3 +5,6 @@ module M = struct
end
let _ = M.x
+File "renameSigOldCaptured_no_dollar.ml", line 4, characters 6-7:
+This existing definition of y would capture an occurrence of x
+
View
2 ocamlwizard/test/expected/renameSimple_rres.ml
@@ -3,3 +3,5 @@ module M = struct
end
let _ = M.y
+Renamed 1 definition(s) and 1 reference(s)
+
View
8 ocamlwizard/test/expected/renameType_rres.ml
@@ -0,0 +1,8 @@
+type y = [`foo]
+
+type z = y
+let _ = (`foo : y)
+let _ = match `foo with #y -> ()
+let _ = match `foo with (_ : y) -> ()
+Renamed 1 definition(s) and 4 reference(s)
+
View
6 ocamlwizard/test/renameType.ml
@@ -0,0 +1,6 @@
+type $x€ = [`foo]
+
+type z = x
+let _ = (`foo : x)
+let _ = match `foo with #x -> ()
+let _ = match `foo with (_ : x) -> ()
View
24 parsing/longident.ml
@@ -41,3 +41,27 @@ let parse s =
[] -> Lident "" (* should not happen, but don't put assert false
so as not to crash the toplevel (see Genprintval) *)
| hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl
+
+module LongidentTbl = Hashtbl.Make
+ (struct
+ type u = t
+ type t = u
+ let equal = ( == )
+ let hash = Hashtbl.hash
+ end)
+
+let longident_table : Location.t LongidentTbl.t option ref = ref None
+
+let record_longident_locations () =
+ longident_table := Some (LongidentTbl.create 1000)
+
+let flush_longidents () =
+ let idents = !longident_table in
+ longident_table := None;
+ idents
+
+let longident loc i =
+ (match !longident_table with
+ | Some t -> LongidentTbl.add t i loc
+ | None -> ());
+ i
View
8 parsing/longident.mli
@@ -22,3 +22,11 @@ type t =
val flatten: t -> string list
val last: t -> string
val parse: string -> t
+
+module LongidentTbl : Hashtbl.S with type key = t
+
+val record_longident_locations : unit -> unit
+
+val flush_longidents : unit -> Location.t LongidentTbl.t option
+
+val longident : Location.t -> t -> t
View
5 parsing/parse.ml
@@ -65,10 +65,9 @@ and use_file = wrap Parser.use_file
let with_ident_locations parsing_fun lexbuf =
Lexer.record_ident_locations ();
+ Longident.record_longident_locations ();
let ast = parsing_fun lexbuf in
- match Lexer.flush_idents () with
- | Some idents -> ast, Some idents
- | None -> assert false
+ ast, Lexer.flush_idents (), Longident.flush_longidents ()
let implementation' = with_ident_locations implementation
and interface' = with_ident_locations interface
View
8 parsing/parse.mli
@@ -20,6 +20,10 @@ val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase
val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list
val implementation' :
- Lexing.lexbuf -> Parsetree.structure * Location.string_table option
+ Lexing.lexbuf ->
+ Parsetree.structure * Location.string_table option
+ * Location.t Longident.LongidentTbl.t option
val interface' :
- Lexing.lexbuf -> Parsetree.signature * Location.string_table option
+ Lexing.lexbuf ->
+ Parsetree.signature * Location.string_table option
+ * Location.t Longident.LongidentTbl.t option
View
57 parsing/parser.mly
@@ -48,8 +48,19 @@ 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 mkoperator name pos =
- { pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc 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'))
(*
Ghost expressions and patterns:
@@ -203,7 +214,7 @@ let bigarray_set arr arg newval =
let lapply p1 p2 =
if !Clflags.applicative_functors
- then Lapply(p1, p2)
+ then lapply p1 p2
else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc())))
let exp_of_label lbl =
@@ -1113,7 +1124,7 @@ label_expr:
{ ("?" ^ $1, $2) }
;
label_ident:
- LIDENT { ($1, mkexp(Pexp_ident(Lident $1))) }
+ LIDENT { ($1, mkexp(Pexp_ident(lident $1))) }
;
let_bindings:
let_binding { [$1] }
@@ -1625,44 +1636,44 @@ constr_ident:
;
val_longident:
- val_ident { Lident $1 }
- | mod_longident DOT val_ident { Ldot($1, $3) }
+ val_ident { lident $1 }
+ | mod_longident DOT val_ident { ldot $1 $3 }
;
constr_longident:
mod_longident %prec below_DOT { $1 }
- | LBRACKET RBRACKET { Lident "[]" }
- | LPAREN RPAREN { Lident "()" }
- | FALSE { Lident "false" }
- | TRUE { Lident "true" }
+ | LBRACKET RBRACKET { lident "[]" }
+ | LPAREN RPAREN { lident "()" }
+ | FALSE { lident "false" }
+ | TRUE { lident "true" }
;
label_longident:
- LIDENT { Lident $1 }
- | mod_longident DOT LIDENT { Ldot($1, $3) }
+ LIDENT { lident $1 }
+ | mod_longident DOT LIDENT { ldot $1 $3 }
;
type_longident:
- LIDENT { Lident $1 }
- | mod_ext_longident DOT LIDENT { Ldot($1, $3) }
+ LIDENT { lident $1 }
+ | mod_ext_longident DOT LIDENT { ldot $1 $3 }
;
mod_longident:
- UIDENT { Lident $1 }
- | mod_longident DOT UIDENT { Ldot($1, $3) }
+ UIDENT { lident $1 }
+ | mod_longident DOT UIDENT { ldot $1 $3 }
;
mod_ext_longident:
- UIDENT { Lident $1 }
- | mod_ext_longident DOT UIDENT { Ldot($1, $3) }
+ UIDENT { lident $1 }
+ | mod_ext_longident DOT UIDENT { ldot $1 $3 }
| mod_ext_longident LPAREN mod_ext_longident RPAREN { lapply $1 $3 }
;
mty_longident:
- ident { Lident $1 }
- | mod_ext_longident DOT ident { Ldot($1, $3) }
+ ident { lident $1 }
+ | mod_ext_longident DOT ident { ldot $1 $3 }
;
clty_longident:
- LIDENT { Lident $1 }
- | mod_ext_longident DOT LIDENT { Ldot($1, $3) }
+ LIDENT { lident $1 }
+ | mod_ext_longident DOT LIDENT { ldot $1 $3 }
;
class_longident:
- LIDENT { Lident $1 }
- | mod_longident DOT LIDENT { Ldot($1, $3) }
+ LIDENT { lident $1 }
+ | mod_longident DOT LIDENT { ldot $1 $3 }
;
/* Toplevel directives */
View
48 typing/env.ml
@@ -498,7 +498,18 @@ module PathTbl = Hashtbl.Make
let hash = Hashtbl.hash
end)
-type path2env = t PathTbl.t
+type path_sort =
+ | Value
+ | Annot
+ | Constructor
+ | Label
+ | Type
+ | Module
+ | Modtype
+ | Class
+ | Cltype
+
+type path2env = (path_sort * Longident.t * t) PathTbl.t
let path_table = ref None
@@ -510,37 +521,46 @@ let flush_paths () =
path_table := None;
paths
-let record p env =
+let record p sort lid env =
match !path_table with
- | Some t -> PathTbl.add t p env
+ | Some t -> PathTbl.add t p (sort, lid, env)
| None -> ()
+(*
let lookup_module lid env =
let path, _ as res = lookup_module lid env in
record path env;
res
+*)
-let lookup proj1 proj2 lid env =
+let recording sort lookup lid env =
+ let path, _ as res = lookup lid env in
+ record path sort lid env;
+ res
+
+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 env;
- res
+ record path sort lid env;
+ res
let lookup_value =
- lookup (fun env -> env.values) (fun sc -> sc.comp_values)
+ lookup Value (fun env -> env.values) (fun sc -> sc.comp_values)
let lookup_annot id e =
- lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
+ lookup Annot (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
and lookup_constructor =
- lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+ lookup Constructor (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
and lookup_label =
- lookup (fun env -> env.labels) (fun sc -> sc.comp_labels)
+ lookup Label (fun env -> env.labels) (fun sc -> sc.comp_labels)
and lookup_type =
- lookup (fun env -> env.types) (fun sc -> sc.comp_types)
+ lookup Type (fun env -> env.types) (fun sc -> sc.comp_types)
and lookup_modtype =
- lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
+ lookup Modtype (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
and lookup_class =
- lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
+ lookup Class (fun env -> env.classes) (fun sc -> sc.comp_classes)
and lookup_cltype =
- lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+ lookup Cltype (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
let ident_tbl_fold f t acc =
List.fold_right
View
13 typing/env.mli
@@ -174,7 +174,18 @@ val check_modtype_inclusion:
module PathTbl : Hashtbl.S with type key = Path.t
-type path2env = t PathTbl.t
+type path_sort =
+ | Value
+ | Annot
+ | Constructor
+ | Label
+ | Type
+ | Module
+ | Modtype
+ | Class
+ | Cltype
+
+type path2env = (path_sort * Longident.t * t) PathTbl.t
val record_path_environments : unit -> unit
View
1 typing/typedtree.ml
@@ -361,6 +361,7 @@ 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
let saved_types = ref []
View
1 typing/typedtree.mli
@@ -378,6 +378,7 @@ 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
val get_saved_types : unit -> saved_type list
View
9 typing/typemod.ml
@@ -1172,17 +1172,19 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
end
end
-let save_signature loc env tsg outputprefix =
+let save_signature (tsg, loc, lloc, penv) outputprefix =
if !Clflags.annotations then
let oc = open_out (outputprefix ^ ".cmti") in
output_value oc [|
Saved_signature tsg;
Saved_ident_locations loc;
- Saved_path_environments env
+ Saved_longident_locations lloc;
+ Saved_path_environments penv
|];
close_out oc
-let type_implementation sourcefile outputprefix modulename initial_env loc ast =
+let type_implementation
+ sourcefile outputprefix modulename initial_env (ast, loc, lloc) =
try
Typedtree.set_saved_types [];
Env.record_path_environments ();
@@ -1193,6 +1195,7 @@ let type_implementation sourcefile outputprefix modulename initial_env loc ast =
output_value oc [|
Saved_implementation str;
Saved_ident_locations loc;
+ Saved_longident_locations lloc;
Saved_path_environments (Env.flush_paths ())
|];
close_out oc;
View
10 typing/typemod.mli
@@ -23,8 +23,9 @@ val type_structure:
Env.t -> Parsetree.structure -> Location.t ->
Typedtree.structure * Types.signature * Env.t
val type_implementation:
- string -> string -> string -> Env.t -> Location.string_table option ->
- Parsetree.structure ->
+ string -> string -> string -> Env.t ->
+ (Parsetree.structure * Location.string_table option
+ * Location.t Longident.LongidentTbl.t option) ->
Typedtree.structure * Typedtree.module_coercion
val transl_signature:
Env.t -> Parsetree.signature -> Typedtree.signature
@@ -34,8 +35,9 @@ val check_nongen_schemes:
val simplify_signature: signature -> signature
val save_signature :
- Location.string_table option -> Env.path2env option ->
- Typedtree.signature -> string -> unit
+ (Typedtree.signature * Location.string_table option
+ * Location.t Longident.LongidentTbl.t option * Env.path2env option) ->
+ string -> unit
val package_units:
string list -> string -> string -> Typedtree.module_coercion

0 comments on commit 9aa51f3

Please sign in to comment.