diff options
-rw-r--r-- | .depend | 53 | ||||
-rw-r--r-- | Changes | 4 | ||||
-rw-r--r-- | compilerlibs/Makefile.compilerlibs | 6 | ||||
-rw-r--r-- | driver/compile_common.ml | 15 | ||||
-rw-r--r-- | driver/main_args.ml | 2 | ||||
-rw-r--r-- | lambda/simplif.ml | 16 | ||||
-rw-r--r-- | man/ocamlc.m | 14 | ||||
-rw-r--r-- | man/ocamlopt.m | 14 | ||||
-rw-r--r-- | manual/manual/cmds/unified-options.etex | 8 | ||||
-rw-r--r-- | tools/.depend | 54 | ||||
-rw-r--r-- | tools/Makefile | 2 | ||||
-rw-r--r-- | tools/read_cmt.ml | 81 | ||||
-rw-r--r-- | typing/TODO.md | 3 | ||||
-rw-r--r-- | typing/cmt2annot.ml (renamed from tools/cmt2annot.ml) | 93 | ||||
-rw-r--r-- | typing/envaux.ml | 7 | ||||
-rw-r--r-- | typing/typeclass.ml | 1 | ||||
-rw-r--r-- | typing/typecore.ml | 17 | ||||
-rw-r--r-- | typing/typemod.ml | 102 |
18 files changed, 226 insertions, 266 deletions
@@ -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 \ @@ -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 diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs index 5ce1945b8d..4bcd179c1e 100644 --- a/compilerlibs/Makefile.compilerlibs +++ b/compilerlibs/Makefile.compilerlibs @@ -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 \ diff --git a/driver/compile_common.ml b/driver/compile_common.ml index 601cfa831c..fb15396e3b 100644 --- a/driver/compile_common.ml +++ b/driver/compile_common.ml @@ -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 () -> diff --git a/driver/main_args.ml b/driver/main_args.ml index 5c8c3aef9c..5c28ded5c2 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -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 = diff --git a/lambda/simplif.ml b/lambda/simplif.ml index 8cc7fe5e88..465d299364 100644 --- a/lambda/simplif.ml +++ b/lambda/simplif.ml @@ -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) -> diff --git a/man/ocamlc.m b/man/ocamlc.m index 8663685979..456c0f6604 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -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, diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 5c1bc40e2c..a857c2c1fa 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -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, diff --git a/manual/manual/cmds/unified-options.etex b/manual/manual/cmds/unified-options.etex index 183d00a67c..fe63611283 100644 --- a/manual/manual/cmds/unified-options.etex +++ b/manual/manual/cmds/unified-options.etex @@ -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}] diff --git a/tools/.depend b/tools/.depend index a4d18f4b17..109cb1f3f1 100644 --- a/tools/.depend +++ b/tools/.depend @@ -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 diff --git a/tools/Makefile b/tools/Makefile index 18aead9359..8bd51bfd8f 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -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),) diff --git a/tools/read_cmt.ml b/tools/read_cmt.ml index 0e3cfbc267..ae6b97fdc3 100644 --- a/tools/read_cmt.ml +++ b/tools/read_cmt.ml @@ -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 diff --git a/typing/TODO.md b/typing/TODO.md index ebd0f99907..c115116117 100644 --- a/typing/TODO.md +++ b/typing/TODO.md @@ -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 diff --git a/tools/cmt2annot.ml b/typing/cmt2annot.ml index 3455fa0caa..40ee752e80 100644 --- a/tools/cmt2annot.ml +++ b/typing/cmt2annot.ml @@ -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 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 gen_annot target_filename ~sourcefile ~use_summaries annots = 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 _ -> + () diff --git a/typing/envaux.ml b/typing/envaux.ml index 2d3a02bc14..8f77435aeb 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -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 + ) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index ca6463e88e..a5436e5dfe 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -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 diff --git a/typing/typecore.ml b/typing/typecore.ml index 37c86aeefb..70a2880fd8 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -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 diff --git a/typing/typemod.ml b/typing/typemod.ml index 2f5948e632..5cf03dc761 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -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 |