run.ml 6.2 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
let version () =
16
17
18
  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>>;
19
20
  Printf.eprintf "Supported features: \n";
  List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Config.descrs ());
21
22
23
24
25
26
27
28
  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
"; 
29
30
  exit 0

31
32
let specs = ref
  [ "--compile", Arg.Set compile,
33
             "compile the given CDuce file";
34
35
36
37
    "--run", Arg.Set run,
         "    execute the given .cdo files";
    "--verbose", Arg.Set Cduce.verbose,
             "(for --compile) show types of exported values";
38
    "--obj-dir",  Arg.String (fun s -> out_dir := s :: !out_dir),
39
             "(for --compile) directory for the compiled .cdo file";
40
    "-I", Arg.String (fun s -> Librarian.obj_path := s::!Librarian.obj_path),
41
      "       add one directory to the lookup path for .cdo and .cmi files";
42
43
    "--stdin", Arg.Unit (fun () -> src := "" :: !src),
           "  read CDuce script on standard input";
44
45
46
47

    "--arg", Arg.Rest (fun s -> args := s :: !args),
         "    following arguments are passed to the CDuce program";  

48
49
    "--no", Arg.String Config.inhibit,
        "     disable a feature (cduce -v to get a list of features)";
50
51
    "--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
           "  print profiling/debugging information";
52
    "-v", Arg.Unit version,
53
      "       print CDuce version, and list built-in optional features";
54
    "--version", Arg.Unit version,
55
             "print CDuce version, and list built-in optional features";
56
57
    "--license", Arg.Unit license,
             "print CDuce license";
58
59
60
61
62
63
64
65

    "--dump", Arg.String (fun s -> save_dump := Some s; load_dump := Some s), 
          "   (deprecated) specify persistency file for loading and saving";
    "--load", Arg.String (fun s -> load_dump := Some s), 
          "   (deprecated) load persistency file before running CDuce program";
    "--save", Arg.String (fun s -> save_dump := Some s), 
          "   (deprecated) save persistency file after running CDuce program";

66

67
 ]
68

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

72
73
74
75
let err s =
  prerr_endline s;
  exit 1

76
77
let mode () =
  Arg.parse !specs (fun s -> src := s :: !src) 
78
    "Usage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:";
79
80
81
82
83
84
  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, _, _        ->
85
	err "Only one CDuce program can be executed at a time"
86
87
    | true,  [o], false, [x], []     -> `Compile (x,Some o) 
    | true,  [], false, [x], []     -> `Compile (x,None) 
88
    | true,  [], false, [], []      ->
89
	err "Please specify the CDuce program to be compiled"
90
    | true,  [], false, _, []       ->
91
	err "Only one CDuce program can be compiled at a time"
92
    | true,  _, false, _, []        ->
93
	err "Please specify only one output directory"
94
    | true,  _, false, _, _        ->
95
	err "No argument can be passed to programs at compile time"
96
97
    | false, _, true,  [x], args   -> `Run (x,args)
    | false, _, true,  [], _       ->
98
	err "Please specifiy the CDuce program to be executed"
99
    | false, _, true,   _, _       ->
100
	err "Only one CDuce program can be executed at a time"
101
    | true, _, true,   _,  _       ->
102
103
	err "The options --compile and --run are incompatible"
	
104

105
106
107

let bol = ref true

108
109
110
let outflush s =
  output_string stdout s;
  flush stdout
111
112

let toploop () =
113
114
115
116
117
118
  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
119
    with Unix.Unix_error (_,_,_) -> 
120
      fun () -> ()
121
122
123
124
125
126
  in
  let quit () = 
    outflush "\n";
    restore ();
    exit 0
  in
127
  Format.fprintf ppf "        CDuce version %s\n@." <:symbol<cduce_version>>;
128
129
130
  Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
  Sys.catch_break true;
  Cduce.toplevel := true;
131
  Location.push_source `Stream;
132
  let read i =
133
    if !bol then 
134
      if !Ulexer.in_comment then outflush "* " else outflush "> ";
135
136
137
138
139
140
    try 
      let c = input_char stdin in
      bol := c = '\n';
      Some c
    with Sys.Break -> quit () 
  in
141
142
  let input = Stream.from read in
  let rec loop () =
143
144
145
146
    outflush "# ";
    bol := false;
    ignore (Cduce.topinput ppf ppf_err input);
    while (input_char stdin != '\n') do () done;
147
    loop () in
148
149
  (try loop () with End_of_file -> ());
  restore ()
150

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

154
let restore () =
155
156
157
158
159
160
161
162
163
164
165
166
  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 -> 
167
	()
168
169
170
171
172
173
174
175
176
177
178
179

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 () = 
180
  match mode () with
181
    | `Toplevel args ->
182
183
	Config.inhibit "ocaml";
	Config.init_all ();
184
185
	Builtin.argv := argv args;
	restore ();
186
187
188
	toploop ();
	save ()
    | `Script (f,args) ->
189
	Config.init_all ();
190
191
	Builtin.argv := argv args;
	Cduce.compile_run f
192
    | `Compile (f,o) ->
193
	Config.init_all ();
194
	Cduce.compile f o
195
    | `Run (f,args) ->
196
	Config.init_all ();
197
198
	Builtin.argv := argv args;
	Cduce.run f
199
	 
200
201
202
203
204
let () = 
(* Hum... *)
  let b = ref true in
  at_exit (fun () -> if !b then (b := false; main ()));
  at_exit (fun () -> Stats.dump Format.std_formatter)
205

206