/
libcompile.ml
156 lines (132 loc) · 5.19 KB
/
libcompile.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Compenv
type info = {
sourcefile : string ;
modulename : string ;
outputprefix : string ;
env : Env.t ;
ppf : Format.formatter ;
tool_name : string ;
source_provenance : Timings.source_provenance ;
}
let cmx i = i.outputprefix ^ ".cmx"
let obj i = i.outputprefix ^ Config.ext_obj
let print_if i flag printer arg =
if !flag then Format.fprintf i.ppf "%a@." printer arg;
arg
let init ppf ~init_path ~tool_name ~sourcefile ~outputprefix =
let source_provenance = Timings.File sourcefile in
Compmisc.init_path init_path;
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
let env = Compmisc.initial_env() in
{ modulename ; outputprefix ; env ; sourcefile ; ppf ;
tool_name ; source_provenance ;
}
(** Compile a .mli file *)
let parse_intf i =
Pparse.parse_interface ~tool_name:i.tool_name i.ppf i.sourcefile
|> print_if i Clflags.dump_parsetree Printast.interface
|> print_if i Clflags.dump_source Pprintast.signature
let typecheck_intf info ast =
let tsg =
ast
|> Typemod.type_interface info.env
|> print_if info Clflags.dump_typedtree Printtyped.interface
in
let sg = tsg.Typedtree.sig_type in
if !Clflags.print_types then
Printtyp.wrap_printing_env info.env (fun () ->
Format.(fprintf std_formatter) "%a@."
Printtyp.signature (Typemod.simplify_signature sg));
ignore (Includemod.signatures info.env sg sg);
Typecore.force_delayed_checks ();
Warnings.check_fatal ();
tsg
let emit_signature info ast tsg =
let sg =
let deprecated = Builtin_attributes.deprecated_of_sig ast in
Env.save_signature ~deprecated tsg.Typedtree.sig_type
info.modulename (info.outputprefix ^ ".cmi")
in
Typemod.save_signature info.modulename tsg
info.outputprefix info.sourcefile info.env sg
let interface ppf ~tool_name ~sourcefile ~outputprefix =
let info = init ppf ~init_path:false ~tool_name ~sourcefile ~outputprefix in
let ast = parse_intf info in
let tsg = typecheck_intf info ast in
if not !Clflags.print_types then begin
emit_signature info ast tsg
end
(** Frontend for a .ml file *)
let parse_impl i =
Pparse.parse_implementation ~tool_name:i.tool_name i.ppf i.sourcefile
|> print_if i Clflags.dump_parsetree Printast.implementation
|> print_if i Clflags.dump_source Pprintast.structure
let typecheck_impl i parsetree =
parsetree
|> Timings.(time (Typing i.sourcefile))
(Typemod.type_implementation i.sourcefile i.outputprefix i.modulename i.env)
|> print_if i Clflags.dump_typedtree
Printtyped.implementation_with_coercion
let wrap_compilation ~frontend ~backend info =
try
let typed = frontend info in
if not !Clflags.print_types then
backend info typed
else begin
Warnings.check_fatal ();
Stypes.dump (Some (info.outputprefix ^ ".annot"));
end
with x ->
Stypes.dump (Some (info.outputprefix ^ ".annot"));
Misc.remove_file (obj info);
Misc.remove_file (cmx info);
raise x
(** C file. *)
let c_file name =
Location.input_name := name;
if Ccomp.compile_file name <> 0 then exit 2
(** Eliom files *)
let eliom_wrap ~frontend ~client ~server info =
let print ast info s =
let ppf =
Format.formatter_of_out_channel @@
open_out (info.outputprefix^s^".ml")
in
Format.fprintf ppf "%a@." Pprintast.structure ast ;
in
let backend _info (ty,_) =
let {Eliom_emit. client = c ; server = s } = Eliom_emit.untype ty in
if !Clflags.verbose then (print c info ".client" ; print s info ".server") ;
server s ;
client c ;
in
wrap_compilation ~frontend ~backend info
let eliom_init suffix ppf ~init_path ~tool_name ~sourcefile ~outputprefix =
let outputprefix = outputprefix ^ "." ^ suffix in
let sourcefile = sourcefile ^ "." ^ suffix in
init ppf ~init_path ~tool_name ~sourcefile ~outputprefix
let silent_typing i ast =
let val_dont_write_files = !Clflags.dont_write_files in
Clflags.dont_write_files := true;
let typedtree =
Timings.(time (Typing i.sourcefile))
(Typemod.type_implementation i.sourcefile i.outputprefix i.modulename i.env)
ast
in
Clflags.dont_write_files := val_dont_write_files;
typedtree