viewcvs.cgi/driver/run.ml

open Ident

let () = State.close ();;

let load_dump = ref None
let save_dump = ref None

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

let compile = ref false
let run = 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 "support for expat: %b\n" (Load_xml.expat_support);
  exit 0

let license () =
  Printf.eprintf "\n\
The CDuce interpreter is distributed under the terms of the Q Public \n\
License version 1.0 (included in the sources). The Choice of Law section\n\
been modified from the original Q Public.\n\n
"; 
  exit 0

let specs =
  [ "--load", Arg.String (fun s -> load_dump := Some s), 
          "   load persistency file before running CDuce program";
    "--save", Arg.String (fun s -> save_dump := Some s), 
          "   save persistency file after running CDuce program";
    "--dump", Arg.String (fun s -> save_dump := Some s; load_dump := Some s), 
          "   specify persistency file for loading and saving";
    "--quiet", Arg.Set Cduce.quiet, 
           "  suppress normal output (typing, results)";
    "--compile", Arg.Set compile,
             "compile the given CDuce file";
    "--obj-dir",  Arg.String (fun s -> out_dir := s :: !out_dir),
             "directory for the compiled .cdo file";
    "-I", Arg.String (fun s -> Librarian.obj_path := s::!Librarian.obj_path),
      "       add one directory to the lookup path for .cdo files";
    "--run", Arg.Set run,
           "    execute the given .cdo file";
    "--stdin", Arg.Unit (fun () -> src := "" :: !src),
           "  read CDuce script on standard input";
    "--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
             "print profiling/debugging information";
    "-v", Arg.Unit version,
      "       print CDuce version";
    "--version", Arg.Unit version,
             "print CDuce version";
    "--license", Arg.Unit license,
             "print CDuce license";
   "--arg", Arg.Rest (fun s -> args := s :: !args),
         "    following arguments are passed to the CDuce program (in argv)";  

 ]

let ppf = 
  if !Cduce.quiet then Format.formatter_of_buffer (Buffer.create 1023)
  else Format.std_formatter
let ppf_err = Format.err_formatter


let specs = 
  if Load_xml.expat_support then
    ("--expat", Arg.Unit (fun () -> Load_xml.use_parser := `Expat),
             "  use expat parser (default)") ::
    ("--pxp", Arg.Unit (fun () -> Load_xml.use_parser := `Pxp),
           "    use PXP parser") ::
    specs
  else
    ("--expat", Arg.Unit (fun () -> (Format.fprintf ppf  "WARNING: --expat unused option. CDuce compiled without expat support\n\n")),
             "  option not available: CDuce was compiled without expat support") ::
    ("--pxp", Arg.Unit (fun () -> (Format.fprintf ppf  "WARNING: --pxp useless option. CDuce compiled without expat support\n\n")),
           "    useless option:  CDuce was compiled without expat support") ::
    specs


let err s =
  prerr_endline s;
  exit 1

let mode =
  Arg.parse specs (fun s -> src := s :: !src) 
    "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
  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 () =
  Cduce.toplevel := true;
  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;
  Location.push_source `Stream;
  let read i =
    if !bol then 
      if !Ulexer.in_comment then outflush "* " else outflush "> ";
    try 
      let c = input_char stdin in
      bol := c = '\n';
      Some c
    with Sys.Break -> quit () 
  in
  let input = Stream.from read in
  let rec loop () =
    outflush "# ";
    bol := false;
    ignore (Cduce.topinput ppf ppf_err input);
    while (input_char stdin != '\n') do () done;
    loop () in
  (try loop () with End_of_file -> ());
  restore ()

let do_file s =
  let chan = open_in s in
  Location.push_source (`File s);
  let input = Stream.of_channel chan in
  let ok = Cduce.script ppf ppf_err input in
  close_in chan;
  if not ok then exit 1

