Deprecate -annot (#2141)

* Move driver code from Cmt2annot to Read_cmt
* Move cmt2annot.ml into typing/
* make depend
* Use standard error handling
* Move specific logic to read_cmt
* Do not pass full cmt record as argument
* Better locations
* Emit .annot files produced from cmt data
* Remove direct calls to Stypes
* Deprecate -annot
* Changes
* make depend
* Adapt doc
* make -C tools depend
This commit is contained in:
Nicolás Ojeda Bär 2020-03-13 12:59:34 +01:00 committed by GitHub
parent 7fd5dd9fdc
commit 57d329e07b
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
18 changed files with 226 additions and 266 deletions

53
.depend
View File

@ -441,6 +441,34 @@ typing/btype.cmi : \
typing/types.cmi \
typing/path.cmi \
parsing/asttypes.cmi
typing/cmt2annot.cmo : \
typing/types.cmi \
typing/typedtree.cmi \
typing/tast_iterator.cmi \
typing/stypes.cmi \
typing/path.cmi \
typing/oprint.cmi \
parsing/location.cmi \
typing/ident.cmi \
typing/envaux.cmi \
typing/env.cmi \
file_formats/cmt_format.cmi \
parsing/asttypes.cmi \
typing/annot.cmi
typing/cmt2annot.cmx : \
typing/types.cmx \
typing/typedtree.cmx \
typing/tast_iterator.cmx \
typing/stypes.cmx \
typing/path.cmx \
typing/oprint.cmx \
parsing/location.cmx \
typing/ident.cmx \
typing/envaux.cmx \
typing/env.cmx \
file_formats/cmt_format.cmx \
parsing/asttypes.cmi \
typing/annot.cmi
typing/ctype.cmo : \
typing/types.cmi \
typing/type_immediacy.cmi \
@ -553,6 +581,7 @@ typing/envaux.cmo : \
typing/subst.cmi \
typing/printtyp.cmi \
typing/path.cmi \
parsing/location.cmi \
typing/ident.cmi \
typing/env.cmi \
parsing/asttypes.cmi \
@ -561,6 +590,7 @@ typing/envaux.cmx : \
typing/subst.cmx \
typing/printtyp.cmx \
typing/path.cmx \
parsing/location.cmx \
typing/ident.cmx \
typing/env.cmx \
parsing/asttypes.cmi \
@ -819,6 +849,7 @@ typing/persistent_env.cmi : \
file_formats/cmi_format.cmi
typing/predef.cmo : \
typing/types.cmi \
typing/type_immediacy.cmi \
typing/path.cmi \
parsing/parsetree.cmi \
parsing/location.cmi \
@ -829,6 +860,7 @@ typing/predef.cmo : \
typing/predef.cmi
typing/predef.cmx : \
typing/types.cmx \
typing/type_immediacy.cmx \
typing/path.cmx \
parsing/parsetree.cmi \
parsing/location.cmx \
@ -1064,7 +1096,6 @@ typing/typeclass.cmo : \
typing/typedecl.cmi \
typing/typecore.cmi \
typing/subst.cmi \
typing/stypes.cmi \
typing/printtyp.cmi \
typing/predef.cmi \
typing/path.cmi \
@ -1093,7 +1124,6 @@ typing/typeclass.cmx : \
typing/typedecl.cmx \
typing/typecore.cmx \
typing/subst.cmx \
typing/stypes.cmx \
typing/printtyp.cmx \
typing/predef.cmx \
typing/path.cmx \
@ -1130,7 +1160,6 @@ typing/typecore.cmo : \
typing/typedtree.cmi \
typing/typedecl.cmi \
typing/subst.cmi \
typing/stypes.cmi \
typing/rec_check.cmi \
typing/printtyp.cmi \
typing/printpat.cmi \
@ -1140,7 +1169,6 @@ typing/typecore.cmo : \
typing/path.cmi \
parsing/parsetree.cmi \
typing/parmatch.cmi \
typing/oprint.cmi \
typing/mtype.cmi \
utils/misc.cmi \
parsing/longident.cmi \
@ -1163,7 +1191,6 @@ typing/typecore.cmx : \
typing/typedtree.cmx \
typing/typedecl.cmx \
typing/subst.cmx \
typing/stypes.cmx \
typing/rec_check.cmx \
typing/printtyp.cmx \
typing/printpat.cmx \
@ -1173,7 +1200,6 @@ typing/typecore.cmx : \
typing/path.cmx \
parsing/parsetree.cmi \
typing/parmatch.cmx \
typing/oprint.cmx \
typing/mtype.cmx \
utils/misc.cmx \
parsing/longident.cmx \
@ -1438,7 +1464,6 @@ typing/typemod.cmo : \
typing/typecore.cmi \
typing/typeclass.cmi \
typing/subst.cmi \
typing/stypes.cmi \
typing/printtyp.cmi \
typing/path.cmi \
parsing/parsetree.cmi \
@ -1454,6 +1479,7 @@ typing/typemod.cmo : \
typing/ctype.cmi \
utils/config.cmi \
file_formats/cmt_format.cmi \
typing/cmt2annot.cmo \
file_formats/cmi_format.cmi \
utils/clflags.cmi \
parsing/builtin_attributes.cmi \
@ -1471,7 +1497,6 @@ typing/typemod.cmx : \
typing/typecore.cmx \
typing/typeclass.cmx \
typing/subst.cmx \
typing/stypes.cmx \
typing/printtyp.cmx \
typing/path.cmx \
parsing/parsetree.cmi \
@ -1487,6 +1512,7 @@ typing/typemod.cmx : \
typing/ctype.cmx \
utils/config.cmx \
file_formats/cmt_format.cmx \
typing/cmt2annot.cmx \
file_formats/cmi_format.cmx \
utils/clflags.cmx \
parsing/builtin_attributes.cmx \
@ -1547,6 +1573,7 @@ typing/types.cmo : \
utils/misc.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/identifiable.cmi \
typing/ident.cmi \
utils/config.cmi \
parsing/asttypes.cmi \
@ -1559,6 +1586,7 @@ typing/types.cmx : \
utils/misc.cmx \
parsing/longident.cmx \
parsing/location.cmx \
utils/identifiable.cmx \
typing/ident.cmx \
utils/config.cmx \
parsing/asttypes.cmi \
@ -1570,6 +1598,7 @@ typing/types.cmi : \
parsing/parsetree.cmi \
parsing/longident.cmi \
parsing/location.cmi \
utils/identifiable.cmi \
typing/ident.cmi \
parsing/asttypes.cmi
typing/typetexp.cmo : \
@ -3302,25 +3331,21 @@ lambda/runtimedef.cmx : \
lambda/runtimedef.cmi :
lambda/simplif.cmo : \
utils/warnings.cmi \
typing/stypes.cmi \
typing/primitive.cmi \
parsing/location.cmi \
lambda/lambda.cmi \
typing/ident.cmi \
utils/clflags.cmi \
parsing/asttypes.cmi \
typing/annot.cmi \
lambda/simplif.cmi
lambda/simplif.cmx : \
utils/warnings.cmx \
typing/stypes.cmx \
typing/primitive.cmx \
parsing/location.cmx \
lambda/lambda.cmx \
typing/ident.cmx \
utils/clflags.cmx \
parsing/asttypes.cmi \
typing/annot.cmi \
lambda/simplif.cmi
lambda/simplif.cmi : \
parsing/location.cmi \
@ -5708,7 +5733,6 @@ driver/compile_common.cmo : \
typing/typemod.cmi \
typing/typedtree.cmi \
typing/typecore.cmi \
typing/stypes.cmi \
utils/profile.cmi \
typing/printtyped.cmi \
typing/printtyp.cmi \
@ -5729,7 +5753,6 @@ driver/compile_common.cmx : \
typing/typemod.cmx \
typing/typedtree.cmx \
typing/typecore.cmx \
typing/stypes.cmx \
utils/profile.cmx \
typing/printtyped.cmx \
typing/printtyp.cmx \
@ -5751,6 +5774,7 @@ driver/compile_common.cmi : \
typing/env.cmi
driver/compmisc.cmo : \
utils/warnings.cmi \
typing/types.cmi \
typing/typemod.cmi \
utils/misc.cmi \
parsing/location.cmi \
@ -5763,6 +5787,7 @@ driver/compmisc.cmo : \
driver/compmisc.cmi
driver/compmisc.cmx : \
utils/warnings.cmx \
typing/types.cmx \
typing/typemod.cmx \
utils/misc.cmx \
parsing/location.cmx \

View File

@ -178,6 +178,10 @@ Working version
from intermediate-representation dumps (-dfoo).
(Gabriel Scherer, review by Vincent Laviron)
- #2141: generate .annot files from cmt data; deprecate -annot.
(Nicolás Ojeda Bär, review by Alain Frisch, Gabriel Scherer and Damien
Doligez)
### Internal/compiler-libs changes:
- #463: a new Misc.Magic_number module for user-friendly parsing

View File

@ -54,10 +54,10 @@ TYPING=typing/ident.cmo typing/path.cmo \
typing/typedtree.cmo typing/printtyped.cmo typing/ctype.cmo \
typing/printtyp.cmo typing/includeclass.cmo \
typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
typing/tast_iterator.cmo typing/tast_mapper.cmo \
file_formats/cmt_format.cmo typing/untypeast.cmo \
typing/tast_iterator.cmo typing/tast_mapper.cmo typing/stypes.cmo \
file_formats/cmt_format.cmo typing/cmt2annot.cmo typing/untypeast.cmo \
typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \
typing/parmatch.cmo typing/stypes.cmo \
typing/parmatch.cmo \
typing/typedecl_properties.cmo typing/typedecl_variance.cmo \
typing/typedecl_unboxed.cmo typing/typedecl_immediacy.cmo \
typing/typedecl_separability.cmo \

View File

@ -101,15 +101,12 @@ let parse_impl i =
|> print_if i.ppf_dump Clflags.dump_source Pprintast.structure
let typecheck_impl i parsetree =
let always () = Stypes.dump (Some (annot i)) in
Misc.try_finally ~always (fun () ->
parsetree
|> Profile.(record typing)
(Typemod.type_implementation
i.source_file i.output_prefix i.module_name i.env)
|> print_if i.ppf_dump Clflags.dump_typedtree
Printtyped.implementation_with_coercion
)
parsetree
|> Profile.(record typing)
(Typemod.type_implementation
i.source_file i.output_prefix i.module_name i.env)
|> print_if i.ppf_dump Clflags.dump_typedtree
Printtyped.implementation_with_coercion
let implementation info ~backend =
Profile.record_call info.source_file @@ fun () ->

View File

@ -33,7 +33,7 @@ let mk_absname f =
;;
let mk_annot f =
"-annot", Arg.Unit f, " Save information in <filename>.annot"
"-annot", Arg.Unit f, " (deprecated) Save information in <filename>.annot"
;;
let mk_binannot f =

View File

@ -600,12 +600,6 @@ let is_tail_native_heuristic : (int -> bool) ref =
ref (fun _ -> true)
let rec emit_tail_infos is_tail lambda =
let call_kind args =
if is_tail
&& ((not !Clflags.native_code)
|| (!is_tail_native_heuristic (List.length args)))
then Annot.Tail
else Annot.Stack in
match lambda with
| Lvar _ -> ()
| Lconst _ -> ()
@ -615,9 +609,7 @@ let rec emit_tail_infos is_tail lambda =
&& Warnings.is_active Warnings.Expect_tailcall
then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall;
emit_tail_infos false ap.ap_func;
list_emit_tail_infos false ap.ap_args;
if !Clflags.annotations then
Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args))
list_emit_tail_infos false ap.ap_args
| Lfunction {body = lam} ->
emit_tail_infos true lam
| Llet (_str, _k, _, lam, body) ->
@ -671,12 +663,10 @@ let rec emit_tail_infos is_tail lambda =
emit_tail_infos false body
| Lassign (_, lam) ->
emit_tail_infos false lam
| Lsend (_, meth, obj, args, loc) ->
| Lsend (_, meth, obj, args, _loc) ->
emit_tail_infos false meth;
emit_tail_infos false obj;
list_emit_tail_infos false args;
if !Clflags.annotations then
Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)));
list_emit_tail_infos false args
| Levent (lam, _) ->
emit_tail_infos is_tail lam
| Lifused (_, lam) ->

