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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
(***********************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed *)
(* under the terms of the Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
original compilation units as sub-modules. *)
open Misc
open Cmx_format
type error =
Illegal_renaming of string * string
| Forward_reference of string * string
| Wrong_for_pack of string * string
| Linking_error
| Assembler_error of string
| File_not_found of string
exception Error of error
(* Read the unit information from a .cmx file. *)
type pack_member_kind = PM_intf | PM_impl of unit_infos
type pack_member =
{ pm_file: string;
pm_name: string;
pm_kind: pack_member_kind }
let read_member_info pack_path file =
let name =
String.capitalize(Filename.basename(chop_extensions file)) in
let kind =
if Filename.check_suffix file ".cmx" then begin
let (info, crc) = Compilenv.read_unit_info file in
if info.ui_name <> name
then raise(Error(Illegal_renaming(file, info.ui_name)));
if info.ui_symbol <>
(Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name
then raise(Error(Wrong_for_pack(file, pack_path)));
Asmlink.check_consistency file info crc;
Compilenv.cache_unit_info info;
PM_impl info
end else
PM_intf in
{ pm_file = file; pm_name = name; pm_kind = kind }
(* Check absence of forward references *)
let check_units members =
let rec check forbidden = function
[] -> ()
| mb :: tl ->
begin match mb.pm_kind with
| PM_intf -> ()
| PM_impl infos ->
List.iter
(fun (unit, _) ->
if List.mem unit forbidden
then raise(Error(Forward_reference(mb.pm_file, unit))))
infos.ui_imports_cmx
end;
check (list_remove mb.pm_name forbidden) tl in
check (List.map (fun mb -> mb.pm_name) members) members
(* Make the .o file for the package *)
let make_package_object ppf members targetobj targetname coercion =
let objtemp =
if !Clflags.keep_asm_file
then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj
else
(* Put the full name of the module in the temporary file name
to avoid collisions with MSVC's link /lib in case of successive
packs *)
Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
let components =
List.map
(fun m ->
match m.pm_kind with
| PM_intf -> None
| PM_impl _ -> Some(Ident.create_persistent m.pm_name))
members in
Asmgen.compile_implementation
(chop_extension_if_any objtemp) ppf
(Translmod.transl_store_package
components (Ident.create_persistent targetname) coercion);
let objfiles =
List.map
(fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj)
(List.filter (fun m -> m.pm_kind <> PM_intf) members) in
let ok =
Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) ""
in
remove_file objtemp;
if not ok then raise(Error Linking_error)
(* Make the .cmx file for the package *)
let build_package_cmx members cmxfile =
let unit_names =
List.map (fun m -> m.pm_name) members in
let filter lst =
List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
let union lst =
List.fold_left
(List.fold_left
(fun accu n -> if List.mem n accu then accu else n :: accu))
[] lst in
let units =
List.fold_right
(fun m accu ->
match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
members [] in
let ui = Compilenv.current_unit_infos() in
let pkg_infos =
{ ui_name = ui.ui_name;
ui_symbol = ui.ui_symbol;
ui_defines =
List.flatten (List.map (fun info -> info.ui_defines) units) @
[ui.ui_symbol];
ui_imports_cmi =
(ui.ui_name, Env.crc_of_unit ui.ui_name) ::
filter(Asmlink.extract_crc_interfaces());
ui_imports_cmx =
filter(Asmlink.extract_crc_implementations());
ui_approx = ui.ui_approx;
ui_curry_fun =
union(List.map (fun info -> info.ui_curry_fun) units);
ui_apply_fun =
union(List.map (fun info -> info.ui_apply_fun) units);
ui_send_fun =
union(List.map (fun info -> info.ui_send_fun) units);
ui_force_link =
List.exists (fun info -> info.ui_force_link) units;
} in
Compilenv.write_unit_info pkg_infos cmxfile
(* Make the .cmx and the .o for the package *)
let package_object_files ppf files targetcmx
targetobj targetname coercion =
let pack_path =
match !Clflags.for_package with
| None -> targetname
| Some p -> p ^ "." ^ targetname in
let members = map_left_right (read_member_info pack_path) files in
check_units members;
make_package_object ppf members targetobj targetname coercion;
build_package_cmx members targetcmx
(* The entry point *)
let package_files ppf files targetcmx =
let files =
List.map
(fun f ->
try find_in_path !Config.load_path f
with Not_found -> raise(Error(File_not_found f)))
files in
let prefix = chop_extensions targetcmx in
let targetcmi = prefix ^ ".cmi" in
let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in
let targetname = String.capitalize(Filename.basename prefix) in
(* Set the name of the current "input" *)
Location.input_name := targetcmx;
(* Set the name of the current compunit *)
Compilenv.reset ?packname:!Clflags.for_package targetname;
try
let coercion = Typemod.package_units files targetcmi targetname in
package_object_files ppf files targetcmx targetobj targetname coercion
with x ->
remove_file targetcmx; remove_file targetobj;
raise x
(* Error report *)
open Format
let report_error ppf = function
Illegal_renaming(file, id) ->
fprintf ppf "Wrong file naming: %a@ contains the code for@ %s"
Location.print_filename file id
| Forward_reference(file, ident) ->
fprintf ppf "Forward reference to %s in file %a" ident
Location.print_filename file
| Wrong_for_pack(file, path) ->
fprintf ppf "File %a@ was not compiled with the `-for-pack %s' option"
Location.print_filename file path
| File_not_found file ->
fprintf ppf "File %s not found" file
| Assembler_error file ->
fprintf ppf "Error while assembling %s" file
| Linking_error ->
fprintf ppf "Error during partial linking"
|