let do_stdin () =
  Location.push_source `Stream;
  let input = Stream.of_channel stdin in
  let ok = Cduce.script ppf ppf_err input in
  if not ok then exit 1

let run s =
  if s = "" then do_stdin () else do_file s

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

let restore argv =
  match !load_dump with
    | Some f ->
        (try 
           Format.fprintf ppf "Restoring state: ";
           let chan = open_in_bin f in
           let s = Marshal.from_channel chan in
           close_in chan;
           (*       Serialize.Get.run Cduce.deserialize_typing_env s; *)
           State.set s; 
           Format.fprintf ppf "done ...@."
         with Sys_error _ ->  
           Format.fprintf ppf "failed ...@.")
    | None -> 
        let t = Sequence.star Sequence.string in
        Cduce.enter_global_value (ident (U.mk "argv")) argv t

let save () =
  match !save_dump with
    | Some f ->
        Format.fprintf ppf "Saving state ...@\n";
        (*       let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
        let s = State.get () in
        let chan = open_out_bin f in
        Marshal.to_channel chan s [ Marshal.Closures ];
        close_out chan
    | None -> ()

let main () = 
  match mode with
    | `Toplevel args ->
        restore (argv args);
        toploop ();
        save ()
    | `Script (f,args) ->
        Cduce.compile_run f (argv args)
    | `Compile (f,o) ->
        Cduce.compile f o
    | `Run (f,args) ->
        Cduce.run f (argv args)
         
let () =  
  at_exit (fun () -> Stats.dump Format.std_formatter);
  main ()


1	open Ident
2
3	let () = State.close ();;
4
5	let load_dump = ref None
6	let save_dump = ref None
7
8	let out_dir = ref [] (* directory of the output file *)
9	let src = ref []
10	let args = ref []
11
12	let compile = ref false
13	let run = ref false
14
15	let version () =
16	Printf.eprintf "CDuce, version %s\n" <:symbol<cduce_version>>;
17	Printf.eprintf "built on %s\n" <:symbol<build_date>>;
18	Printf.eprintf "using OCaml %s compiler\n" <:symbol<ocaml_compiler>>;
19	Printf.eprintf "support for expat: %b\n" (Load_xml.expat_support);
20	exit 0
21
22	let license () =
23	Printf.eprintf "\n\
24	The CDuce interpreter is distributed under the terms of the Q Public \n\
25	License version 1.0 (included in the sources). The Choice of Law section\n\
26	been modified from the original Q Public.\n\n
27	";
28	exit 0
29
30	let specs =
31	[ "--load", Arg.String (fun s -> load_dump := Some s),
32	" load persistency file before running CDuce program";
33	"--save", Arg.String (fun s -> save_dump := Some s),
34	" save persistency file after running CDuce program";
35	"--dump", Arg.String (fun s -> save_dump := Some s; load_dump := Some s),
36	" specify persistency file for loading and saving";
37	"--quiet", Arg.Set Cduce.quiet,
38	" suppress normal output (typing, results)";
39	"--compile", Arg.Set compile,
40	"compile the given CDuce file";
41	"--obj-dir", Arg.String (fun s -> out_dir := s :: !out_dir),
42	"directory for the compiled .cdo file";
43	"-I", Arg.String (fun s -> Librarian.obj_path := s::!Librarian.obj_path),
44	" add one directory to the lookup path for .cdo files";
45	"--run", Arg.Set run,
46	" execute the given .cdo file";
47	"--stdin", Arg.Unit (fun () -> src := "" :: !src),
48	" read CDuce script on standard input";
49	"--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
50	"print profiling/debugging information";
51	"-v", Arg.Unit version,
52	" print CDuce version";
53	"--version", Arg.Unit version,
54	"print CDuce version";
55	"--license", Arg.Unit license,
56	"print CDuce license";
57	"--arg", Arg.Rest (fun s -> args := s :: !args),
58	" following arguments are passed to the CDuce program (in argv)";
59
60	]
61
62	let ppf =
63	if !Cduce.quiet then Format.formatter_of_buffer (Buffer.create 1023)
64	else Format.std_formatter
65	let ppf_err = Format.err_formatter
66
67
68	let specs =
69	if Load_xml.expat_support then
70	("--expat", Arg.Unit (fun () -> Load_xml.use_parser := `Expat),
71	" use expat parser (default)") ::
72	("--pxp", Arg.Unit (fun () -> Load_xml.use_parser := `Pxp),
73	" use PXP parser") ::
74	specs
75	else
76	("--expat", Arg.Unit (fun () -> (Format.fprintf ppf "WARNING: --expat unused option. CDuce compiled without expat support\n\n")),
77	" option not available: CDuce was compiled without expat support") ::
78	("--pxp", Arg.Unit (fun () -> (Format.fprintf ppf "WARNING: --pxp useless option. CDuce compiled without expat support\n\n")),
79	" useless option: CDuce was compiled without expat support") ::
80	specs
81
82
83	let err s =
84	prerr_endline s;
85	exit 1
86
87	let mode =
88	Arg.parse specs (fun s -> src := s :: !src)
89	"Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
90	match (!compile,!out_dir,!run,!src,!args) with
91	\| false, _::_, _, _, _ ->
92	err "--obj-dir option can be used only with --compile"
93	\| false, [], false, [], args -> `Toplevel args
94	\| false, [], false, [x], args -> `Script (x,args)
95	\| false, [], false, _, _ ->
96	err "Only one CDuce program can be executed at a time"
97	\| true, [o], false, [x], [] -> `Compile (x,Some o)
98	\| true, [], false, [x], [] -> `Compile (x,None)
99	\| true, [], false, [], [] ->
100	err "Please specify the CDuce program to be compiled"
101	\| true, [], false, _, [] ->
102	err "Only one CDuce program can be compiled at a time"
103	\| true, _, false, _, [] ->
104	err "Please specify only one output directory"
105	\| true, _, false, _, _ ->
106	err "No argument can be passed to programs at compile time"
107	\| false, _, true, [x], args -> `Run (x,args)
108	\| false, _, true, [], _ ->
109	err "Please specifiy the CDuce program to be executed"
110	\| false, _, true, _, _ ->
111	err "Only one CDuce program can be executed at a time"
112	\| true, _, true, _, _ ->
113	err "The options --compile and --run are incompatible"
114
115
116
117	let bol = ref true
118
119	let outflush s =
120	output_string stdout s;
121	flush stdout
122
123	let toploop () =
124	Cduce.toplevel := true;
125	let restore =
126	try
127	let tcio = Unix.tcgetattr Unix.stdin in
128	Unix.tcsetattr
129	Unix.stdin Unix.TCSADRAIN { tcio with Unix.c_vquit = '\004' };
130	fun () -> Unix.tcsetattr Unix.stdin Unix.TCSADRAIN tcio
131	with Unix.Unix_error (_,_,_) ->
132	fun () -> ()
133	in
134	let quit () =
135	outflush "\n";
136	restore ();
137	exit 0
138	in
139	Format.fprintf ppf " CDuce version %s\n@." <:symbol<cduce_version>>;
140	Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
141	Sys.catch_break true;
142	Cduce.toplevel := true;
143	Location.push_source `Stream;
144	let read i =
145	if !bol then
146	if !Ulexer.in_comment then outflush "* " else outflush "> ";
147	try
148	let c = input_char stdin in
149	bol := c = '\n';
150	Some c
151	with Sys.Break -> quit ()
152	in
153	let input = Stream.from read in
154	let rec loop () =
155	outflush "# ";
156	bol := false;
157	ignore (Cduce.topinput ppf ppf_err input);
158	while (input_char stdin != '\n') do () done;
159	loop () in
160	(try loop () with End_of_file -> ());
161	restore ()
162
163	let do_file s =
164	let chan = open_in s in
165	Location.push_source (`File s);
166	let input = Stream.of_channel chan in
167	let ok = Cduce.script ppf ppf_err input in
168	close_in chan;
169	if not ok then exit 1
170
171	let do_stdin () =
172	Location.push_source `Stream;
173	let input = Stream.of_channel stdin in
174	let ok = Cduce.script ppf ppf_err input in
175	if not ok then exit 1
176
177	let run s =
178	if s = "" then do_stdin () else do_file s
179
180	let argv args =
181	Value.sequence (List.rev_map Value.string_latin1 args)
182
183	let restore argv =
184	match !load_dump with
185	\| Some f ->
186	(try
187	Format.fprintf ppf "Restoring state: ";
188	let chan = open_in_bin f in
189	let s = Marshal.from_channel chan in
190	close_in chan;
191	(* Serialize.Get.run Cduce.deserialize_typing_env s; *)
192	State.set s;
193	Format.fprintf ppf "done ...@."
194	with Sys_error _ ->
195	Format.fprintf ppf "failed ...@.")
196	\| None ->
197	let t = Sequence.star Sequence.string in
198	Cduce.enter_global_value (ident (U.mk "argv")) argv t
199
200	let save () =
201	match !save_dump with
202	\| Some f ->
203	Format.fprintf ppf "Saving state ...@\n";
204	(* let s = Serialize.Put.run Cduce.serialize_typing_env () in *)
205	let s = State.get () in
206	let chan = open_out_bin f in
207	Marshal.to_channel chan s [ Marshal.Closures ];
208	close_out chan
209	\| None -> ()
210
211	let main () =
212	match mode with
213	\| `Toplevel args ->
214	restore (argv args);
215	toploop ();
216	save ()
217	\| `Script (f,args) ->
218	Cduce.compile_run f (argv args)
219	\| `Compile (f,o) ->
220	Cduce.compile f o
221	\| `Run (f,args) ->
222	Cduce.run f (argv args)
223
224	let () =
225	at_exit (fun () -> Stats.dump Format.std_formatter);
226	main ()
227
228