1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1999 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 open Compenv
17 open Parsetree
18 module String = Misc.Stdlib.String
19
20 let ppf = Format.err_formatter
21 (* Print the dependencies *)
22
23 type file_kind = ML | MLI;;
24
25 let load_path = ref ([] : (string * string array) list)
26 let ml_synonyms = ref [".ml"]
27 let mli_synonyms = ref [".mli"]
28 let shared = ref false
29 let native_only = ref false
30 let bytecode_only = ref false
31 let raw_dependencies = ref false
32 let sort_files = ref false
33 let all_dependencies = ref false
34 let one_line = ref false
35 let files =
36 ref ([] : (string * file_kind * String.Set.t * string list) list)
37 let allow_approximation = ref false
38 let map_files = ref []
39 let module_map = ref String.Map.empty
40 let debug = ref false
41
42 module Error_occurred : sig
43 val set : unit -> unit
44 val get : unit -> bool
45 end = struct
46 (* Once set to [true], [error_occurred] should never be set to
47 [false]. *)
48 let error_occurred = ref false
49 let get () = !error_occurred
50 let set () = error_occurred := true
51 end
52
53 (* Fix path to use '/' as directory separator instead of '\'.
54 Only under Windows. *)
55
56 let fix_slash s =
57 if Sys.os_type = "Unix" then s else begin
58 String.map (function '\\' -> '/' | c -> c) s
59 end
60
61 (* Since we reinitialize load_path after reading OCAMLCOMP,
62 we must use a cache instead of calling Sys.readdir too often. *)
63 let dirs = ref String.Map.empty
64 let readdir dir =
65 try
66 String.Map.find dir !dirs
67 with Not_found ->
68 let contents =
69 try
70 Sys.readdir dir
71 with Sys_error msg ->
72 Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
73 Error_occurred.set ();
74 [||]
75 in
76 dirs := String.Map.add dir contents !dirs;
77 contents
78
79 let add_to_list li s =
80 li := s :: !li
81
82 let add_to_load_path dir =
83 try
84 let dir = Misc.expand_directory Config.standard_library dir in
85 let contents = readdir dir in
86 add_to_list load_path (dir, contents)
87 with Sys_error msg ->
88 Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
89 Error_occurred.set ()
90
91 let add_to_synonym_list synonyms suffix =
92 if (String.length suffix) > 1 && suffix.[0] = '.' then
93 add_to_list synonyms suffix
94 else begin
95 Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
96 Error_occurred.set ()
97 end
98
99 (* Find file 'name' (capitalized) in search path *)
100 let find_module_in_load_path name =
101 let names = List.map (fun ext -> name ^ ext) (!mli_synonyms @ !ml_synonyms) in
102 let unames =
103 let uname = String.uncapitalize_ascii name in
104 List.map (fun ext -> uname ^ ext) (!mli_synonyms @ !ml_synonyms)
105 in
106 let rec find_in_array a pos =
107 if pos >= Array.length a then None else begin
108 let s = a.(pos) in
109 if List.mem s names || List.mem s unames then
110 Some s
111 else
112 find_in_array a (pos + 1)
113 end in
114 let rec find_in_path = function
115 [] -> raise Not_found
116 | (dir, contents) :: rem ->
117 match find_in_array contents 0 with
118 Some truename ->
119 if dir = "." then truename else Filename.concat dir truename
120 | None -> find_in_path rem in
121 find_in_path !load_path
122
123 let find_dependency target_kind modname (byt_deps, opt_deps) =
124 try
125 let filename = find_module_in_load_path modname in
126 let basename = Filename.chop_extension filename in
127 let cmi_file = basename ^ ".cmi" in
128 let cmx_file = basename ^ ".cmx" in
129 let mli_exists =
130 List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms in
131 let ml_exists =
132 List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
133 if mli_exists then
134 let new_opt_dep =
135 if !all_dependencies then
136 match target_kind with
137 | MLI -> [ cmi_file ]
138 | ML ->
139 cmi_file :: (if ml_exists then [ cmx_file ] else [])
140 else
141 (* this is a make-specific hack that makes .cmx to be a 'proxy'
142 target that would force the dependency on .cmi via transitivity *)
143 if ml_exists
144 then [ cmx_file ]
145 else [ cmi_file ]
146 in
147 ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
148 else
149 (* "just .ml" case *)
150 let bytenames =
151 if !all_dependencies then
152 match target_kind with
153 | MLI -> [ cmi_file ]
154 | ML -> [ cmi_file ]
155 else
156 (* again, make-specific hack *)
157 [basename ^ (if !native_only then ".cmx" else ".cmo")] in
158 let optnames =
159 if !all_dependencies
160 then match target_kind with
161 | MLI -> [ cmi_file ]
162 | ML -> [ cmi_file; cmx_file ]
163 else [ cmx_file ]
164 in
165 (bytenames @ byt_deps, optnames @ opt_deps)
166 with Not_found ->
167 (byt_deps, opt_deps)
168
169 let (depends_on, escaped_eol) = (":", " \\\n ")
170
171 let print_filename s =
172 let s = if !Clflags.force_slash then fix_slash s else s in
173 if not (String.contains s ' ') then begin
174 print_string s;
175 end else begin
176 let rec count n i =
177 if i >= String.length s then n
178 else if s.[i] = ' ' then count (n+1) (i+1)
179 else count n (i+1)
180 in
181 let spaces = count 0 0 in
182 let result = Bytes.create (String.length s + spaces) in
183 let rec loop i j =
184 if i >= String.length s then ()
185 else if s.[i] = ' ' then begin
186 Bytes.set result j '\\';
187 Bytes.set result (j+1) ' ';
188 loop (i+1) (j+2);
189 end else begin
190 Bytes.set result j s.[i];
191 loop (i+1) (j+1);
192 end
193 in
194 loop 0 0;
195 print_bytes result;
196 end
197 ;;
198
199 let print_dependencies target_files deps =
200 let pos = ref 0 in
201 let print_on_same_line item =
202 if !pos <> 0 then print_string " ";
203 print_filename item;
204 pos := !pos + String.length item + 1;
205 in
206 let print_on_new_line item =
207 print_string escaped_eol;
208 print_filename item;
209 pos := String.length item + 4;
210 in
211 let print_compact item =
212 if !one_line || (!pos + 1 + String.length item <= 77)
213 then print_on_same_line item
214 else print_on_new_line item
215 in
216 let print_dep item =
217 if !one_line
218 then print_on_same_line item
219 else print_on_new_line item
220 in
221 List.iter print_compact target_files;
222 print_string " "; print_string depends_on;
223 pos := !pos + String.length depends_on + 1;
224 List.iter print_dep deps;
225 print_string "\n"
226
227 let print_raw_dependencies source_file deps =
228 print_filename source_file; print_string depends_on;
229 String.Set.iter
230 (fun dep ->
231 (* filter out "*predef*" *)
232 if (String.length dep > 0)
233 && (match dep.[0] with
234 | 'A'..'Z' | '\128'..'\255' -> true
235 | _ -> false) then
236 begin
237 print_char ' ';
238 print_string dep
239 end)
240 deps;
241 print_char '\n'
242
243
244 (* Process one file *)
245
246 let print_exception exn =
247 Location.report_exception Format.err_formatter exn
248
249 let report_err exn =
250 Error_occurred.set ();
251 print_exception exn
252
253 let tool_name = "ocamldep"
254
255 let rec lexical_approximation lexbuf =
256 (* Approximation when a file can't be parsed.
257 Heuristic:
258 - first component of any path starting with an uppercase character is a
259 dependency.
260 - always skip the token after a dot, unless dot is preceded by a
261 lower-case identifier
262 - always skip the token after a backquote
263 *)
264 try
265 let rec process after_lident lexbuf =
266 match Lexer.token lexbuf with
267 | Parser.UIDENT name ->
268 Depend.free_structure_names :=
269 String.Set.add name !Depend.free_structure_names;
270 process false lexbuf
271 | Parser.LIDENT _ -> process true lexbuf
272 | Parser.DOT when after_lident -> process false lexbuf
273 | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf
274 | Parser.EOF -> ()
275 | _ -> process false lexbuf
276 and skip_one lexbuf =
277 match Lexer.token lexbuf with
278 | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf
279 | Parser.EOF -> ()
280 | _ -> process false lexbuf
281
282 in
283 process false lexbuf
284 with Lexer.Error _ -> lexical_approximation lexbuf
285
286 let read_and_approximate inputfile =
287 Depend.free_structure_names := String.Set.empty;
288 let ic = open_in_bin inputfile in
289 try
290 seek_in ic 0;
291 Location.input_name := inputfile;
292 let lexbuf = Lexing.from_channel ic in
293 Location.init lexbuf inputfile;
294 lexical_approximation lexbuf;
295 close_in ic;
296 !Depend.free_structure_names
297 with exn ->
298 close_in ic;
299 report_err exn;
300 !Depend.free_structure_names
301
302 let read_parse_and_extract parse_function extract_function def ast_kind
303 source_file =
304 Depend.pp_deps := [];
305 Depend.free_structure_names := String.Set.empty;
306 try
307 let input_file = Pparse.preprocess source_file in
308 begin try
309 let ast = Pparse.file ~tool_name input_file parse_function ast_kind in
310 let bound_vars =
311 List.fold_left
312 (fun bv modname ->
313 Depend.open_module bv (Longident.parse modname))
314 !module_map ((* PR#7248 *) List.rev !Clflags.open_modules)
315 in
316 let r = extract_function bound_vars ast in
317 Pparse.remove_preprocessed input_file;
318 (!Depend.free_structure_names, r)
319 with x ->
320 Pparse.remove_preprocessed input_file;
321 raise x
322 end
323 with x -> begin
324 print_exception x;
325 if not !allow_approximation then begin
326 Error_occurred.set ();
327 (String.Set.empty, def)
328 end else
329 (read_and_approximate source_file, def)
330 end
331
332 let print_ml_dependencies source_file extracted_deps pp_deps =
333 let basename = Filename.chop_extension source_file in
334 let byte_targets = [ basename ^ ".cmo" ] in
335 let native_targets =
336 if !all_dependencies
337 then [ basename ^ ".cmx"; basename ^ ".o" ]
338 else [ basename ^ ".cmx" ] in
339 let shared_targets = [ basename ^ ".cmxs" ] in
340 let init_deps = if !all_dependencies then [source_file] else [] in
341 let cmi_name = basename ^ ".cmi" in
342 let init_deps, extra_targets =
343 if List.exists (fun ext -> Sys.file_exists (basename ^ ext))
344 !mli_synonyms
345 then (cmi_name :: init_deps, cmi_name :: init_deps), []
346 else (init_deps, init_deps),
347 (if !all_dependencies then [cmi_name] else [])
348 in
349 let (byt_deps, native_deps) =
350 String.Set.fold (find_dependency ML)
351 extracted_deps init_deps in
352 if not !native_only then
353 print_dependencies (byte_targets @ extra_targets) (byt_deps @ pp_deps);
354 if not !bytecode_only then
355 begin
356 print_dependencies (native_targets @ extra_targets)
357 (native_deps @ pp_deps);
358 if !shared then
359 print_dependencies (shared_targets @ extra_targets)
360 (native_deps @ pp_deps)
361 end
362
363 let print_mli_dependencies source_file extracted_deps pp_deps =
364 let basename = Filename.chop_extension source_file in
365 let (byt_deps, _opt_deps) =
366 String.Set.fold (find_dependency MLI)
367 extracted_deps ([], []) in
368 print_dependencies [basename ^ ".cmi"] (byt_deps @ pp_deps)
369
370 let print_file_dependencies (source_file, kind, extracted_deps, pp_deps) =
371 if !raw_dependencies then begin
372 print_raw_dependencies source_file extracted_deps
373 end else
374 match kind with
375 | ML -> print_ml_dependencies source_file extracted_deps pp_deps
376 | MLI -> print_mli_dependencies source_file extracted_deps pp_deps
377
378
379 let ml_file_dependencies source_file =
380 let parse_use_file_as_impl lexbuf =
381 let f x =
382 match x with
383 | Ptop_def s -> s
384 | Ptop_dir _ -> []
385 in
386 List.flatten (List.map f (Parse.use_file lexbuf))
387 in
388 let (extracted_deps, ()) =
389 read_parse_and_extract parse_use_file_as_impl Depend.add_implementation ()
390 Pparse.Structure source_file
391 in
392 files := (source_file, ML, extracted_deps, !Depend.pp_deps) :: !files
393
394 let mli_file_dependencies source_file =
395 let (extracted_deps, ()) =
396 read_parse_and_extract Parse.interface Depend.add_signature ()
397 Pparse.Signature source_file
398 in
399 files := (source_file, MLI, extracted_deps, !Depend.pp_deps) :: !files
400
401 let process_file_as process_fun def source_file =
402 Compenv.readenv ppf (Before_compile source_file);
403 load_path := [];
404 List.iter add_to_load_path (
405 (!Compenv.last_include_dirs @
406 !Clflags.include_dirs @
407 !Compenv.first_include_dirs
408 ));
409 Location.input_name := source_file;
410 try
411 if Sys.file_exists source_file then process_fun source_file else def
412 with x -> report_err x; def
413
414 let process_file source_file ~ml_file ~mli_file ~def =
415 if List.exists (Filename.check_suffix source_file) !ml_synonyms then
416 process_file_as ml_file def source_file
417 else if List.exists (Filename.check_suffix source_file) !mli_synonyms then
418 process_file_as mli_file def source_file
419 else def
420
421 let file_dependencies source_file =
422 process_file source_file ~def:()
423 ~ml_file:ml_file_dependencies
424 ~mli_file:mli_file_dependencies
425
426 let file_dependencies_as kind =
427 match kind with
428 | ML -> process_file_as ml_file_dependencies ()
429 | MLI -> process_file_as mli_file_dependencies ()
430
431 let sort_files_by_dependencies files =
432 let h = Hashtbl.create 31 in
433 let worklist = ref [] in
434
435 (* Init Hashtbl with all defined modules *)
436 let files = List.map (fun (file, file_kind, deps, pp_deps) ->
437 let modname =
438 String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
439 in
440 let key = (modname, file_kind) in
441 let new_deps = ref [] in
442 Hashtbl.add h key (file, new_deps);
443 worklist := key :: !worklist;
444 (modname, file_kind, deps, new_deps, pp_deps)
445 ) files in
446
447 (* Keep only dependencies to defined modules *)
448 List.iter (fun (modname, file_kind, deps, new_deps, _pp_deps) ->
449 let add_dep modname kind =
450 new_deps := (modname, kind) :: !new_deps;
451 in
452 String.Set.iter (fun modname ->
453 match file_kind with
454 ML -> (* ML depends both on ML and MLI *)
455 if Hashtbl.mem h (modname, MLI) then add_dep modname MLI;
456 if Hashtbl.mem h (modname, ML) then add_dep modname ML
457 | MLI -> (* MLI depends on MLI if exists, or ML otherwise *)
458 if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
459 else if Hashtbl.mem h (modname, ML) then add_dep modname ML
460 ) deps;
461 if file_kind = ML then (* add dep from .ml to .mli *)
462 if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
463 ) files;
464
465 (* Print and remove all files with no remaining dependency. Iterate
466 until all files have been removed (worklist is empty) or
467 no file was removed during a turn (cycle). *)
468 let printed = ref true in
469 while !printed && !worklist <> [] do
470 let files = !worklist in
471 worklist := [];
472 printed := false;
473 List.iter (fun key ->
474 let (file, deps) = Hashtbl.find h key in
475 let set = !deps in
476 deps := [];
477 List.iter (fun key ->
478 if Hashtbl.mem h key then deps := key :: !deps
479 ) set;
480 if !deps = [] then begin
481 printed := true;
482 Printf.printf "%s " file;
483 Hashtbl.remove h key;
484 end else
485 worklist := key :: !worklist
486 ) files
487 done;
488
489 if !worklist <> [] then begin
490 Location.error "cycle in dependencies. End of list is not sorted."
491 |> Location.print_report Format.err_formatter;
492 let sorted_deps =
493 let li = ref [] in
494 Hashtbl.iter (fun _ file_deps -> li := file_deps :: !li) h;
495 List.sort (fun (file1, _) (file2, _) -> String.compare file1 file2) !li
496 in
497 List.iter (fun (file, deps) ->
498 Format.fprintf Format.err_formatter "\t@[%s: " file;
499 List.iter (fun (modname, kind) ->
500 Format.fprintf Format.err_formatter "%s.%s " modname
501 (if kind=ML then "ml" else "mli");
502 ) !deps;
503 Format.fprintf Format.err_formatter "@]@.";
504 Printf.printf "%s " file) sorted_deps;
505 Error_occurred.set ()
506 end;
507 Printf.printf "\n%!";
508 ()
509
510 (* Map *)
511
512 let rec dump_map s0 ppf m =
513 let open Depend in
514 String.Map.iter
515 (fun key (Node(s1,m')) ->
516 let s = String.Set.diff s1 s0 in
517 if String.Set.is_empty s then
518 Format.fprintf ppf "@ @[<hv2>module %s : sig%a@;<1 -2>end@]"
519 key (dump_map (String.Set.union s1 s0)) m'
520 else
521 Format.fprintf ppf "@ module %s = %s" key (String.Set.choose s))
522 m
523
524 let process_ml_map =
525 read_parse_and_extract Parse.implementation Depend.add_implementation_binding
526 String.Map.empty Pparse.Structure
527
528 let process_mli_map =
529 read_parse_and_extract Parse.interface Depend.add_signature_binding
530 String.Map.empty Pparse.Signature
531
532 let parse_map fname =
533 map_files := fname :: !map_files ;
534 let old_transp = !Clflags.transparent_modules in
535 Clflags.transparent_modules := true;
536 let (deps, m) =
537 process_file fname ~def:(String.Set.empty, String.Map.empty)
538 ~ml_file:process_ml_map
539 ~mli_file:process_mli_map
540 in
541 Clflags.transparent_modules := old_transp;
542 let modname =
543 String.capitalize_ascii
544 (Filename.basename (Filename.chop_extension fname)) in
545 if String.Map.is_empty m then
546 report_err (Failure (fname ^ " : empty map file or parse error"));
547 let mm = Depend.make_node m in
548 if !debug then begin
549 Format.printf "@[<v>%s:%t%a@]@." fname
550 (fun ppf -> String.Set.iter (Format.fprintf ppf " %s") deps)
551 (dump_map deps) (String.Map.add modname mm String.Map.empty)
552 end;
553 let mm = Depend.(weaken_map (String.Set.singleton modname) mm) in
554 module_map := String.Map.add modname mm !module_map
555 ;;
556
557
558 (* Entry point *)
559
560 let print_version () =
561 Format.printf "ocamldep, version %s@." Sys.ocaml_version;
562 exit 0;
563 ;;
564
565 let print_version_num () =
566 Format.printf "%s@." Sys.ocaml_version;
567 exit 0;
568 ;;
569
570 let main () =
571 Clflags.classic := false;
572 add_to_list first_include_dirs Filename.current_dir_name;
573 Compenv.readenv ppf Before_args;
574 Clflags.reset_arguments (); (* reset arguments from ocamlc/ocamlopt *)
575 Clflags.add_arguments __LOC__ [
576 "-absname", Arg.Set Clflags.absname,
577 " Show absolute filenames in error messages";
578 "-all", Arg.Set all_dependencies,
579 " Generate dependencies on all files";
580 "-allow-approx", Arg.Set allow_approximation,
581 " Fallback to a lexer-based approximation on unparsable files";
582 "-as-map", Arg.Set Clflags.transparent_modules,
583 " Omit delayed dependencies for module aliases (-no-alias-deps -w -49)";
584 (* "compiler uses -no-alias-deps, and no module is coerced"; *)
585 "-debug-map", Arg.Set debug,
586 " Dump the delayed dependency map for each map file";
587 "-I", Arg.String (add_to_list Clflags.include_dirs),
588 "<dir> Add <dir> to the list of include directories";
589 "-impl", Arg.String (file_dependencies_as ML),
590 "<f> Process <f> as a .ml file";
591 "-intf", Arg.String (file_dependencies_as MLI),
592 "<f> Process <f> as a .mli file";
593 "-map", Arg.String parse_map,
594 "<f> Read <f> and propagate delayed dependencies to following files";
595 "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
596 "<e> Consider <e> as a synonym of the .ml extension";
597 "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms),
598 "<e> Consider <e> as a synonym of the .mli extension";
599 "-modules", Arg.Set raw_dependencies,
600 " Print module dependencies in raw form (not suitable for make)";
601 "-native", Arg.Set native_only,
602 " Generate dependencies for native-code only (no .cmo files)";
603 "-bytecode", Arg.Set bytecode_only,
604 " Generate dependencies for bytecode-code only (no .cmx files)";
605 "-one-line", Arg.Set one_line,
606 " Output one line per file, regardless of the length";
607 "-open", Arg.String (add_to_list Clflags.open_modules),
608 "<module> Opens the module <module> before typing";
609 "-plugin", Arg.String(fun _p -> Clflags.plugin := true),
610 "<plugin> (no longer supported)";
611 "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
612 "<cmd> Pipe sources through preprocessor <cmd>";
613 "-ppx", Arg.String (add_to_list first_ppx),
614 "<cmd> Pipe abstract syntax trees through preprocessor <cmd>";
615 "-shared", Arg.Set shared,
616 " Generate dependencies for native plugin files (.cmxs targets)";
617 "-slash", Arg.Set Clflags.force_slash,
618 " (Windows) Use forward slash / instead of backslash \\ in file paths";
619 "-sort", Arg.Set sort_files,
620 " Sort files according to their dependencies";
621 "-version", Arg.Unit print_version,
622 " Print version and exit";
623 "-vnum", Arg.Unit print_version_num,
624 " Print version number and exit";
625 "-args", Arg.Expand Arg.read_arg,
626 "<file> Read additional newline separated command line arguments \n\
627 \ from <file>";
628 "-args0", Arg.Expand Arg.read_arg0,
629 "<file> Read additional NUL separated command line arguments from \n\
630 \ <file>"
631 ];
632 let usage =
633 Printf.sprintf "Usage: %s [options] <source files>\nOptions are:"
634 (Filename.basename Sys.argv.(0))
635 in
636 Clflags.parse_arguments file_dependencies usage;
637 Compenv.readenv ppf Before_link;
638 if !sort_files then sort_files_by_dependencies !files
639 else List.iter print_file_dependencies (List.sort compare !files);
640 exit (if Error_occurred.get () then 2 else 0)
641
642 let main_from_option () =
643 if Sys.argv.(1) <> "-depend" then begin
644 Printf.eprintf
645 "Fatal error: argument -depend must be used as first argument.\n%!";
646 exit 2;
647 end;
648 incr Arg.current;
649 Sys.argv.(0) <- Sys.argv.(0) ^ " -depend";
650 Sys.argv.(!Arg.current) <- Sys.argv.(0);
651 main ()
652