View File

@ -204,17 +204,9 @@ excluding the filename.
Show absolute filenames in error messages.
.TP
.B \-annot
Dump detailed information about the compilation (types, bindings,
tail-calls, etc). The information for file
.IR src .ml
is put into file
.IR src .annot.
In case of a type error, dump all the information inferred by the
type-checker before the error. The
.IR src .annot
file can be used with the emacs commands given in
.B emacs/caml\-types.el
to display types and other annotations interactively.
Deprecated since 4.11. Please use
.BR \-bin-annot
instead.
.TP
.B \-bin\-annot
Dump detailed information about the compilation (types, bindings,

View File

@ -167,17 +167,9 @@ excluding the filename.
Show absolute filenames in error messages.
.TP
.B \-annot
Dump detailed information about the compilation (types, bindings,
tail-calls, etc). The information for file
.IR src .ml
is put into file
.IR src .annot.
In case of a type error, dump all the information inferred by the
type-checker before the error. The
.IR src .annot
file can be used with the emacs commands given in
.B emacs/caml\-types.el
to display types and other annotations interactively.
Deprecated since OCaml 4.11. Please use
.BR \-bin-annot
instead.
.TP
.B \-bin\-annot
Dump detailed information about the compilation (types, bindings,

View File

@ -61,13 +61,7 @@ command line, unless the "-noautolink" option is given.
Force error messages to show absolute paths for file names.
\notop{\item["-annot"]
Dump detailed information about the compilation (types, bindings,
tail-calls, etc). The information for file \var{src}".ml"
is put into file \var{src}".annot". In case of a type error, dump
all the information inferred by the type-checker before the error.
The \var{src}".annot" file can be used with the emacs commands given in
"emacs/caml-types.el" to display types and other annotations
interactively.
Deprecated since OCaml 4.11. Please use "-bin-annot" instead.
}%notop
\item["-args" \var{filename}]

View File

@ -28,40 +28,6 @@ cmpbyt.cmo : \
../bytecomp/bytesections.cmi
cmpbyt.cmx : \
../bytecomp/bytesections.cmx
cmt2annot.cmo : \
../typing/untypeast.cmi \
../typing/types.cmi \
../typing/typedtree.cmi \
../typing/tast_iterator.cmi \
../typing/stypes.cmi \
../parsing/pprintast.cmi \
../typing/path.cmi \
../typing/oprint.cmi \
../parsing/location.cmi \
../utils/load_path.cmi \
../typing/ident.cmi \
../typing/envaux.cmi \
../typing/env.cmi \
../file_formats/cmt_format.cmi \
../parsing/asttypes.cmi \
../typing/annot.cmi
cmt2annot.cmx : \
../typing/untypeast.cmx \
../typing/types.cmx \
../typing/typedtree.cmx \
../typing/tast_iterator.cmx \
../typing/stypes.cmx \
../parsing/pprintast.cmx \
../typing/path.cmx \
../typing/oprint.cmx \
../parsing/location.cmx \
../utils/load_path.cmx \
../typing/ident.cmx \
../typing/envaux.cmx \
../typing/env.cmx \
../file_formats/cmt_format.cmx \
../parsing/asttypes.cmi \
../typing/annot.cmi
cvt_emit.cmo :
cvt_emit.cmx :
dumpobj.cmo : \
@ -202,17 +168,29 @@ profiling.cmx : \
profiling.cmi
profiling.cmi :
read_cmt.cmo : \
../typing/untypeast.cmi \
../typing/stypes.cmi \
../parsing/pprintast.cmi \
../parsing/location.cmi \
../utils/load_path.cmi \
../typing/envaux.cmi \
../driver/compmisc.cmi \
../file_formats/cmt_format.cmi \
cmt2annot.cmo \
../utils/clflags.cmi
../typing/cmt2annot.cmo \
../utils/clflags.cmi \
../typing/annot.cmi
read_cmt.cmx : \
../typing/untypeast.cmx \
../typing/stypes.cmx \
../parsing/pprintast.cmx \
../parsing/location.cmx \
../utils/load_path.cmx \
../typing/envaux.cmx \
../driver/compmisc.cmx \
../file_formats/cmt_format.cmx \
cmt2annot.cmx \
../utils/clflags.cmx
../typing/cmt2annot.cmx \
../utils/clflags.cmx \
../typing/annot.cmi
stripdebug.cmo : \
../utils/misc.cmi \
../bytecomp/bytesections.cmi

View File

@ -228,7 +228,7 @@ READ_CMT= \
$(ROOTDIR)/compilerlibs/ocamlcommon.cma \
$(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \
\
cmt2annot.cmo read_cmt.cmo
read_cmt.cmo
# Reading cmt files
$(call byte_and_opt,read_cmt,$(READ_CMT),)

View File

@ -97,6 +97,64 @@ let print_info cmt =
end;
()
let generate_ml target_filename filename cmt =
let (printer, ext) =
match cmt.Cmt_format.cmt_annots with
| Cmt_format.Implementation typedtree ->
(fun ppf -> Pprintast.structure ppf
(Untypeast.untype_structure typedtree)),
".ml"
| Cmt_format.Interface typedtree ->
(fun ppf -> Pprintast.signature ppf
(Untypeast.untype_signature typedtree)),
".mli"
| _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
in
let target_filename = match target_filename with
None -> Some (filename ^ ext)
| Some "-" -> None
| Some _ -> target_filename
in
let oc = match target_filename with
None -> None
| Some filename -> Some (open_out filename) in
let ppf = match oc with
None -> Format.std_formatter
| Some oc -> Format.formatter_of_out_channel oc in
printer ppf;
Format.pp_print_flush ppf ();
match oc with
None -> flush stdout
| Some oc -> close_out oc
(* Save cmt information as faked annotations, attached to
Location.none, on top of the .annot file. Only when -save-cmt-info is
provided to ocaml_cmt.
*)
let record_cmt_info cmt =
let location_none = {
Location.none with Location.loc_ghost = false }
in
let location_file file = {
Location.none with
Location.loc_start = {
Location.none.Location.loc_start with
Lexing.pos_fname = file }}
in
let record_info name value =
let ident = Printf.sprintf ".%s" name in
Stypes.record (Stypes.An_ident (location_none, ident,
Annot.Idef (location_file value)))
in
let open Cmt_format in
(* record in reverse order to get them in correct order... *)
List.iter (fun dir -> record_info "include" dir) (List.rev cmt.cmt_loadpath);
record_info "chdir" cmt.cmt_builddir;
(match cmt.cmt_sourcefile with
None -> () | Some file -> record_info "source" file)
let main () =
Clflags.annotations := true;
@ -105,12 +163,25 @@ let main () =
Filename.check_suffix filename ".cmt" ||
Filename.check_suffix filename ".cmti"
then begin
let open Cmt_format in
Compmisc.init_path ();
let cmt = Cmt_format.read_cmt filename in
if !gen_annot then
Cmt2annot.gen_annot ~save_cmt_info: !save_cmt_info
!target_filename filename cmt;
if !gen_ml then Cmt2annot.gen_ml !target_filename filename cmt;
let cmt = read_cmt filename in
if !gen_annot then begin
if !save_cmt_info then record_cmt_info cmt;
let target_filename =
match !target_filename with
| None -> Some (filename ^ ".annot")
| Some "-" -> None
| Some _ as x -> x
in
Envaux.reset_cache ();
List.iter Load_path.add_dir (List.rev cmt.cmt_loadpath);
Cmt2annot.gen_annot target_filename
~sourcefile:cmt.cmt_sourcefile
~use_summaries:cmt.cmt_use_summaries
cmt.cmt_annots
end;
if !gen_ml then generate_ml !target_filename filename cmt;
if !print_info_arg || not (!gen_ml || !gen_annot) then print_info cmt;
end else begin
Printf.fprintf stderr

View File

@ -79,9 +79,6 @@ consensus for all of them.
- Track "string literals" in the type-checker, which often act as
magic "internal" names which should be avoided.
- Get rid of -annot.
(see Nicolas' PR)
- Consider storing warning settings (+other context) as part of `Env.t`?
- Parse attributes understood (e.g. the deprecated attribute) by the

View File

@ -76,11 +76,7 @@ let rec iterator ~scope rebuild_env =
let full_name = Path.name ~paren:Oprint.parenthesized_ident path in
let env =
if rebuild_env then
try
Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
with Envaux.Error err ->
Format.eprintf "%a@." Envaux.report_error err;
exit 2
Env.env_of_only_summary Envaux.env_from_summary exp.exp_env
else
exp.exp_env
in
@ -169,89 +165,20 @@ let binary_part iter x =
| Partial_signature_item x -> iter.signature_item iter x
| Partial_module_type x -> iter.module_type iter x
(* Save cmt information as faked annotations, attached to
Location.none, on top of the .annot file. Only when -save-cmt-info is
provided to ocaml_cmt.
*)
let record_cmt_info cmt =
let location_none = {
Location.none with Location.loc_ghost = false }
in
let location_file file = {
Location.none with
Location.loc_start = {
Location.none.Location.loc_start with
Lexing.pos_fname = file }}
in
let record_info name value =
let ident = Printf.sprintf ".%s" name in
Stypes.record (Stypes.An_ident (location_none, ident,
Annot.Idef (location_file value)))
in
let gen_annot target_filename ~sourcefile ~use_summaries annots =
let open Cmt_format in
(* record in reverse order to get them in correct order... *)
List.iter (fun dir -> record_info "include" dir) (List.rev cmt.cmt_loadpath);
record_info "chdir" cmt.cmt_builddir;
(match cmt.cmt_sourcefile with
None -> () | Some file -> record_info "source" file)
let gen_annot ?(save_cmt_info=false) target_filename filename cmt =
let open Cmt_format in
Envaux.reset_cache ();
List.iter Load_path.add_dir (List.rev cmt.cmt_loadpath);
let target_filename =
match target_filename with
| None -> Some (filename ^ ".annot")
| Some "-" -> None
| Some _ -> target_filename
let scope =
match sourcefile with
| None -> Location.none
| Some s -> Location.in_file s
in
if save_cmt_info then record_cmt_info cmt;
let iter = iterator ~scope:Location.none cmt.cmt_use_summaries in
match cmt.cmt_annots with
let iter = iterator ~scope use_summaries in
match annots with
| Implementation typedtree ->
iter.structure iter typedtree;
Stypes.dump target_filename
| Interface _ ->
Printf.eprintf "Cannot generate annotations for interface file\n%!";
exit 2
| Partial_implementation parts ->
Array.iter (binary_part iter) parts;
Stypes.dump target_filename
| Packed _ ->
Printf.fprintf stderr "Packed files not yet supported\n%!";
Stypes.dump target_filename
| Partial_interface _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
let gen_ml target_filename filename cmt =
let (printer, ext) =
match cmt.Cmt_format.cmt_annots with
| Cmt_format.Implementation typedtree ->
(fun ppf -> Pprintast.structure ppf
(Untypeast.untype_structure typedtree)),
".ml"
| Cmt_format.Interface typedtree ->
(fun ppf -> Pprintast.signature ppf
(Untypeast.untype_signature typedtree)),
".mli"
| _ ->
Printf.fprintf stderr "File was generated with an error\n%!";
exit 2
in
let target_filename = match target_filename with
None -> Some (filename ^ ext)
| Some "-" -> None
| Some _ -> target_filename
in
let oc = match target_filename with
None -> None
| Some filename -> Some (open_out filename) in
let ppf = match oc with
None -> Format.std_formatter
| Some oc -> Format.formatter_of_out_channel oc in
printer ppf;
Format.pp_print_flush ppf ();
match oc with
None -> flush stdout
| Some oc -> close_out oc
| Interface _ | Packed _ | Partial_interface _ ->
()

View File

@ -106,3 +106,10 @@ open Format
let report_error ppf = function
| Module_not_found p ->
fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
let () =
Location.register_error_of_exn
(function
| Error err -> Some (Location.error_of_printer_file report_error err)
| _ -> None
)

View File

@ -247,7 +247,6 @@ let rec limited_generalize rv =
(* Record a class type *)
let rc node =
Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node);
Stypes.record (Stypes.Ti_class node); (* moved to genannot *)
node

View File

@ -172,17 +172,14 @@ let type_object =
*)
let re node =
Cmt_format.add_saved_type (Cmt_format.Partial_expression node);
Stypes.record (Stypes.Ti_expr node);
node
;;
let rp node =
Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Value, node));
Stypes.record (Stypes.Ti_pat (Value, node));
node
;;
let rcp node =
Cmt_format.add_saved_type (Cmt_format.Partial_pattern (Computation, node));
Stypes.record (Stypes.Ti_pat (Computation, node));
node
;;
@ -417,11 +414,6 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
if not !allow_modules then
raise (Error (loc, Env.empty, Modules_not_allowed));
module_variables := (name, loc) :: !module_variables
end else begin
(* moved to genannot *)
Option.iter
(fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s)))
!pattern_scope
end;
id
@ -3647,15 +3639,6 @@ and type_expect_
and type_ident env ?(recarg=Rejected) lid =
let (path, desc) = Env.lookup_value ~loc:lid.loc lid.txt env in
if !Clflags.annotations then begin
let dloc = desc.Types.val_loc in
let annot =
if dloc.Location.loc_ghost then Annot.Iref_external
else Annot.Iref_internal dloc
in
let name = Path.name ~paren:Oprint.parenthesized_ident path in
Stypes.record (Stypes.An_ident (lid.loc, name, annot))
end;
let is_recarg =
match (repr desc.val_type).desc with
| Tconstr(p, _, _) -> Path.is_constructor_typath p

