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 open Clflags
17
18 let usage =
19 "Usage: ocamlnat <options> <object-files> [script-file]\noptions are:"
20
21 let preload_objects = ref []
22
23 (* Position of the first non expanded argument *)
24 let first_nonexpanded_pos = ref 0
25
26 let current = ref (!Arg.current)
27
28 let argv = ref Sys.argv
29
30 (* Test whether the option is part of a responsefile *)
31 let is_expanded pos = pos < !first_nonexpanded_pos
32
33 let expand_position pos len =
34 if pos < !first_nonexpanded_pos then
35 (* Shift the position *)
36 first_nonexpanded_pos := !first_nonexpanded_pos + len
37 else
38 (* New last position *)
39 first_nonexpanded_pos := pos + len + 2
40
41
42 let prepare ppf =
43 Opttoploop.set_paths ();
44 try
45 let res =
46 List.for_all (Opttopdirs.load_file ppf) (List.rev !preload_objects)
47 in
48 Opttoploop.run_hooks Opttoploop.Startup;
49 res
50 with x ->
51 try Location.report_exception ppf x; false
52 with x ->
53 Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
54 false
55
56 let file_argument name =
57 let ppf = Format.err_formatter in
58 if Filename.check_suffix name ".cmxs"
59 || Filename.check_suffix name ".cmx"
60 || Filename.check_suffix name ".cmxa"
61 then preload_objects := name :: !preload_objects
62 else if is_expanded !current then begin
63 (* Script files are not allowed in expand options because otherwise the
64 check in override arguments may fail since the new argv can be larger
65 than the original argv.
66 *)
67 Printf.eprintf "For implementation reasons, the toplevel does not support\
68 \ having script files (here %S) inside expanded arguments passed through\
69 \ the -args{,0} command-line option.\n" name;
70 exit 2
71 end else begin
72 let newargs = Array.sub !argv !Arg.current
73 (Array.length !argv - !Arg.current)
74 in
75 Compmisc.read_clflags_from_env ();
76 if prepare ppf && Opttoploop.run_script ppf name newargs
77 then exit 0
78 else exit 2
79 end
80
81 let wrap_expand f s =
82 let start = !current in
83 let arr = f s in
84 expand_position start (Array.length arr);
85 arr
86
87 module Options = Main_args.Make_opttop_options (struct
88 include Main_args.Default.Opttopmain
89 let _stdin () = file_argument ""
90 let _args = wrap_expand Arg.read_arg
91 let _args0 = wrap_expand Arg.read_arg0
92 let anonymous s = file_argument s
93 end);;
94
95 let () =
96 let extra_paths =
97 match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
98 | exception Not_found -> []
99 | s -> Misc.split_path_contents s
100 in
101 Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs
102
103 let main () =
104 native_code := true;
105 let list = ref Options.list in
106 begin
107 try
108 Arg.parse_and_expand_argv_dynamic current argv list file_argument usage;
109 with
110 | Arg.Bad msg -> Format.fprintf Format.err_formatter "%s%!" msg; exit 2
111 | Arg.Help msg -> Format.fprintf Format.std_formatter "%s%!" msg; exit 0
112 end;
113 Compmisc.read_clflags_from_env ();
114 if not (prepare Format.err_formatter) then exit 2;
115 Compmisc.init_path ();
116 Opttoploop.loop Format.std_formatter
117