run.ml 6.82 KB
Newer Older
1
2
open Ident

3
let () = State.close ();;
4

5
6
7
let load_dump = ref None
let save_dump = ref None

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

12
13
14
let compile = ref false
let run = ref false

15
16
17
18
19
ifdef ML_INTERFACE then
  let ocaml_support = true
else 
  let ocaml_support = false;;

20
let version () =
21
22
23
  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>>;
24
  Printf.eprintf "support for ocaml interfacing: %b\n" ocaml_support;
25
  Printf.eprintf "support for expat: %b\n" (Load_xml.expat_support);
26
  Printf.eprintf "support for curl: %b\n" (Load_xml.curl_support);
27
28
29
30
31
32
33
34
  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
"; 
35
36
  exit 0

37
let specs = ref 
38
39
40
41
42
43
  [ "--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";
44
45
    "--verbose", Arg.Set Cduce.verbose,
             "verbose output for compilation (show types of exported values)";
46
    "--compile", Arg.Set compile,
47
48
49
50
51
             "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";
52
    "--run", Arg.Set run,
53
           "    execute the given .cdo file";
54
55
    "--stdin", Arg.Unit (fun () -> src := "" :: !src),
           "  read CDuce script on standard input";
56
57
    "--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
           "  print profiling/debugging information";
58
    "-v", Arg.Unit version,
59
      "       print CDuce version";
60
    "--version", Arg.Unit version,
61
62
63
             "print CDuce version";
    "--license", Arg.Unit license,
             "print CDuce license";
64
   "--arg", Arg.Rest (fun s -> args := s :: !args),
65
         "    following arguments are passed to the CDuce program (in argv)";  
66

67
 ]
68

69
let ppf = Format.std_formatter
70
71
let ppf_err = Format.err_formatter

72
let () =
73
  if Load_xml.expat_support then
74
     specs := 
75
76
77
    ("--expat", Arg.Unit (fun () -> Load_xml.use_parser := `Expat),
             "  use expat parser (default)") ::
    ("--pxp", Arg.Unit (fun () -> Load_xml.use_parser := `Pxp),
78
           "    use PXP parser") ::
79
    !specs
80
  else
81
    specs :=
82
    ("--expat", Arg.Unit (fun () -> (Format.fprintf ppf  "WARNING: --expat unused option. CDuce compiled without expat support\n\n")),
83
             "  option not available: CDuce was compiled without expat support") ::
84
    ("--pxp", Arg.Unit (fun () -> (Format.fprintf ppf  "WARNING: --pxp useless option. CDuce compiled without expat support\n\n")),
85
           "    useless option:  CDuce was compiled without expat support") ::
86
    !specs
87
88


89
90
91
92
let err s =
  prerr_endline s;
  exit 1

93
94
let mode () =
  Arg.parse !specs (fun s -> src := s :: !src) 
95
    "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
96
97
98
99
100
101
  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, _, _        ->
102
	err "Only one CDuce program can be executed at a time"
103
104
    | true,  [o], false, [x], []     -> `Compile (x,Some o) 
    | true,  [], false, [x], []     -> `Compile (x,None) 
105
    | true,  [], false, [], []      ->
106
	err "Please specify the CDuce program to be compiled"
107
    | true,  [], false, _, []       ->
108
	err "Only one CDuce program can be compiled at a time"
109
    | true,  _, false, _, []        ->
110
	err "Please specify only one output directory"
111
    | true,  _, false, _, _        ->
112
	err "No argument can be passed to programs at compile time"
113
114
    | false, _, true,  [x], args   -> `Run (x,args)
    | false, _, true,  [], _       ->
115
	err "Please specifiy the CDuce program to be executed"
116
    | false, _, true,   _, _       ->
117
	err "Only one CDuce program can be executed at a time"
118
    | true, _, true,   _,  _       ->
119
120
	err "The options --compile and --run are incompatible"
	
121

122
123
124

let bol = ref true

125
126
127
let outflush s =
  output_string stdout s;
  flush stdout
128
129

let toploop () =
130
131
132
133
134
135
  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
136
    with Unix.Unix_error (_,_,_) -> 
137
      fun () -> ()
138
139
140
141
142
143
  in
  let quit () = 
    outflush "\n";
    restore ();
    exit 0
  in
144
  Format.fprintf ppf "        CDuce version %s\n@." <:symbol<cduce_version>>;
145
146
147
  Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
  Sys.catch_break true;
  Cduce.toplevel := true;
148
  Location.push_source `Stream;
149
  let read i =
150
    if !bol then 
151
      if !Ulexer.in_comment then outflush "* " else outflush "> ";
152
153
154
155
156
157
    try 
      let c = input_char stdin in
      bol := c = '\n';
      Some c
    with Sys.Break -> quit () 
  in
158
159
  let input = Stream.from read in
  let rec loop () =
160
161
162
163
    outflush "# ";
    bol := false;
    ignore (Cduce.topinput ppf ppf_err input);
    while (input_char stdin != '\n') do () done;
164
    loop () in
165
166
  (try loop () with End_of_file -> ());
  restore ()
167

168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
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;
	   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 = State.get () in
	let chan = open_out_bin f in
	Marshal.to_channel chan s [ Marshal.Closures ];
	close_out chan
    | None -> ()

let main () = 
198
  match mode () with
199
200
201
202
203
204
    | `Toplevel args ->
	restore (argv args);
	toploop ();
	save ()
    | `Script (f,args) ->
	Cduce.compile_run f (argv args)
205
206
    | `Compile (f,o) ->
	Cduce.compile f o
207
208
209
    | `Run (f,args) ->
	Cduce.run f (argv args)
	 
210
211
212
213
214
let () = 
(* Hum... *)
  let b = ref true in
  at_exit (fun () -> if !b then (b := false; main ()));
  at_exit (fun () -> Stats.dump Format.std_formatter)
215

216