run.ml 5.12 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 src  = ref []
9
let args = ref []
10

11
let version () =
12
13
14
  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>>;
15
  Printf.eprintf "support for expat: %b\n" (Load_xml.expat_support);
16
17
18
19
20
21
22
23
  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
"; 
24
25
  exit 0

26
let specs =
27
28
29
30
31
32
  [ "--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";
33
34
    "--quiet", Arg.Set Cduce.quiet, 
           "  suppress normal output (typing, results)";
35
36
    "--stdin", Arg.Unit (fun () -> src := "" :: !src),
           "  read CDuce script on standard input";
37
38
    "--verbose", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
             "print profiling/debugging information";
39
    "-v", Arg.Unit version,
40
      "       print CDuce version";
41
    "--version", Arg.Unit version,
42
43
44
             "print CDuce version";
    "--license", Arg.Unit license,
             "print CDuce license";
45
   "--arg", Arg.Rest (fun s -> args := s :: !args),
46
         "    following arguments are passed to the CDuce program (in argv)";  
47

48
 ]
49

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

55
56
57
58
59
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),
60
           "    use PXP parser") ::
61
62
    specs
  else
63
    ("--expat", Arg.Unit (fun () -> (Format.fprintf ppf  "WARNING: --expat unused option. CDuce compiled without expat support\n\n")),
64
             "  option not available: CDuce was compiled without expat support") ::
65
    ("--pxp", Arg.Unit (fun () -> (Format.fprintf ppf  "WARNING: --pxp useless option. CDuce compiled without expat support\n\n")),
66
           "    useless option:  CDuce was compiled without expat support") ::
67
68
69
    specs


70
71
let () =
  Arg.parse specs (fun s -> src := s :: !src) 
72
    "\nUsage:\ncduce [OPTIONS ...] [FILE ...] [--arg argument ...]\n\nOptions:"
73

74
75
76

let bol = ref true

77
78
79
let outflush s =
  output_string stdout s;
  flush stdout
80
81

let toploop () =
82
  Cduce.toplevel := true;
83
84
85
86
87
88
  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
89
    with Unix.Unix_error (_,_,_) -> 
90
      fun () -> ()
91
92
93
94
95
96
  in
  let quit () = 
    outflush "\n";
    restore ();
    exit 0
  in
97
  Format.fprintf ppf "        CDuce version %s\n@." <:symbol<cduce_version>>;
98
99
100
  Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
  Sys.catch_break true;
  Cduce.toplevel := true;
101
  Location.push_source `Stream;
102
  let read i =
103
    if !bol then 
104
      if !Ulexer.in_comment then outflush "* " else outflush "> ";
105
106
107
108
109
110
    try 
      let c = input_char stdin in
      bol := c = '\n';
      Some c
    with Sys.Break -> quit () 
  in
111
112
  let input = Stream.from read in
  let rec loop () =
113
114
115
116
    outflush "# ";
    bol := false;
    ignore (Cduce.topinput ppf ppf_err input);
    while (input_char stdin != '\n') do () done;
117
    loop () in
118
119
  (try loop () with End_of_file -> ());
  restore ()
120

121
let do_file s =
122
123
  let chan = open_in s in
  Location.push_source (`File s);
124
  let input = Stream.of_channel chan in
125
126
127
  let ok = Cduce.script ppf ppf_err input in
  close_in chan;
  if not ok then exit 1
128

129
130
131
132
133
134
135
136
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
137
138

let main () =
139
  (match !load_dump with
140
141
142
143
144
145
146
147
148
149
     | 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 ...@.")
150
151
152
153
     | None -> 
	 let l = List.rev_map Value.string_latin1 !args in
	 let l = Value.sequence l in
	 let t = Sequence.star Sequence.string in
154
	 Cduce.enter_global_value (ident (U.mk "argv")) l t
155
  );
156
  (match !src with
157
     | [] -> toploop ()
158
     | l -> List.iter run l);
159
  (match !save_dump with
160
161
162
163
164
165
166
167
168
169
     | 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 -> ())



170
171
172
173
let () = 
  at_exit (fun () -> Stats.dump Format.std_formatter);
  main ()

174