trunk/driver/run.ml

open Ident

let out_dir  = ref [] (* directory of the output file *)
let src  = ref []
let args = ref []

let compile = ref false
let run = ref false
let script = ref false
let mlstub = ref false
let topstub = ref false

let version () =
  Printf.eprintf "CDuce, version %s\n" <:symbol<cduce_version>>;
  Printf.eprintf "built on %s\n" <:symbol<build_date>>;
  Printf.eprintf "using OCaml %s compiler\n" <:symbol<ocaml_compiler>>;
  Printf.eprintf "Supported features: \n";
  List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Cduce_config.descrs ());
  exit 0

let specs =
  [ "--compile", Arg.Set compile,
             "compile the given CDuce file";
    "-c", Arg.Set compile,
      "       same as --compile";
    "--run", Arg.Set run,
         "    execute the given .cdo files";
    "--verbose", Arg.Set Cduce.verbose,
             "(for --compile) show types of exported values";
    "--obj-dir",  Arg.String (fun s -> out_dir := s :: !out_dir),
             "(for --compile) directory for the compiled .cdo file";
    "-I", Arg.String (fun s -> Cduce_loc.obj_path := s::!Cduce_loc.obj_path),
      "       add one directory to the lookup path for .cdo/.cmi and include files";
    "--stdin", Arg.Unit (fun () -> src := "" :: !src),
           "  read CDuce script on standard input";
    "--arg", Arg.Rest (fun s -> args := s :: !args),
         "    following arguments are passed to the CDuce program";
    "--script", Arg.Rest (fun s -> 
                            if not !script then (script := true;
                                                src := s :: !src)
                            else args := s :: !args),
            " the first argument after is the source, then the arguments";
    "--no", Arg.String Cduce_config.inhibit,
        "     disable a feature (cduce -v to get a list of features)";
    "--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
           "  print profiling/debugging information";
    "-v", Arg.Unit version,
      "       print CDuce version, and list built-in optional features";
    "--version", Arg.Unit version,
             "print CDuce version, and list built-in optional features";
    "--mlstub", Arg.Set mlstub,
            " produce stub ML code from a compiled unit";
    "--topstub", Arg.Set topstub,
             "produce stub ML code for a toplevel from a primitive file";
 ]

let ppf = Format.std_formatter
let ppf_err = Format.err_formatter

let err s =
  prerr_endline s;
  exit 1

let mode () =
  Arg.parse (specs @ !Cduce.extra_specs) (fun s -> src := s :: !src) 
    "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
  if (!mlstub) then (
    match !src with [x] -> `Mlstub x | _ ->
      err "Please specify one .cdo file"
  ) else if (!topstub) then (
    match !src with [x] -> `Topstub x | _ ->
      err "Please specify one primitive file"
  ) else match (!compile,!out_dir,!run,!src,!args) with
    | false, _::_, _,  _, _   -> 
        err "--obj-dir option can be used only with --compile"
    | false, [], false, [],  args   -> `Toplevel args
    | false, [], false, [x], args   -> `Script (x,args)
    | false, [], false, _, _        ->
        err "Only one CDuce program can be executed at a time"
    | true,  [o], false, [x], []     -> `Compile (x,Some o) 
    | true,  [], false, [x], []     -> `Compile (x,None) 
    | true,  [], false, [], []      ->
        err "Please specify the CDuce program to be compiled"
    | true,  [], false, _, []       ->
        err "Only one CDuce program can be compiled at a time"
    | true,  _, false, _, []        ->
        err "Please specify only one output directory"
    | true,  _, false, _, _        ->
        err "No argument can be passed to programs at compile time"
    | false, _, true,  [x], args   -> `Run (x,args)
    | false, _, true,  [], _       ->
        err "Please specifiy the CDuce program to be executed"
    | false, _, true,   _, _       ->
        err "Only one CDuce program can be executed at a time"
    | true, _, true,   _,  _       ->
        err "The options --compile and --run are incompatible"
        

let bol = ref true

let outflush s =
  output_string stdout s;
  flush stdout

let toploop () =
  let restore = 
    try 
      let tcio = Unix.tcgetattr Unix.stdin in
      Unix.tcsetattr 
        Unix.stdin Unix.TCSADRAIN { tcio with Unix.c_vquit = '\004' };
      fun () -> Unix.tcsetattr Unix.stdin Unix.TCSADRAIN tcio
    with Unix.Unix_error (_,_,_) -> 
      fun () -> ()
  in
  let quit () = 
    outflush "\n";
    restore ();
    exit 0
  in
  Format.fprintf ppf "        CDuce version %s\n@." <:symbol<cduce_version>>;
  Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
  Sys.catch_break true;
  Cduce.toplevel := true;
  Librarian.run_loaded := true;
  let buf_in = Buffer.create 1024 in
  Cduce_loc.push_source (`Buffer buf_in);
  let read _i =
    if !bol then 
      if !Ulexer.in_comment then outflush "* " else outflush "> ";
    try 
      let c = input_char stdin in
      Buffer.add_char buf_in c;
      bol := c = '\n';
      Some c
    with Sys.Break -> quit () 
  in
  let input = Stream.from read in
  let rec loop () =
    outflush "# ";
    bol := false;
    Buffer.clear buf_in;
    ignore (Cduce.topinput ppf ppf_err input);
    while (input_char stdin != '\n') do () done;
    loop () in
  (try loop () with End_of_file -> ());
  restore ()

