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 Compenv
17
18 let usage = "Usage: ocaml <options> <object-files> [script-file [arguments]]\n\
19 options 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 let prepare ppf =
42 Toploop.set_paths ();
43 try
44 let res =
45 let objects =
46 List.rev (!preload_objects @ !first_objfiles)
47 in
48 List.for_all (Topdirs.load_file ppf) objects
49 in
50 Toploop.run_hooks Toploop.Startup;
51 res
52 with x ->
53 try Location.report_exception ppf x; false
54 with x ->
55 Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
56 false
57
58 (* If [name] is "", then the "file" is stdin treated as a script file. *)
59 let file_argument name =
60 let ppf = Format.err_formatter in
61 if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
62 then preload_objects := name :: !preload_objects
63 else if is_expanded !current then begin
64 (* Script files are not allowed in expand options because otherwise the
65 check in override arguments may fail since the new argv can be larger
66 than the original argv.
67 *)
68 Printf.eprintf "For implementation reasons, the toplevel does not support\
69 \ having script files (here %S) inside expanded arguments passed through the\
70 \ -args{,0} command-line option.\n" name;
71 exit 2
72 end else begin
73 let newargs = Array.sub !argv !current
74 (Array.length !argv - !current)
75 in
76 Compenv.readenv ppf Before_link;
77 Compmisc.read_clflags_from_env ();
78 if prepare ppf && Toploop.run_script ppf name newargs
79 then exit 0
80 else exit 2
81 end
82
83
84 let wrap_expand f s =
85 let start = !current in
86 let arr = f s in
87 expand_position start (Array.length arr);
88 arr
89
90 module Options = Main_args.Make_bytetop_options (struct
91 include Main_args.Default.Topmain
92 let _stdin () = file_argument ""
93 let _args = wrap_expand Arg.read_arg
94 let _args0 = wrap_expand Arg.read_arg0
95 let anonymous s = file_argument s
96 end);;
97
98 let () =
99 let extra_paths =
100 match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
101 | exception Not_found -> []
102 | s -> Misc.split_path_contents s
103 in
104 Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs
105
106 let main () =
107 let ppf = Format.err_formatter in
108 Compenv.readenv ppf Before_args;
109 let list = ref Options.list in
110 begin
111 try
112 Arg.parse_and_expand_argv_dynamic current argv list file_argument usage;
113 with
114 | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2
115 | Arg.Help msg -> Printf.printf "%s" msg; exit 0
116 end;
117 Compenv.readenv ppf Before_link;
118 Compmisc.read_clflags_from_env ();
119 if not (prepare ppf) then exit 2;
120 Compmisc.init_path ();
121 Toploop.loop Format.std_formatter
122