View File

@ -214,11 +214,6 @@ let type_open_descr ?used_slot ?toplevel env sod =
in
(od, newenv)
(* Record a module type *)
let rm node =
Stypes.record (Stypes.Ti_mod node);
node
(* Forward declaration, to be filled in by type_module_type_of *)
let type_module_type_of_fwd :
(Env.t -> Parsetree.module_expr ->
@ -1906,16 +1901,16 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
else mty
in
{ md with mod_type = mty }
in rm md
in md
| Pmod_structure sstr ->
let (str, sg, names, _finalenv) =
type_structure funct_body anchor env sstr smod.pmod_loc in
let md =
rm { mod_desc = Tmod_structure str;
mod_type = Mty_signature sg;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
{ mod_desc = Tmod_structure str;
mod_type = Mty_signature sg;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
in
let sg' = Signature_names.simplify _finalenv names sg in
if List.length sg' = List.length sg then md else
@ -1948,11 +1943,11 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, true
in
let body = type_module sttn funct_body None newenv sbody in
rm { mod_desc = Tmod_functor(t_arg, body);
mod_type = Mty_functor(ty_arg, body.mod_type);
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
{ mod_desc = Tmod_functor(t_arg, body);
mod_type = Mty_functor(ty_arg, body.mod_type);
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Pmod_apply(sfunct, sarg) ->
let arg = type_module true funct_body None env sarg in
let path = path_of_module arg in
@ -1964,11 +1959,11 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
raise (Error (sfunct.pmod_loc, env, Apply_generative));
if funct_body && Mtype.contains_type env funct.mod_type then
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
rm { mod_desc = Tmod_apply(funct, arg, Tcoerce_none);
mod_type = mty_res;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
{ mod_desc = Tmod_apply(funct, arg, Tcoerce_none);
mod_type = mty_res;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Mty_functor (Named (param, mty_param), mty_res) as mty_functor ->
let coercion =
try
@ -2017,11 +2012,11 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
in
check_well_formed_module env smod.pmod_loc
"the signature of this functor application" mty_appl;
rm { mod_desc = Tmod_apply(funct, arg, coercion);
mod_type = mty_appl;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
{ mod_desc = Tmod_apply(funct, arg, coercion);
mod_type = mty_appl;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Mty_alias path ->
raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path))
| _ ->
@ -2033,10 +2028,10 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
let md =
wrap_constraint env true arg mty.mty_type (Tmodtype_explicit mty)
in
rm { md with
mod_loc = smod.pmod_loc;
mod_attributes = smod.pmod_attributes;
}
{ md with
mod_loc = smod.pmod_loc;
mod_attributes = smod.pmod_attributes;
}
| Pmod_unpack sexp ->
if !Clflags.principal then Ctype.begin_def ();
@ -2065,11 +2060,11 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
in
if funct_body && Mtype.contains_type env mty then
raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
rm { mod_desc = Tmod_unpack(exp, mty);
mod_type = mty;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
{ mod_desc = Tmod_unpack(exp, mty);
mod_type = mty;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| Pmod_extension ext ->
raise (Error_forward (Builtin_attributes.error_of_extension ext))
@ -2439,9 +2434,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
let (str_rem, sig_rem, final_env) = type_struct new_env srem in
(str :: str_rem, sg @ sig_rem, final_env)
in
if !Clflags.annotations then
(* moved to genannot *)
List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
let previous_saved_types = Cmt_format.get_saved_types () in
let run () =
let (items, sg, final_env) = type_struct env sstr in
@ -2486,11 +2478,11 @@ let type_module_type_of env smod =
match smod.pmod_desc with
| Pmod_ident lid -> (* turn off strengthening in this case *)
let path, md = Env.lookup_module ~loc:smod.pmod_loc lid.txt env in
rm { mod_desc = Tmod_ident (path, lid);
mod_type = md.md_type;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
{ mod_desc = Tmod_ident (path, lid);
mod_type = md.md_type;
mod_env = env;
mod_attributes = smod.pmod_attributes;
mod_loc = smod.pmod_loc }
| _ -> type_module env smod
in
let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
@ -2624,6 +2616,10 @@ let () =
(* Typecheck an implementation file *)
let gen_annot outputprefix sourcefile annots =
Cmt2annot.gen_annot (Some (outputprefix ^ ".annot"))
~sourcefile:(Some sourcefile) ~use_summaries:false annots
let type_implementation sourcefile outputprefix modulename initial_env ast =
Cmt_format.clear ();
Misc.try_finally (fun () ->
@ -2640,6 +2636,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
(fun () -> fprintf std_formatter "%a@."
(Printtyp.printed_signature sourcefile) simple_sg
);
gen_annot outputprefix sourcefile (Cmt_format.Implementation str);
(str, Tcoerce_none) (* result is ignored by Compile.implementation *)
end else begin
let sourceintf =
@ -2660,8 +2657,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
(* It is important to run these checks after the inclusion test above,
so that value declarations which are not used internally but
exported are not reported as being unused. *)
let annots = Cmt_format.Implementation str in
Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
(Cmt_format.Implementation str) (Some sourcefile) initial_env None;
annots (Some sourcefile) initial_env None;
gen_annot outputprefix sourcefile annots;
(str, coercion)
end else begin
let coercion =
@ -2681,19 +2680,24 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
Env.save_signature ~alerts
simple_sg modulename (outputprefix ^ ".cmi")
in
let annots = Cmt_format.Implementation str in
Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
(Cmt_format.Implementation str)
(Some sourcefile) initial_env (Some cmi);
annots (Some sourcefile) initial_env (Some cmi);
gen_annot outputprefix sourcefile annots
end;
(str, coercion)
end
end
)
~exceptionally:(fun () ->
let annots =
Cmt_format.Partial_implementation
(Array.of_list (Cmt_format.get_saved_types ()))
in
Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
(Cmt_format.Partial_implementation
(Array.of_list (Cmt_format.get_saved_types ())))
(Some sourcefile) initial_env None)
annots (Some sourcefile) initial_env None;
gen_annot outputprefix sourcefile annots
)
let save_signature modname tsg outputprefix source_file initial_env cmi =
Cmt_format.save_cmt (outputprefix ^ ".cmti") modname