Passage a la version bootstrappee (franchissement du Rubicon)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

5 files changed, 214 insertions, 0 deletions

diff --git a/driver/compile.ml b/driver/compile.ml
new file mode 100644
index 0000000000..91ff7e9e21
--- /dev/null
+++ b/driver/compile.ml
@@ -0,0 +1,99 @@
+(* The batch compiler *)
+
+open Misc
+open Config
+open Format
+open Typedtree
+
+(* Initialize the search path.
+   The current directory is always searched first,
+   then the directories specified with the -I option (in command-line order),
+   then the standard library directory. *)
+
+let init_path () =
+  load_path := "" :: List.rev (Config.standard_library :: !Clflags.include_dirs);
+  Env.reset_cache()
+
+(* Return the initial environment in which compilation proceeds. *)
+
+let initial_env () =
+  init_path();
+  try
+    if !Clflags.nopervasives
+    then Env.initial
+    else Env.open_pers_signature "Pervasives" Env.initial
+  with Not_found ->
+    fatal_error "cannot open Pervasives.cmi"
+
+(* Compute the CRC of a file *)
+
+let file_crc ic =
+  seek_in ic 0;
+  Crc.for_channel ic (in_channel_length ic)
+
+(* Compile a .mli file *)
+
+let interface sourcefile =
+  let prefixname = Filename.chop_suffix sourcefile ".mli" in
+  let modulename = capitalize(Filename.basename prefixname) in
+  let ic = open_in_bin sourcefile in
+  let lb = Lexing.from_channel ic in
+  Location.input_name := sourcefile;
+  try
+    let sg = Typemod.transl_signature (initial_env()) (Parse.interface lb) in
+    let crc = file_crc ic in
+    close_in ic;
+    if !Clflags.print_types then (Printtyp.signature sg; print_flush());
+    Env.save_signature sg modulename crc (prefixname ^ ".cmi")
+  with x ->
+    close_in ic;
+    raise x
+
+let print_if flag printer arg =
+  if !flag then begin printer arg; print_newline() end;
+  arg
+
+let implementation sourcefile =
+  let prefixname = Filename.chop_suffix sourcefile ".ml" in
+  let modulename = capitalize(Filename.basename prefixname) in
+  let objfile = prefixname ^ ".cmo" in
+  let ic = open_in_bin sourcefile in
+  let lb = Lexing.from_channel ic in
+  let oc = open_out_bin objfile in
+  Location.input_name := sourcefile;
+  try
+    let (str, sg, finalenv) =
+      Typemod.type_structure (initial_env()) (Parse.implementation lb) in
+    if !Clflags.print_types then (Printtyp.signature sg; print_flush());
+    let (coercion, crc) =
+      if file_exists (prefixname ^ ".mli") then begin
+        let (dclsig, crc) =
+          Env.read_signature modulename (prefixname ^ ".cmi") in
+        (Includemod.signatures Env.initial sg dclsig, crc)
+      end else begin
+        let crc = file_crc ic in
+        Env.save_signature sg modulename crc (prefixname ^ ".cmi");
+        (Tcoerce_none, crc)
+      end in
+    Emitcode.to_file oc modulename crc
+      (print_if Clflags.dump_instr Printinstr.instrlist
+        (Codegen.compile_implementation
+          (print_if Clflags.dump_lambda Printlambda.lambda
+            (Translmod.transl_implementation modulename str coercion))));
+    close_in ic;
+    close_out oc
+  with x ->
+    close_in ic;
+    close_out oc;
+    remove_file objfile;
+    raise x
+
+let c_file name =
+  if Sys.command (concat_strings " " (
+    Config.c_compiler ::
+    "-c" ::
+    List.map (fun dir -> "-I" ^ dir) (List.rev !Clflags.include_dirs) @
+    ("-I" ^ Config.standard_library) ::
+    name ::
+    [])) <> 0
+  then exit 2
diff --git a/driver/compile.mli b/driver/compile.mli
new file mode 100644
index 0000000000..0df7451f36
--- /dev/null
+++ b/driver/compile.mli
@@ -0,0 +1,8 @@
+(* Compile a .ml or .mli file *)
+
+val interface: string -> unit
+val implementation: string -> unit
+val c_file: string -> unit
+
+val initial_env: unit -> Env.t
+val init_path: unit -> unit
diff --git a/driver/errors.ml b/driver/errors.ml
new file mode 100644
index 0000000000..438418125b
--- /dev/null
+++ b/driver/errors.ml
@@ -0,0 +1,42 @@
+(* Error report *)
+
+open Format
+open Location
+
+(* Report an error *)
+
+let report_error exn =
+  open_hovbox 0;
+  begin match exn with
+    Lexer.Error(err, start, stop) ->
+      Location.print {loc_start = start; loc_end = stop};
+      Lexer.report_error err
+  | Parse.Error(start, stop) ->
+      Location.print {loc_start = start; loc_end = stop};
+      print_string "Syntax error"
+  | Env.Error err ->
+      Env.report_error err
+  | Typecore.Error(loc, err) ->
+      Location.print loc; Typecore.report_error err
+  | Typetexp.Error(loc, err) ->
+      Location.print loc; Typetexp.report_error err
+  | Typedecl.Error(loc, err) ->
+      Location.print loc; Typedecl.report_error err
+  | Includemod.Error err ->
+      Includemod.report_error err
+  | Typemod.Error(loc, err) ->
+      Location.print loc; Typemod.report_error err
+  | Translcore.Error(loc, err) ->
+      Location.print loc; Translcore.report_error err
+  | Symtable.Error code ->
+      Symtable.report_error code
+  | Linker.Error code ->
+      Linker.report_error code
+  | Librarian.Error code ->
+      Librarian.report_error code
+  | Sys_error msg ->
+      print_string "I/O error: "; print_string msg
+  | x ->
+      close_box(); raise x
+  end;
+  close_box(); print_newline()
diff --git a/driver/errors.mli b/driver/errors.mli
new file mode 100644
index 0000000000..abe8636153
--- /dev/null
+++ b/driver/errors.mli
@@ -0,0 +1,3 @@
+(* Error report *)
+
+val report_error: exn -> unit
diff --git a/driver/main.ml b/driver/main.ml
new file mode 100644
index 0000000000..d80a105bee
--- /dev/null
+++ b/driver/main.ml
@@ -0,0 +1,62 @@
+open Clflags
+
+let process_file name =
+  if Filename.check_suffix name ".ml" then begin
+    Compile.implementation name;
+    objfiles := (Filename.chop_suffix name ".ml" ^ ".cmo") :: !objfiles
+  end
+  else if Filename.check_suffix name ".mli" then
+    Compile.interface name
+  else if Filename.check_suffix name ".cmo" 
+       or Filename.check_suffix name ".cma" then
+    objfiles := name :: !objfiles
+  else if Filename.check_suffix name ".o"
+       or Filename.check_suffix name ".a" then
+    ccobjs := name :: !ccobjs
+  else if Filename.check_suffix name ".c" then begin
+    Compile.c_file name;
+    ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ".o")
+    :: !ccobjs
+  end
+  else
+    raise(Arg.Bad("don't know what to do with " ^ name))
+
+let print_version_number () =
+  print_string "The Caml Special Light compiler, version ";
+  print_string Config.version;
+  print_newline()
+
+let main () =
+  try
+    Arg.parse
+      ["-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs);
+       "-c", Arg.Unit(fun () -> compile_only := true);
+       "-o", Arg.String(fun s -> exec_name := s; archive_name := s);
+       "-i", Arg.Unit(fun () -> print_types := true);
+       "-a", Arg.Unit(fun () -> make_archive := true);
+       "-fast", Arg.Unit(fun () -> fast := true);
+       "-nopervasives", Arg.Unit(fun () -> nopervasives := true);
+       "-custom", Arg.Unit(fun () -> custom_runtime := true);
+       "-ccopt", Arg.String(fun s -> ccopts := s :: !ccopts);
+       "-l", Arg.String(fun s -> ccobjs := s :: !ccobjs);
+       "-linkall", Arg.Unit(fun s -> link_everything := true);
+       "-dlambda", Arg.Unit(fun () -> dump_lambda := true);
+       "-dinstr", Arg.Unit(fun () -> dump_instr := true);
+       "-v", Arg.Unit print_version_number;
+       "-", Arg.String process_file]
+      process_file;
+    if !make_archive then begin
+      Compile.init_path();
+      Librarian.create_archive (List.rev !objfiles) !archive_name
+    end
+    else if not !compile_only & !objfiles <> [] then begin
+      Compile.init_path();
+      Linker.link (List.rev !objfiles)
+    end;
+    exit 0
+  with x ->
+    Format.set_formatter_output stderr;
+    Errors.report_error x;
+    exit 2
+
+let _ = Printexc.catch main ()