run.ml 6.17 KB
Newer Older
1 2
open Ident

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

7 8
let compile = ref false
let run = ref false
9
let script = ref false
10
let mlstub = ref false
11
let topstub = ref false
12

13
let version () =
14 15 16
  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>>;
17
  Printf.eprintf "Supported features: \n";
18
  List.iter (fun (n,d) -> Printf.eprintf "- %s: %s\n" n d) (Cduce_config.descrs ());
19 20
  exit 0

21
let specs =
22
  [ "--compile", Arg.Set compile,
23
             "compile the given CDuce file";
24 25
    "-c", Arg.Set compile,
      "       same as --compile";
26 27 28 29
    "--run", Arg.Set run,
         "    execute the given .cdo files";
    "--verbose", Arg.Set Cduce.verbose,
             "(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 35
    "--stdin", Arg.Unit (fun () -> src := "" :: !src),
           "  read CDuce script on standard input";
36
    "--arg", Arg.Rest (fun s -> args := s :: !args),
37 38 39 40 41 42
         "    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";
43
    "--no", Arg.String Cduce_config.inhibit,
44
        "     disable a feature (cduce -v to get a list of features)";
45 46
    "--debug", Arg.Unit (fun () -> Stats.set_verbosity Stats.Summary),
           "  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 54
    "--topstub", Arg.Set topstub,
             "produce stub ML code for a toplevel from a primitive file";
55
 ]
56

57
let ppf = Format.std_formatter
58 59
let ppf_err = Format.err_formatter

60 61 62 63
let err s =
  prerr_endline s;
  exit 1

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 68 69
  if (!mlstub) then (
    match !src with [x] -> `Mlstub x | _ ->
      err "Please specify one .cdo file"
70 71 72
  ) else if (!topstub) then (
    match !src with [x] -> `Topstub x | _ ->
      err "Please specify one primitive file"
73
  ) else match (!compile,!out_dir,!run,!src,!args) with
74 75 76 77 78
    | 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, _, _        ->
79
	err "Only one CDuce program can be executed at a time"
80 81
    | true,  [o], false, [x], []     -> `Compile (x,Some o) 
    | 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 91
    | false, _, true,  [x], args   -> `Run (x,args)
    | 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 97
	err "The options --compile and --run are incompatible"
	
98

99 100 101

let bol = ref true

102 103 104
let outflush s =
  output_string stdout s;
  flush stdout
105

106 107 108 109 110 111 112 113 114 115 116 117
let has_newline b =
  let rec loop i found =
    if i >= 1 then
      let c = Buffer.nth b i in
      if c == ';' && Buffer.nth b (i-1) == ';'
      then found
      else loop (i - 1) (c == '\n')
    else false
  in
  loop (Buffer.length b - 1) false


118
let toploop () =
119 120 121 122 123 124
  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
125
    with Unix.Unix_error (_,_,_) -> 
126
      fun () -> ()
127 128 129 130 131 132
  in
  let quit () = 
    outflush "\n";
    restore ();
    exit 0
  in
133
  Format.fprintf ppf "        CDuce version %s\n@." <:symbol<cduce_version>>;
134 135 136
  Sys.set_signal Sys.sigquit (Sys.Signal_handle (fun _ -> quit ()));
  Sys.catch_break true;
  Cduce.toplevel := true;
137
  Librarian.run_loaded := true;
138
  let buf_in = Buffer.create 1024 in
139
  Cduce_loc.push_source (`Buffer buf_in);
140
  let read _i =
141
    if !bol then 
142
      if !Ulexer.in_comment then outflush "* " else outflush "> ";
143 144
    try 
      let c = input_char stdin in
145
      Buffer.add_char buf_in c;
146 147 148 149
      bol := c = '\n';
      Some c
    with Sys.Break -> quit () 
  in
150 151
  let input = Stream.from read in
  let rec loop () =
152 153
    outflush "# ";
    bol := false;
154
    Buffer.clear buf_in;
155
    ignore (Cduce.topinput ppf ppf_err input);
156 157
    if not (has_newline buf_in) then
      (* ";;\n" was eaten by a regular expression in the lexer *)
158
    while (input_char stdin != '\n') do () done;
159
    loop () in
160 161
  (try loop () with End_of_file -> ());
  restore ()
162

163 164 165 166
let argv args = 
  Value.sequence (List.rev_map Value.string_latin1 args)

let main () = 
167
  at_exit (fun () -> Stats.dump Format.std_formatter);
168
  Cduce_loc.set_viewport (Html.create false);
169
  match mode () with
170
    | `Toplevel args ->
171
	Cduce_config.init_all ();
172
	Builtin.argv := argv args;
173
	toploop ()
174
    | `Script (f,args) ->
175
	Cduce_config.init_all ();
176 177
	Builtin.argv := argv args;
	Cduce.compile_run f
178
    | `Compile (f,o) ->
179
	Cduce_config.init_all ();
180
	Cduce.compile f o
181
    | `Run (f,args) ->
182
	Cduce_config.init_all ();
183 184
	Builtin.argv := argv args;
	Cduce.run f
185
    | `Mlstub f ->
186
	Cduce_config.init_all ();
187
	Librarian.prepare_stub f
188
    | `Topstub f ->
189
	Cduce_config.init_all ();
190
	!Librarian.make_wrapper f