1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* Build libraries of .cmo files *)
17
18 open Misc
19 open Config
20 open Cmo_format
21
22 type error =
23 File_not_found of string
24 | Not_an_object_file of string
25
26 exception Error of error
27
28 (* Copy a compilation unit from a .cmo or .cma into the archive *)
29 let copy_compunit ic oc compunit =
30 seek_in ic compunit.cu_pos;
31 compunit.cu_pos <- pos_out oc;
32 compunit.cu_force_link <- compunit.cu_force_link || !Clflags.link_everything;
33 copy_file_chunk ic oc compunit.cu_codesize;
34 if compunit.cu_debug > 0 then begin
35 seek_in ic compunit.cu_debug;
36 compunit.cu_debug <- pos_out oc;
37 copy_file_chunk ic oc compunit.cu_debugsize
38 end
39
40 (* Add C objects and options and "custom" info from a library descriptor *)
41
42 let lib_ccobjs = ref []
43 let lib_ccopts = ref []
44 let lib_dllibs = ref []
45
46 (* See Bytelink.add_ccobjs for explanations on how options are ordered.
47 Notice that here we scan .cma files given on the command line from
48 left to right, hence options must be added after. *)
49
50 let add_ccobjs l =
51 if not !Clflags.no_auto_link then begin
52 if l.lib_custom then Clflags.custom_runtime := true;
53 lib_ccobjs := !lib_ccobjs @ l.lib_ccobjs;
54 lib_ccopts := !lib_ccopts @ l.lib_ccopts;
55 lib_dllibs := !lib_dllibs @ l.lib_dllibs
56 end
57
58 let copy_object_file oc name =
59 let file_name =
60 try
61 Load_path.find name
62 with Not_found ->
63 raise(Error(File_not_found name)) in
64 let ic = open_in_bin file_name in
65 try
66 let buffer = really_input_string ic (String.length cmo_magic_number) in
67 if buffer = cmo_magic_number then begin
68 let compunit_pos = input_binary_int ic in
69 seek_in ic compunit_pos;
70 let compunit = (input_value ic : compilation_unit) in
71 Bytelink.check_consistency file_name compunit;
72 copy_compunit ic oc compunit;
73 close_in ic;
74 [compunit]
75 end else
76 if buffer = cma_magic_number then begin
77 let toc_pos = input_binary_int ic in
78 seek_in ic toc_pos;
79 let toc = (input_value ic : library) in
80 List.iter (Bytelink.check_consistency file_name) toc.lib_units;
81 add_ccobjs toc;
82 List.iter (copy_compunit ic oc) toc.lib_units;
83 close_in ic;
84 toc.lib_units
85 end else
86 raise(Error(Not_an_object_file file_name))
87 with
88 End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name))
89 | x -> close_in ic; raise x
90
91 let create_archive file_list lib_name =
92 let outchan = open_out_bin lib_name in
93 Misc.try_finally
94 ~always:(fun () -> close_out outchan)
95 ~exceptionally:(fun () -> remove_file lib_name)
96 (fun () ->
97 output_string outchan cma_magic_number;
98 let ofs_pos_toc = pos_out outchan in
99 output_binary_int outchan 0;
100 let units =
101 List.flatten(List.map (copy_object_file outchan) file_list) in
102 let toc =
103 { lib_units = units;
104 lib_custom = !Clflags.custom_runtime;
105 lib_ccobjs = !Clflags.ccobjs @ !lib_ccobjs;
106 lib_ccopts = !Clflags.all_ccopts @ !lib_ccopts;
107 lib_dllibs = !Clflags.dllibs @ !lib_dllibs } in
108 let pos_toc = pos_out outchan in
109 Emitcode.marshal_to_channel_with_possibly_32bit_compat
110 ~filename:lib_name ~kind:"bytecode library"
111 outchan toc;
112 seek_out outchan ofs_pos_toc;
113 output_binary_int outchan pos_toc;
114 )
115
116 open Format
117
118 let report_error ppf = function
119 | File_not_found name ->
120 fprintf ppf "Cannot find file %s" name
121 | Not_an_object_file name ->
122 fprintf ppf "The file %a is not a bytecode object file"
123 Location.print_filename name
124
125 let () =
126 Location.register_error_of_exn
127 (function
128 | Error err -> Some (Location.error_of_printer_file report_error err)
129 | _ -> None
130 )
131
132 let reset () =
133 lib_ccobjs := [];
134 lib_ccopts := [];
135 lib_dllibs := []
136