let argv args = 
  Value.sequence (List.rev_map Value.string_latin1 args)

let main () = 
  at_exit (fun () -> Stats.dump Format.std_formatter);
  Cduce_loc.set_viewport (Html.create false);
  match mode () with
    | `Toplevel args ->
        Cduce_config.init_all ();
        Builtin.argv := argv args;
        toploop ()
    | `Script (f,args) ->
        Cduce_config.init_all ();
        Builtin.argv := argv args;
        Cduce.compile_run f
    | `Compile (f,o) ->
        Cduce_config.init_all ();
        Cduce.compile f o
    | `Run (f,args) ->
        Cduce_config.init_all ();
        Builtin.argv := argv args;
        Cduce.run f
    | `Mlstub f ->
        Cduce_config.init_all ();
        Librarian.prepare_stub f
    | `Topstub f ->
        Cduce_config.init_all ();
        !Librarian.make_wrapper f
1	open Ident
2
3	let out_dir = ref [] (* directory of the output file *)
4	let src = ref []
5	let args = ref []
6
7	let compile = ref false
8	let run = ref false
9	let script = ref false
10	let mlstub = ref false
11	let topstub = ref false
12
13	let version () =
14	Printf.eprintf "CDuce, version %s\n" <:symbol<cduce_version>>;
15	Printf.eprintf "built on %s\n" <:symbol<build_date>>;
16	Printf.eprintf "using OCaml %s compiler\n" <:symbol<ocaml_compiler>>;
17	Printf.eprintf "Supported features: \n";
18	List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Cduce_config.descrs ());
19	exit 0
20
21	let specs =
22	[ "--compile", Arg.Set compile,
23	"compile the given CDuce file";
24	"-c", Arg.Set compile,
25	" same as --compile";
26	"--run", Arg.Set run,
27	" execute the given .cdo files";
28	"--verbose", Arg.Set Cduce.verbose,
29	"(for --compile) show types of exported values";
30	"--obj-dir", Arg.String (fun s -> out_dir := s :: !out_dir),
31	"(for --compile) directory for the compiled .cdo file";
32	"-I", Arg.String (fun s -> Cduce_loc.obj_path := s::!Cduce_loc.obj_path),
33	" add one directory to the lookup path for .cdo/.cmi and include files";
34	"--stdin", Arg.Unit (fun () -> src := "" :: !src),
35	" read CDuce script on standard input";
36	"--arg", Arg.Rest (fun s -> args := s :: !args),
37	" following arguments are passed to the CDuce program";
38	"--script", Arg.Rest (fun s ->
39	if not !script then (script := true;
40	src := s :: !src)
41	else args := s :: !args),
42	" the first argument after is the source, then the arguments";
43	"--no", Arg.String Cduce_config.inhibit,
44	" disable a feature (cduce -v to get a list of features)";
45	"--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
46	" print profiling/debugging information";
47	"-v", Arg.Unit version,
48	" print CDuce version, and list built-in optional features";
49	"--version", Arg.Unit version,
50	"print CDuce version, and list built-in optional features";
51	"--mlstub", Arg.Set mlstub,
52	" produce stub ML code from a compiled unit";
53	"--topstub", Arg.Set topstub,
54	"produce stub ML code for a toplevel from a primitive file";
55	]
56
57	let ppf = Format.std_formatter
58	let ppf_err = Format.err_formatter
59
60	let err s =
61	prerr_endline s;
62	exit 1
63
64	let mode () =
65	Arg.parse (specs @ !Cduce.extra_specs) (fun s -> src := s :: !src)
66	"Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
67	if (!mlstub) then (
68	match !src with [x] -> `Mlstub x \| _ ->
69	err "Please specify one .cdo file"
70	) else if (!topstub) then (
71	match !src with [x] -> `Topstub x \| _ ->
72	err "Please specify one primitive file"
73	) else match (!compile,!out_dir,!run,!src,!args) with
74	\| false, _::_, _, _, _ ->
75	err "--obj-dir option can be used only with --compile"
76	\| false, [], false, [], args -> `Toplevel args
77	\| false, [], false, [x], args -> `Script (x,args)
78	\| false, [], false, _, _ ->
79	err "Only one CDuce program can be executed at a time"
80	\| true, [o], false, [x], [] -> `Compile (x,Some o)
81	\| true, [], false, [x], [] -> `Compile (x,None)
82	\| true, [], false, [], [] ->
83	err "Please specify the CDuce program to be compiled"
84	\| true, [], false, _, [] ->
85	err "Only one CDuce program can be compiled at a time"
86	\| true, _, false, _, [] ->
87	err "Please specify only one output directory"
88	\| true, _, false, _, _ ->
89	err "No argument can be passed to programs at compile time"
90	\| false, _, true, [x], args -> `Run (x,args)
91	\| false, _, true, [], _ ->
92	err "Please specifiy the CDuce program to be executed"
93	\| false, _, true, _, _ ->
94	err "Only one CDuce program can be executed at a time"
95	\| true, _, true, _, _ ->
96	err "The options --compile and --run are incompatible"
97
98
99
100	let bol = ref true
101
102	let outflush s =
103	output_string stdout s;
104	flush stdout
105
106	let toploop () =
107	let restore =
108	try
109	let tcio = Unix.tcgetattr Unix.stdin in
110	Unix.tcsetattr
111	Unix.stdin Unix.TCSADRAIN { tcio with Unix.c_vquit = '\004' };
112	fun () -> Unix.tcsetattr Unix.stdin Unix.TCSADRAIN tcio
113	with Unix.Unix_error (_,_,_) ->
114	fun () -> ()
115	in
116	let quit () =
117	outflush "\n";
118	restore ();
119	exit 0
120	in
121	Format.fprintf ppf " CDuce version %s\n@." <:symbol<cduce_version>>;
122	Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
123	Sys.catch_break true;
124	Cduce.toplevel := true;
125	Librarian.run_loaded := true;
126	let buf_in = Buffer.create 1024 in
127	Cduce_loc.push_source (`Buffer buf_in);
128	let read _i =
129	if !bol then
130	if !Ulexer.in_comment then outflush "* " else outflush "> ";
131	try
132	let c = input_char stdin in
133	Buffer.add_char buf_in c;
134	bol := c = '\n';
135	Some c
136	with Sys.Break -> quit ()
137	in
138	let input = Stream.from read in
139	let rec loop () =
140	outflush "# ";
141	bol := false;
142	Buffer.clear buf_in;
143	ignore (Cduce.topinput ppf ppf_err input);
144	while (input_char stdin != '\n') do () done;
145	loop () in
146	(try loop () with End_of_file -> ());
147	restore ()
148
149	let argv args =
150	Value.sequence (List.rev_map Value.string_latin1 args)
151
152	let main () =
153	at_exit (fun () -> Stats.dump Format.std_formatter);
154	Cduce_loc.set_viewport (Html.create false);
155	match mode () with
156	\| `Toplevel args ->
157	Cduce_config.init_all ();
158	Builtin.argv := argv args;
159	toploop ()
160	\| `Script (f,args) ->
161	Cduce_config.init_all ();
162	Builtin.argv := argv args;
163	Cduce.compile_run f
164	\| `Compile (f,o) ->
165	Cduce_config.init_all ();
166	Cduce.compile f o
167	\| `Run (f,args) ->
168	Cduce_config.init_all ();
169	Builtin.argv := argv args;
170	Cduce.run f
171	\| `Mlstub f ->
172	Cduce_config.init_all ();
173	Librarian.prepare_stub f
174	\| `Topstub f ->
175	Cduce_config.init_all ();
176	!Librarian.make_wrapper f