summaryrefslogtreecommitdiff
path: root/ocaml-binary-annot/driver
diff options
context:
space:
mode:
Diffstat (limited to 'ocaml-binary-annot/driver')
-rw-r--r--ocaml-binary-annot/driver/compile.ml152
-rw-r--r--ocaml-binary-annot/driver/compile.mli24
-rw-r--r--ocaml-binary-annot/driver/errors.ml81
-rw-r--r--ocaml-binary-annot/driver/errors.mli18
-rw-r--r--ocaml-binary-annot/driver/main.ml204
-rw-r--r--ocaml-binary-annot/driver/main.mli17
-rw-r--r--ocaml-binary-annot/driver/main_args.ml773
-rw-r--r--ocaml-binary-annot/driver/main_args.mli215
-rw-r--r--ocaml-binary-annot/driver/ocamlcomp.sh.in5
-rw-r--r--ocaml-binary-annot/driver/optcompile.ml147
-rw-r--r--ocaml-binary-annot/driver/optcompile.mli24
-rw-r--r--ocaml-binary-annot/driver/opterrors.ml83
-rw-r--r--ocaml-binary-annot/driver/opterrors.mli17
-rw-r--r--ocaml-binary-annot/driver/optmain.ml216
-rw-r--r--ocaml-binary-annot/driver/optmain.mli17
-rw-r--r--ocaml-binary-annot/driver/pparse.ml83
-rw-r--r--ocaml-binary-annot/driver/pparse.mli22
17 files changed, 2098 insertions, 0 deletions
diff --git a/ocaml-binary-annot/driver/compile.ml b/ocaml-binary-annot/driver/compile.ml
new file mode 100644
index 0000000000..4e2d8566ec
--- /dev/null
+++ b/ocaml-binary-annot/driver/compile.ml
@@ -0,0 +1,152 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* 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 (unless the -nostdlib option is given).
+ *)
+
+let init_path () =
+ let dirs =
+ if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs
+ else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs
+ else !Clflags.include_dirs in
+ let exp_dirs =
+ List.map (expand_directory Config.standard_library) dirs in
+ load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
+ Env.reset_cache ()
+
+(* Return the initial environment in which compilation proceeds. *)
+
+(* Note: do not do init_path() in initial_env, this breaks
+ toplevel initialization (PR#1775) *)
+let initial_env () =
+ Ident.reinit();
+ try
+ if !Clflags.nopervasives
+ then Env.initial
+ else Env.open_pers_signature "Pervasives" Env.initial
+ with Not_found ->
+ fatal_error "cannot open pervasives.cmi"
+
+(* Note: this function is duplicated in optcompile.ml *)
+let check_unit_name ppf filename name =
+ try
+ begin match name.[0] with
+ | 'A'..'Z' -> ()
+ | _ ->
+ Location.print_warning (Location.in_file filename) ppf
+ (Warnings.Bad_module_name name);
+ raise Exit;
+ end;
+ for i = 1 to String.length name - 1 do
+ match name.[i] with
+ | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
+ | _ ->
+ Location.print_warning (Location.in_file filename) ppf
+ (Warnings.Bad_module_name name);
+ raise Exit;
+ done;
+ with Exit -> ()
+;;
+
+(* Compile a .mli file *)
+
+let interface ppf sourcefile outputprefix =
+ Location.input_name := sourcefile;
+ init_path ();
+ let modulename =
+ String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ check_unit_name ppf sourcefile modulename;
+ Env.set_unit_name modulename;
+ let inputfile = Pparse.preprocess sourcefile in
+ try
+ let ast =
+ Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
+ if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ let sg = Typemod.transl_signature (initial_env()) ast in
+ if !Clflags.print_types then
+ fprintf std_formatter "%a@." Printtyp.signature
+ (Typemod.simplify_signature sg);
+ Warnings.check_fatal ();
+ if not !Clflags.print_types then
+ Env.save_signature sg modulename (outputprefix ^ ".cmi");
+ Pparse.remove_preprocessed inputfile
+ with e ->
+ Pparse.remove_preprocessed_if_ast inputfile;
+ raise e
+
+(* Compile a .ml file *)
+
+let print_if ppf flag printer arg =
+ if !flag then fprintf ppf "%a@." printer arg;
+ arg
+
+let (++) x f = f x
+
+let implementation ppf sourcefile outputprefix =
+ Location.input_name := sourcefile;
+ init_path ();
+ let modulename =
+ String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ check_unit_name ppf sourcefile modulename;
+ Env.set_unit_name modulename;
+ let inputfile = Pparse.preprocess sourcefile in
+ let env = initial_env() in
+ if !Clflags.print_types then begin
+ try ignore(
+ Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
+ ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ Typemod.type_implementation sourcefile outputprefix modulename env)
+ with x ->
+ Pparse.remove_preprocessed_if_ast inputfile;
+ raise x
+ end else begin
+ let objfile = outputprefix ^ ".cmo" in
+ let oc = open_out_bin objfile in
+ try
+ Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
+ ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ Unused_var.warn ppf
+ ++ Typemod.type_implementation sourcefile outputprefix modulename env
+ ++ Translmod.transl_implementation modulename
+ ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+ ++ Simplif.simplify_lambda
+ ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+ ++ Bytegen.compile_implementation modulename
+ ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
+ ++ Emitcode.to_file oc modulename;
+ Warnings.check_fatal ();
+ close_out oc;
+ Pparse.remove_preprocessed inputfile;
+ Stypes.dump (outputprefix ^ ".annot");
+ with x ->
+ close_out oc;
+ remove_file objfile;
+ Pparse.remove_preprocessed_if_ast inputfile;
+ Stypes.dump (outputprefix ^ ".annot");
+ raise x
+ end
+
+let c_file name =
+ Location.input_name := name;
+ if Ccomp.compile_file name <> 0 then exit 2
diff --git a/ocaml-binary-annot/driver/compile.mli b/ocaml-binary-annot/driver/compile.mli
new file mode 100644
index 0000000000..507d61bbd7
--- /dev/null
+++ b/ocaml-binary-annot/driver/compile.mli
@@ -0,0 +1,24 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Compile a .ml or .mli file *)
+
+open Format
+
+val interface: formatter -> string -> string -> unit
+val implementation: formatter -> string -> string -> unit
+val c_file: string -> unit
+
+val initial_env: unit -> Env.t
+val init_path: unit -> unit
diff --git a/ocaml-binary-annot/driver/errors.ml b/ocaml-binary-annot/driver/errors.ml
new file mode 100644
index 0000000000..22dd1fc6a0
--- /dev/null
+++ b/ocaml-binary-annot/driver/errors.ml
@@ -0,0 +1,81 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* WARNING: if you change something in this file, you must look at
+ opterrors.ml and ocamldoc/odoc_analyse.ml
+ to see if you need to make the same changes there.
+*)
+
+open Format
+
+(* Report an error *)
+
+let report_error ppf exn =
+ let report ppf = function
+ | Lexer.Error(err, loc) ->
+ Location.print_error ppf loc;
+ Lexer.report_error ppf err
+ | Syntaxerr.Error err ->
+ Syntaxerr.report_error ppf err
+ | Pparse.Error ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf "Preprocessor error"
+ | Env.Error err ->
+ Location.print_error_cur_file ppf;
+ Env.report_error ppf err
+ | Ctype.Tags(l, l') ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf
+ "In this program,@ variant constructors@ `%s and `%s@ \
+ have the same hash value.@ Change one of them." l l'
+ | Typecore.Error(loc, err) ->
+ Location.print_error ppf loc; Typecore.report_error ppf err
+ | Typetexp.Error(loc, err) ->
+ Location.print_error ppf loc; Typetexp.report_error ppf err
+ | Typedecl.Error(loc, err) ->
+ Location.print_error ppf loc; Typedecl.report_error ppf err
+ | Typeclass.Error(loc, err) ->
+ Location.print_error ppf loc; Typeclass.report_error ppf err
+ | Includemod.Error err ->
+ Location.print_error_cur_file ppf;
+ Includemod.report_error ppf err
+ | Typemod.Error(loc, err) ->
+ Location.print_error ppf loc; Typemod.report_error ppf err
+ | Translcore.Error(loc, err) ->
+ Location.print_error ppf loc; Translcore.report_error ppf err
+ | Translclass.Error(loc, err) ->
+ Location.print_error ppf loc; Translclass.report_error ppf err
+ | Translmod.Error(loc, err) ->
+ Location.print_error ppf loc; Translmod.report_error ppf err
+ | Symtable.Error code ->
+ Location.print_error_cur_file ppf;
+ Symtable.report_error ppf code
+ | Bytelink.Error code ->
+ Location.print_error_cur_file ppf;
+ Bytelink.report_error ppf code
+ | Bytelibrarian.Error code ->
+ Location.print_error_cur_file ppf;
+ Bytelibrarian.report_error ppf code
+ | Bytepackager.Error code ->
+ Location.print_error_cur_file ppf;
+ Bytepackager.report_error ppf code
+ | Sys_error msg ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf "I/O error: %s" msg
+ | Warnings.Errors (n) ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf "Error-enabled warnings (%d occurrences)" n
+ | x -> fprintf ppf "@]"; raise x in
+
+ fprintf ppf "@[%a@]@." report exn
diff --git a/ocaml-binary-annot/driver/errors.mli b/ocaml-binary-annot/driver/errors.mli
new file mode 100644
index 0000000000..ac203a53ef
--- /dev/null
+++ b/ocaml-binary-annot/driver/errors.mli
@@ -0,0 +1,18 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Error report *)
+open Format
+
+val report_error: formatter -> exn -> unit
diff --git a/ocaml-binary-annot/driver/main.ml b/ocaml-binary-annot/driver/main.ml
new file mode 100644
index 0000000000..09aa89655e
--- /dev/null
+++ b/ocaml-binary-annot/driver/main.ml
@@ -0,0 +1,204 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Config
+open Clflags
+
+let output_prefix name =
+ let oname =
+ match !output_name with
+ | None -> name
+ | Some n -> if !compile_only then (output_name := None; n) else name in
+ Misc.chop_extension_if_any oname
+
+let process_interface_file ppf name =
+ Compile.interface ppf name (output_prefix name)
+
+let process_implementation_file ppf name =
+ let opref = output_prefix name in
+ Compile.implementation ppf name opref;
+ objfiles := (opref ^ ".cmo") :: !objfiles
+
+let process_file ppf name =
+ if Filename.check_suffix name ".ml"
+ || Filename.check_suffix name ".mlt" then begin
+ let opref = output_prefix name in
+ Compile.implementation ppf name opref;
+ objfiles := (opref ^ ".cmo") :: !objfiles
+ end
+ else if Filename.check_suffix name !Config.interface_suffix then begin
+ let opref = output_prefix name in
+ Compile.interface ppf name opref;
+ if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
+ end
+ else if Filename.check_suffix name ".cmo"
+ || Filename.check_suffix name ".cma" then
+ objfiles := name :: !objfiles
+ else if Filename.check_suffix name ".cmi" && !make_package then
+ objfiles := name :: !objfiles
+ else if Filename.check_suffix name ext_obj
+ || Filename.check_suffix name ext_lib then
+ ccobjs := name :: !ccobjs
+ else if Filename.check_suffix name ext_dll then
+ dllibs := name :: !dllibs
+ else if Filename.check_suffix name ".c" then begin
+ Compile.c_file name;
+ ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
+ :: !ccobjs
+ end
+ else
+ raise(Arg.Bad("don't know what to do with " ^ name))
+
+let print_version_and_library () =
+ print_string "The Objective Caml compiler, version ";
+ print_string Config.version; print_newline();
+ print_string "Standard library directory: ";
+ print_string Config.standard_library; print_newline();
+ exit 0
+
+let print_version_string () =
+ print_string Config.version; print_newline(); exit 0
+
+let print_standard_library () =
+ print_string Config.standard_library; print_newline(); exit 0
+
+let usage = "Usage: ocamlc <options> <files>\nOptions are:"
+
+(* Error messages to standard error formatter *)
+let anonymous = process_file Format.err_formatter;;
+let impl = process_implementation_file Format.err_formatter;;
+let intf = process_interface_file Format.err_formatter;;
+
+let show_config () =
+ Config.print_config stdout;
+ exit 0;
+;;
+
+module Options = Main_args.Make_bytecomp_options (struct
+ let set r () = r := true
+ let unset r () = r := false
+ let _a = set make_archive
+ let _annot = set annotations
+ let _c = set compile_only
+ let _cc s = c_compiler := Some s
+ let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
+ let _ccopt s = ccopts := s :: !ccopts
+ let _config = show_config
+ let _custom = set custom_runtime
+ let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs
+ let _dllpath s = dllpaths := !dllpaths @ [s]
+ let _g = set debug
+ let _i () = print_types := true; compile_only := true
+ let _I s = include_dirs := s :: !include_dirs
+ let _impl = impl
+ let _intf = intf
+ let _intf_suffix s = Config.interface_suffix := s
+ let _labels = unset classic
+ let _linkall = set link_everything
+ let _make_runtime () =
+ custom_runtime := true; make_runtime := true; link_everything := true
+ let _no_app_funct = unset applicative_functors
+ let _noassert = set noassert
+ let _nolabels = set classic
+ let _noautolink = set no_auto_link
+ let _nostdlib = set no_std_include
+ let _o s = output_name := Some s
+ let _output_obj () = output_c_object := true; custom_runtime := true
+ let _pack = set make_package
+ let _pp s = preprocessor := Some s
+ let _principal = set principal
+ let _rectypes = set recursive_types
+ let _strict_sequence = set strict_sequence
+ let _thread = set use_threads
+ let _vmthread = set use_vmthreads
+ let _unsafe = set fast
+ let _use_prims s = use_prims := s
+ let _use_runtime s = use_runtime := s
+ let _v = print_version_and_library
+ let _version = print_version_string
+ let _vnum = print_version_string
+ let _w = (Warnings.parse_options false)
+ let _warn_error = (Warnings.parse_options true)
+ let _warn_help = Warnings.help_warnings
+ let _where = print_standard_library
+ let _verbose = set verbose
+ let _nopervasives = set nopervasives
+ let _dparsetree = set dump_parsetree
+ let _drawlambda = set dump_rawlambda
+ let _dlambda = set dump_lambda
+ let _dinstr = set dump_instr
+ let anonymous = anonymous
+end)
+
+let fatal err =
+ prerr_endline err;
+ exit 2
+
+let extract_output = function
+ | Some s -> s
+ | None -> fatal "Please specify the name of the output file, using option -o"
+
+let default_output = function
+ | Some s -> s
+ | None -> Config.default_executable_name
+
+let main () =
+ try
+ Arg.parse Options.list anonymous usage;
+ if
+ List.length (List.filter (fun x -> !x)
+ [make_archive;make_package;compile_only;output_c_object])
+ > 1
+ then
+ if !print_types then
+ fatal "Option -i is incompatible with -pack, -a, -output-obj"
+ else
+ fatal "Please specify at most one of -pack, -a, -c, -output-obj";
+
+ if !make_archive then begin
+ Compile.init_path();
+ Bytelibrarian.create_archive (List.rev !objfiles)
+ (extract_output !output_name)
+ end
+ else if !make_package then begin
+ Compile.init_path();
+ Bytepackager.package_files (List.rev !objfiles)
+ (extract_output !output_name)
+ end
+ else if not !compile_only && !objfiles <> [] then begin
+ let target =
+ if !output_c_object then
+ let s = extract_output !output_name in
+ if (Filename.check_suffix s Config.ext_obj
+ || Filename.check_suffix s Config.ext_dll
+ || Filename.check_suffix s ".c")
+ then s
+ else
+ fatal
+ (Printf.sprintf
+ "The extension of the output file must be .c, %s or %s"
+ Config.ext_obj Config.ext_dll
+ )
+ else
+ default_output !output_name
+ in
+ Compile.init_path();
+ Bytelink.link (List.rev !objfiles) target
+ end;
+ exit 0
+ with x ->
+ Errors.report_error Format.err_formatter x;
+ exit 2
+
+let _ = main ()
diff --git a/ocaml-binary-annot/driver/main.mli b/ocaml-binary-annot/driver/main.mli
new file mode 100644
index 0000000000..d175a3ca26
--- /dev/null
+++ b/ocaml-binary-annot/driver/main.mli
@@ -0,0 +1,17 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(*
+ this "empty" file is here to speed up garbage collection in ocamlc.opt
+*)
diff --git a/ocaml-binary-annot/driver/main_args.ml b/ocaml-binary-annot/driver/main_args.ml
new file mode 100644
index 0000000000..279a46328e
--- /dev/null
+++ b/ocaml-binary-annot/driver/main_args.ml
@@ -0,0 +1,773 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Damien Doligez, projet Para, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+let mk_a f =
+ "-a", Arg.Unit f, " Build a library"
+;;
+
+let mk_annot f =
+ "-annot", Arg.Unit f, " Save information in <filename>.annot"
+;;
+
+let mk_c f =
+ "-c", Arg.Unit f, " Compile only (do not link)"
+;;
+
+let mk_cc f =
+ "-cc", Arg.String f, "<command> Use <command> as the C compiler and linker"
+;;
+
+let mk_cclib f =
+ "-cclib", Arg.String f, "<opt> Pass option <opt> to the C linker"
+;;
+
+let mk_ccopt f =
+ "-ccopt", Arg.String f, "<opt> Pass option <opt> to the C compiler and linker"
+;;
+
+let mk_compact f =
+ "-compact", Arg.Unit f, " Optimize code size rather than speed"
+;;
+
+let mk_config f =
+ "-config", Arg.Unit f, " Print configuration values and exit"
+;;
+
+let mk_custom f =
+ "-custom", Arg.Unit f, " Link in custom mode"
+;;
+
+let mk_dllib f =
+ "-dllib", Arg.String f, "<lib> Use the dynamically-loaded library <lib>"
+;;
+
+let mk_dllpath f =
+ "-dllpath", Arg.String f,
+ "<dir> Add <dir> to the run-time search path for shared libraries"
+;;
+
+let mk_dtypes f =
+ "-dtypes", Arg.Unit f, " (deprecated) same as -annot"
+;;
+
+let mk_for_pack_byt () =
+ "-for-pack", Arg.String ignore,
+ "<ident> Ignored (for compatibility with ocamlopt)"
+;;
+
+let mk_for_pack_opt f =
+ "-for-pack", Arg.String f,
+ "<ident> Generate code that can later be `packed' with\n\
+ \ ocamlopt -pack -o <ident>.cmx"
+;;
+
+let mk_g_byt f =
+ "-g", Arg.Unit f, " Save debugging information"
+;;
+
+let mk_g_opt f =
+ "-g", Arg.Unit f, " Record debugging information for exception backtrace"
+;;
+
+let mk_i f =
+ "-i", Arg.Unit f, " Print inferred interface"
+;;
+
+let mk_I f =
+ "-I", Arg.String f, "<dir> Add <dir> to the list of include directories"
+;;
+
+let mk_impl f =
+ "-impl", Arg.String f, "<file> Compile <file> as a .ml file"
+;;
+
+let mk_init f =
+ "-init", Arg.String f, "<file> Load <file> instead of default init file"
+;;
+
+let mk_inline f =
+ "-inline", Arg.Int f, "<n> Set aggressiveness of inlining to <n>"
+;;
+
+let mk_intf f =
+ "-intf", Arg.String f, "<file> Compile <file> as a .mli file"
+;;
+
+let mk_intf_suffix f =
+ "-intf-suffix", Arg.String f,
+ "<string> Suffix for interface files (default: .mli)"
+;;
+
+let mk_intf_suffix_2 f =
+ "-intf_suffix", Arg.String f, "<string> (deprecated) same as -intf-suffix"
+;;
+
+let mk_labels f =
+ "-labels", Arg.Unit f, " Use commuting label mode"
+;;
+
+let mk_linkall f =
+ "-linkall", Arg.Unit f, " Link all modules, even unused ones"
+;;
+
+let mk_make_runtime f =
+ "-make-runtime", Arg.Unit f,
+ " Build a runtime system with given C objects and libraries"
+;;
+
+let mk_make_runtime_2 f =
+ "-make_runtime", Arg.Unit f, " (deprecated) same as -make-runtime"
+;;
+
+let mk_modern f =
+ "-modern", Arg.Unit f, " (deprecated) same as -labels"
+;;
+
+let mk_no_app_funct f =
+ "-no-app-funct", Arg.Unit f, " Deactivate applicative functors"
+;;
+
+let mk_noassert f =
+ "-noassert", Arg.Unit f, " Do not compile assertion checks"
+;;
+
+let mk_noautolink_byt f =
+ "-noautolink", Arg.Unit f,
+ " Do not automatically link C libraries specified in .cma files"
+;;
+
+let mk_noautolink_opt f =
+ "-noautolink", Arg.Unit f,
+ " Do not automatically link C libraries specified in .cmxa files"
+;;
+
+let mk_nodynlink f =
+ "-nodynlink", Arg.Unit f,
+ " Enable optimizations for code that will not be dynlinked"
+;;
+
+let mk_nolabels f =
+ "-nolabels", Arg.Unit f, " Ignore non-optional labels in types"
+;;
+
+let mk_noprompt f =
+ "-noprompt", Arg.Unit f, " Suppress all prompts"
+;;
+
+let mk_nostdlib f =
+ "-nostdlib", Arg.Unit f,
+ " Do not add default directory to the list of include directories"
+;;
+
+let mk_o f =
+ "-o", Arg.String f, "<file> Set output file name to <file>"
+;;
+
+let mk_output_obj f =
+ "-output-obj", Arg.Unit f, " Output a C object file instead of an executable"
+;;
+
+let mk_p f =
+ "-p", Arg.Unit f,
+ " Compile and link with profiling support for \"gprof\"\n\
+ \ (not supported on all platforms)"
+;;
+
+let mk_pack_byt f =
+ "-pack", Arg.Unit f, " Package the given .cmo files into one .cmo"
+;;
+
+let mk_pack_opt f =
+ "-pack", Arg.Unit f, " Package the given .cmx files into one .cmx"
+;;
+
+let mk_pp f =
+ "-pp", Arg.String f, "<command> Pipe sources through preprocessor <command>"
+;;
+
+let mk_principal f =
+ "-principal", Arg.Unit f, " Check principality of type inference"
+;;
+
+let mk_rectypes f =
+ "-rectypes", Arg.Unit f, " Allow arbitrary recursive types"
+;;
+
+let mk_S f =
+ "-S", Arg.Unit f, " Keep intermediate assembly file"
+;;
+
+let mk_strict_sequence f =
+ "-strict-sequence", Arg.Unit f,
+ " Left-hand part of a sequence must have type unit"
+;;
+
+let mk_shared f =
+ "-shared", Arg.Unit f, " Produce a dynlinkable plugin"
+;;
+
+let mk_thread f =
+ "-thread", Arg.Unit f,
+ " Generate code that supports the system threads library"
+;;
+
+let mk_unsafe f =
+ "-unsafe", Arg.Unit f,
+ " Do not compile bounds checking on array and string access"
+;;
+
+let mk_use_runtime f =
+ "-use-runtime", Arg.String f,
+ "<file> Generate bytecode for the given runtime system"
+;;
+
+let mk_use_runtime_2 f =
+ "-use_runtime", Arg.String f,
+ "<file> (deprecated) same as -use-runtime"
+;;
+
+let mk_v f =
+ "-v", Arg.Unit f,
+ " Print compiler version and location of standard library and exit"
+;;
+
+let mk_version f =
+ "-version", Arg.Unit f, " Print version and exit"
+;;
+
+let mk_vnum f =
+ "-vnum", Arg.Unit f, " Print version number and exit"
+;;
+
+let mk_verbose f =
+ "-verbose", Arg.Unit f, " Print calls to external commands"
+;;
+
+let mk_vmthread f =
+ "-vmthread", Arg.Unit f,
+ " Generate code that supports the threads library with VM-level\n\
+ \ scheduling"
+;;
+
+let mk_w f =
+ "-w", Arg.String f,
+ Printf.sprintf
+ "<list> Enable or disable warnings according to <list>:\n\
+ \ +<spec> enable warnings in <spec>\n\
+ \ -<spec> disable warnings in <spec>\n\
+ \ @<spec> enable warnings in <spec> and treat them as errors\n\
+ \ <spec> can be:\n\
+ \ <num> a single warning number\n\
+ \ <num1>..<num2> a range of consecutive warning numbers\n\
+ \ <letter> a predefined set\n\
+ \ default setting is %S" Warnings.defaults_w
+;;
+
+let mk_warn_error f =
+ "-warn-error", Arg.String f,
+ Printf.sprintf
+ "<list> Enable or disable error status for warnings according\n\
+ \ to <list>. See option -w for the syntax of <list>.\n\
+ \ Default setting is %S" Warnings.defaults_warn_error
+;;
+
+let mk_warn_help f =
+ "-warn-help", Arg.Unit f, " Show description of warning numbers"
+;;
+
+let mk_where f =
+ "-where", Arg.Unit f, " Print location of standard library and exit"
+;;
+
+let mk_nopervasives f =
+ "-nopervasives", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_use_prims f =
+ "-use-prims", Arg.String f, "<file> (undocumented)"
+;;
+
+let mk_dparsetree f =
+ "-dparsetree", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_drawlambda f =
+ "-drawlambda", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dlambda f =
+ "-dlambda", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dinstr f =
+ "-dinstr", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dcmm f =
+ "-dcmm", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dsel f =
+ "-dsel", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dcombine f =
+ "-dcombine", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dlive f =
+ "-dlive", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dspill f =
+ "-dspill", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dsplit f =
+ "-dsplit", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dinterf f =
+ "-dinterf", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dprefer f =
+ "-dprefer", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dalloc f =
+ "-dalloc", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dreload f =
+ "-dreload", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dscheduling f =
+ "-dscheduling", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dlinear f =
+ "-dlinear", Arg.Unit f, " (undocumented)"
+;;
+
+let mk_dstartup f =
+ "-dstartup", Arg.Unit f, " (undocumented)"
+;;
+
+let mk__ f =
+ "-", Arg.String f,
+ "<file> Treat <file> as a file name (even if it starts with `-')"
+;;
+
+module type Bytecomp_options = sig
+ val _a : unit -> unit
+ val _annot : unit -> unit
+ val _c : unit -> unit
+ val _cc : string -> unit
+ val _cclib : string -> unit
+ val _ccopt : string -> unit
+ val _config : unit -> unit
+ val _custom : unit -> unit
+ val _dllib : string -> unit
+ val _dllpath : string -> unit
+ val _g : unit -> unit
+ val _i : unit -> unit
+ val _I : string -> unit
+ val _impl : string -> unit
+ val _intf : string -> unit
+ val _intf_suffix : string -> unit
+ val _labels : unit -> unit
+ val _linkall : unit -> unit
+ val _make_runtime : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _noautolink : unit -> unit
+ val _nolabels : unit -> unit
+ val _nostdlib : unit -> unit
+ val _o : string -> unit
+ val _output_obj : unit -> unit
+ val _pack : unit -> unit
+ val _pp : string -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _thread : unit -> unit
+ val _vmthread : unit -> unit
+ val _unsafe : unit -> unit
+ val _use_runtime : string -> unit
+ val _v : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _verbose : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+ val _where : unit -> unit
+
+ val _nopervasives : unit -> unit
+ val _use_prims : string -> unit
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dinstr : unit -> unit
+
+ val anonymous : string -> unit
+end;;
+
+module type Bytetop_options = sig
+ val _I : string -> unit
+ val _init : string -> unit
+ val _labels : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _nolabels : unit -> unit
+ val _noprompt : unit -> unit
+ val _nostdlib : unit -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _unsafe : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dinstr : unit -> unit
+
+ val anonymous : string -> unit
+end;;
+
+module type Optcomp_options = sig
+ val _a : unit -> unit
+ val _annot : unit -> unit
+ val _c : unit -> unit
+ val _cc : string -> unit
+ val _cclib : string -> unit
+ val _ccopt : string -> unit
+ val _compact : unit -> unit
+ val _config : unit -> unit
+ val _for_pack : string -> unit
+ val _g : unit -> unit
+ val _i : unit -> unit
+ val _I : string -> unit
+ val _impl : string -> unit
+ val _inline : int -> unit
+ val _intf : string -> unit
+ val _intf_suffix : string -> unit
+ val _labels : unit -> unit
+ val _linkall : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _noautolink : unit -> unit
+ val _nodynlink : unit -> unit
+ val _nolabels : unit -> unit
+ val _nostdlib : unit -> unit
+ val _o : string -> unit
+ val _output_obj : unit -> unit
+ val _p : unit -> unit
+ val _pack : unit -> unit
+ val _pp : string -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _shared : unit -> unit
+ val _S : unit -> unit
+ val _thread : unit -> unit
+ val _unsafe : unit -> unit
+ val _v : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _verbose : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+ val _where : unit -> unit
+
+ val _nopervasives : unit -> unit
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dcmm : unit -> unit
+ val _dsel : unit -> unit
+ val _dcombine : unit -> unit
+ val _dlive : unit -> unit
+ val _dspill : unit -> unit
+ val _dsplit : unit -> unit
+ val _dinterf : unit -> unit
+ val _dprefer : unit -> unit
+ val _dalloc : unit -> unit
+ val _dreload : unit -> unit
+ val _dscheduling : unit -> unit
+ val _dlinear : unit -> unit
+ val _dstartup : unit -> unit
+
+ val anonymous : string -> unit
+end;;
+
+module type Opttop_options = sig
+ val _compact : unit -> unit
+ val _I : string -> unit
+ val _init : string -> unit
+ val _inline : int -> unit
+ val _labels : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _nolabels : unit -> unit
+ val _noprompt : unit -> unit
+ val _nostdlib : unit -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _S : unit -> unit
+ val _unsafe : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dcmm : unit -> unit
+ val _dsel : unit -> unit
+ val _dcombine : unit -> unit
+ val _dlive : unit -> unit
+ val _dspill : unit -> unit
+ val _dsplit : unit -> unit
+ val _dinterf : unit -> unit
+ val _dprefer : unit -> unit
+ val _dalloc : unit -> unit
+ val _dreload : unit -> unit
+ val _dscheduling : unit -> unit
+ val _dlinear : unit -> unit
+ val _dstartup : unit -> unit
+
+ val anonymous : string -> unit
+end;;
+
+module type Arg_list = sig
+ val list : (string * Arg.spec * string) list
+end;;
+
+module Make_bytecomp_options (F : Bytecomp_options) =
+struct
+ let list = [
+ mk_a F._a;
+ mk_annot F._annot;
+ mk_c F._c;
+ mk_cc F._cc;
+ mk_cclib F._cclib;
+ mk_ccopt F._ccopt;
+ mk_config F._config;
+ mk_custom F._custom;
+ mk_dllib F._dllib;
+ mk_dllpath F._dllpath;
+ mk_dtypes F._annot;
+ mk_for_pack_byt ();
+ mk_g_byt F._g;
+ mk_i F._i;
+ mk_I F._I;
+ mk_impl F._impl;
+ mk_intf F._intf;
+ mk_intf_suffix F._intf_suffix;
+ mk_intf_suffix_2 F._intf_suffix;
+ mk_labels F._labels;
+ mk_linkall F._linkall;
+ mk_make_runtime F._make_runtime;
+ mk_make_runtime_2 F._make_runtime;
+ mk_modern F._labels;
+ mk_no_app_funct F._no_app_funct;
+ mk_noassert F._noassert;
+ mk_noautolink_byt F._noautolink;
+ mk_nolabels F._nolabels;
+ mk_nostdlib F._nostdlib;
+ mk_o F._o;
+ mk_output_obj F._output_obj;
+ mk_pack_byt F._pack;
+ mk_pp F._pp;
+ mk_principal F._principal;
+ mk_rectypes F._rectypes;
+ mk_strict_sequence F._strict_sequence;
+ mk_thread F._thread;
+ mk_unsafe F._unsafe;
+ mk_use_runtime F._use_runtime;
+ mk_use_runtime_2 F._use_runtime;
+ mk_v F._v;
+ mk_version F._version;
+ mk_vnum F._vnum;
+ mk_verbose F._verbose;
+ mk_vmthread F._vmthread;
+ mk_w F._w;
+ mk_warn_error F._warn_error;
+ mk_warn_help F._warn_help;
+ mk_where F._where;
+
+ mk_nopervasives F._nopervasives;
+ mk_use_prims F._use_prims;
+ mk_dparsetree F._dparsetree;
+ mk_drawlambda F._drawlambda;
+ mk_dlambda F._dlambda;
+ mk_dinstr F._dinstr;
+
+ mk__ F.anonymous;
+ ]
+end;;
+
+module Make_bytetop_options (F : Bytetop_options) =
+struct
+ let list = [
+ mk_I F._I;
+ mk_init F._init;
+ mk_labels F._labels;
+ mk_no_app_funct F._no_app_funct;
+ mk_noassert F._noassert;
+ mk_nolabels F._nolabels;
+ mk_noprompt F._noprompt;
+ mk_nostdlib F._nostdlib;
+ mk_principal F._principal;
+ mk_rectypes F._rectypes;
+ mk_strict_sequence F._strict_sequence;
+ mk_unsafe F._unsafe;
+ mk_version F._version;
+ mk_vnum F._vnum;
+ mk_w F._w;
+ mk_warn_error F._warn_error;
+ mk_warn_help F._warn_help;
+
+ mk_dparsetree F._dparsetree;
+ mk_drawlambda F._drawlambda;
+ mk_dlambda F._dlambda;
+ mk_dinstr F._dinstr;
+
+ mk__ F.anonymous;
+ ]
+end;;
+
+module Make_optcomp_options (F : Optcomp_options) =
+struct
+ let list = [
+ mk_a F._a;
+ mk_annot F._annot;
+ mk_c F._c;
+ mk_cc F._cc;
+ mk_cclib F._cclib;
+ mk_ccopt F._ccopt;
+ mk_compact F._compact;
+ mk_config F._config;
+ mk_dtypes F._annot;
+ mk_for_pack_opt F._for_pack;
+ mk_g_opt F._g;
+ mk_i F._i;
+ mk_I F._I;
+ mk_impl F._impl;
+ mk_inline F._inline;
+ mk_intf F._intf;
+ mk_intf_suffix F._intf_suffix;
+ mk_labels F._labels;
+ mk_linkall F._linkall;
+ mk_no_app_funct F._no_app_funct;
+ mk_noassert F._noassert;
+ mk_noautolink_opt F._noautolink;
+ mk_nodynlink F._nodynlink;
+ mk_nolabels F._nolabels;
+ mk_nostdlib F._nostdlib;
+ mk_o F._o;
+ mk_output_obj F._output_obj;
+ mk_p F._p;
+ mk_pack_opt F._pack;
+ mk_pp F._pp;
+ mk_principal F._principal;
+ mk_rectypes F._rectypes;
+ mk_S F._S;
+ mk_strict_sequence F._strict_sequence;
+ mk_shared F._shared;
+ mk_thread F._thread;
+ mk_unsafe F._unsafe;
+ mk_v F._v;
+ mk_version F._version;
+ mk_vnum F._vnum;
+ mk_verbose F._verbose;
+ mk_w F._w;
+ mk_warn_error F._warn_error;
+ mk_warn_help F._warn_help;
+ mk_where F._where;
+
+ mk_nopervasives F._nopervasives;
+ mk_dparsetree F._dparsetree;
+ mk_drawlambda F._drawlambda;
+ mk_dlambda F._dlambda;
+ mk_dcmm F._dcmm;
+ mk_dsel F._dsel;
+ mk_dcombine F._dcombine;
+ mk_dlive F._dlive;
+ mk_dspill F._dspill;
+ mk_dinterf F._dinterf;
+ mk_dprefer F._dprefer;
+ mk_dalloc F._dalloc;
+ mk_dreload F._dreload;
+ mk_dscheduling F._dscheduling;
+ mk_dlinear F._dlinear;
+ mk_dstartup F._dstartup;
+
+ mk__ F.anonymous;
+ ]
+end;;
+
+module Make_opttop_options (F : Opttop_options) = struct
+ let list = [
+ mk_compact F._compact;
+ mk_I F._I;
+ mk_init F._init;
+ mk_inline F._inline;
+ mk_labels F._labels;
+ mk_no_app_funct F._no_app_funct;
+ mk_noassert F._noassert;
+ mk_nolabels F._nolabels;
+ mk_noprompt F._noprompt;
+ mk_nostdlib F._nostdlib;
+ mk_principal F._principal;
+ mk_rectypes F._rectypes;
+ mk_S F._S;
+ mk_strict_sequence F._strict_sequence;
+ mk_unsafe F._unsafe;
+ mk_version F._version;
+ mk_vnum F._vnum;
+ mk_w F._w;
+ mk_warn_error F._warn_error;
+ mk_warn_help F._warn_help;
+
+ mk_dparsetree F._dparsetree;
+ mk_drawlambda F._drawlambda;
+ mk_dcmm F._dcmm;
+ mk_dsel F._dsel;
+ mk_dcombine F._dcombine;
+ mk_dlive F._dlive;
+ mk_dspill F._dspill;
+ mk_dinterf F._dinterf;
+ mk_dprefer F._dprefer;
+ mk_dalloc F._dalloc;
+ mk_dreload F._dreload;
+ mk_dscheduling F._dscheduling;
+ mk_dlinear F._dlinear;
+ mk_dstartup F._dstartup;
+
+ mk__ F.anonymous;
+ ]
+end;;
diff --git a/ocaml-binary-annot/driver/main_args.mli b/ocaml-binary-annot/driver/main_args.mli
new file mode 100644
index 0000000000..1c4abf5097
--- /dev/null
+++ b/ocaml-binary-annot/driver/main_args.mli
@@ -0,0 +1,215 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Damien Doligez, projet Para, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1998 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+module type Bytecomp_options =
+ sig
+ val _a : unit -> unit
+ val _annot : unit -> unit
+ val _c : unit -> unit
+ val _cc : string -> unit
+ val _cclib : string -> unit
+ val _ccopt : string -> unit
+ val _config : unit -> unit
+ val _custom : unit -> unit
+ val _dllib : string -> unit
+ val _dllpath : string -> unit
+ val _g : unit -> unit
+ val _i : unit -> unit
+ val _I : string -> unit
+ val _impl : string -> unit
+ val _intf : string -> unit
+ val _intf_suffix : string -> unit
+ val _labels : unit -> unit
+ val _linkall : unit -> unit
+ val _make_runtime : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _noautolink : unit -> unit
+ val _nolabels : unit -> unit
+ val _nostdlib : unit -> unit
+ val _o : string -> unit
+ val _output_obj : unit -> unit
+ val _pack : unit -> unit
+ val _pp : string -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _thread : unit -> unit
+ val _vmthread : unit -> unit
+ val _unsafe : unit -> unit
+ val _use_runtime : string -> unit
+ val _v : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _verbose : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+ val _where : unit -> unit
+
+ val _nopervasives : unit -> unit
+ val _use_prims : string -> unit
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dinstr : unit -> unit
+
+ val anonymous : string -> unit
+ end
+;;
+
+module type Bytetop_options = sig
+ val _I : string -> unit
+ val _init : string -> unit
+ val _labels : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _nolabels : unit -> unit
+ val _noprompt : unit -> unit
+ val _nostdlib : unit -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _unsafe : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dinstr : unit -> unit
+
+ val anonymous : string -> unit
+end;;
+
+module type Optcomp_options = sig
+ val _a : unit -> unit
+ val _annot : unit -> unit
+ val _c : unit -> unit
+ val _cc : string -> unit
+ val _cclib : string -> unit
+ val _ccopt : string -> unit
+ val _compact : unit -> unit
+ val _config : unit -> unit
+ val _for_pack : string -> unit
+ val _g : unit -> unit
+ val _i : unit -> unit
+ val _I : string -> unit
+ val _impl : string -> unit
+ val _inline : int -> unit
+ val _intf : string -> unit
+ val _intf_suffix : string -> unit
+ val _labels : unit -> unit
+ val _linkall : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _noautolink : unit -> unit
+ val _nodynlink : unit -> unit
+ val _nolabels : unit -> unit
+ val _nostdlib : unit -> unit
+ val _o : string -> unit
+ val _output_obj : unit -> unit
+ val _p : unit -> unit
+ val _pack : unit -> unit
+ val _pp : string -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _shared : unit -> unit
+ val _S : unit -> unit
+ val _thread : unit -> unit
+ val _unsafe : unit -> unit
+ val _v : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _verbose : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+ val _where : unit -> unit
+
+ val _nopervasives : unit -> unit
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dcmm : unit -> unit
+ val _dsel : unit -> unit
+ val _dcombine : unit -> unit
+ val _dlive : unit -> unit
+ val _dspill : unit -> unit
+ val _dsplit : unit -> unit
+ val _dinterf : unit -> unit
+ val _dprefer : unit -> unit
+ val _dalloc : unit -> unit
+ val _dreload : unit -> unit
+ val _dscheduling : unit -> unit
+ val _dlinear : unit -> unit
+ val _dstartup : unit -> unit
+
+ val anonymous : string -> unit
+end;;
+
+module type Opttop_options = sig
+ val _compact : unit -> unit
+ val _I : string -> unit
+ val _init : string -> unit
+ val _inline : int -> unit
+ val _labels : unit -> unit
+ val _no_app_funct : unit -> unit
+ val _noassert : unit -> unit
+ val _nolabels : unit -> unit
+ val _noprompt : unit -> unit
+ val _nostdlib : unit -> unit
+ val _principal : unit -> unit
+ val _rectypes : unit -> unit
+ val _strict_sequence : unit -> unit
+ val _S : unit -> unit
+ val _unsafe : unit -> unit
+ val _version : unit -> unit
+ val _vnum : unit -> unit
+ val _w : string -> unit
+ val _warn_error : string -> unit
+ val _warn_help : unit -> unit
+
+ val _dparsetree : unit -> unit
+ val _drawlambda : unit -> unit
+ val _dlambda : unit -> unit
+ val _dcmm : unit -> unit
+ val _dsel : unit -> unit
+ val _dcombine : unit -> unit
+ val _dlive : unit -> unit
+ val _dspill : unit -> unit
+ val _dsplit : unit -> unit
+ val _dinterf : unit -> unit
+ val _dprefer : unit -> unit
+ val _dalloc : unit -> unit
+ val _dreload : unit -> unit
+ val _dscheduling : unit -> unit
+ val _dlinear : unit -> unit
+ val _dstartup : unit -> unit
+
+ val anonymous : string -> unit
+end;;
+
+module type Arg_list = sig
+ val list : (string * Arg.spec * string) list
+end;;
+
+module Make_bytecomp_options (F : Bytecomp_options) : Arg_list;;
+module Make_bytetop_options (F : Bytetop_options) : Arg_list;;
+module Make_optcomp_options (F : Optcomp_options) : Arg_list;;
+module Make_opttop_options (F : Opttop_options) : Arg_list;;
diff --git a/ocaml-binary-annot/driver/ocamlcomp.sh.in b/ocaml-binary-annot/driver/ocamlcomp.sh.in
new file mode 100644
index 0000000000..2aeb2de20b
--- /dev/null
+++ b/ocaml-binary-annot/driver/ocamlcomp.sh.in
@@ -0,0 +1,5 @@
+#!/bin/sh
+
+topdir=`dirname $0`
+
+exec @compiler@ -nostdlib -I $topdir/stdlib "$@"
diff --git a/ocaml-binary-annot/driver/optcompile.ml b/ocaml-binary-annot/driver/optcompile.ml
new file mode 100644
index 0000000000..29afc628dc
--- /dev/null
+++ b/ocaml-binary-annot/driver/optcompile.ml
@@ -0,0 +1,147 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* 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 () =
+ let dirs =
+ if !Clflags.use_threads
+ then "+threads" :: !Clflags.include_dirs
+ else !Clflags.include_dirs in
+ let exp_dirs =
+ List.map (expand_directory Config.standard_library) dirs in
+ load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
+ Env.reset_cache ()
+
+(* Return the initial environment in which compilation proceeds. *)
+
+let initial_env () =
+ Ident.reinit();
+ try
+ if !Clflags.nopervasives
+ then Env.initial
+ else Env.open_pers_signature "Pervasives" Env.initial
+ with Not_found ->
+ fatal_error "cannot open pervasives.cmi"
+
+(* Note: this function is duplicated in compile.ml *)
+let check_unit_name ppf filename name =
+ try
+ begin match name.[0] with
+ | 'A'..'Z' -> ()
+ | _ ->
+ Location.print_warning (Location.in_file filename) ppf
+ (Warnings.Bad_module_name name);
+ raise Exit;
+ end;
+ for i = 1 to String.length name - 1 do
+ match name.[i] with
+ | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> ()
+ | _ ->
+ Location.print_warning (Location.in_file filename) ppf
+ (Warnings.Bad_module_name name);
+ raise Exit;
+ done;
+ with Exit -> ()
+;;
+
+(* Compile a .mli file *)
+
+let interface ppf sourcefile outputprefix =
+ Location.input_name := sourcefile;
+ init_path ();
+ let modulename =
+ String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ check_unit_name ppf sourcefile modulename;
+ Env.set_unit_name modulename;
+ let inputfile = Pparse.preprocess sourcefile in
+ try
+ let ast =
+ Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in
+ if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
+ let sg = Typemod.transl_signature (initial_env()) ast in
+ if !Clflags.print_types then
+ fprintf std_formatter "%a@." Printtyp.signature
+ (Typemod.simplify_signature sg);
+ Warnings.check_fatal ();
+ if not !Clflags.print_types then
+ Env.save_signature sg modulename (outputprefix ^ ".cmi");
+ Pparse.remove_preprocessed inputfile;
+ Stypes.dump (outputprefix ^ ".annot");
+ with e ->
+ Pparse.remove_preprocessed_if_ast inputfile;
+ Stypes.dump (outputprefix ^ ".annot");
+ raise e
+
+(* Compile a .ml file *)
+
+let print_if ppf flag printer arg =
+ if !flag then fprintf ppf "%a@." printer arg;
+ arg
+
+let (++) x f = f x
+let (+++) (x, y) f = (x, f y)
+
+let implementation ppf sourcefile outputprefix =
+ Location.input_name := sourcefile;
+ init_path ();
+ let modulename =
+ String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in
+ check_unit_name ppf sourcefile modulename;
+ Env.set_unit_name modulename;
+ let inputfile = Pparse.preprocess sourcefile in
+ let env = initial_env() in
+ Compilenv.reset ?packname:!Clflags.for_package modulename;
+ let cmxfile = outputprefix ^ ".cmx" in
+ let objfile = outputprefix ^ ext_obj in
+ try
+ if !Clflags.print_types then ignore(
+ Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
+ ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ Unused_var.warn ppf
+ ++ Typemod.type_implementation sourcefile outputprefix modulename env)
+ else begin
+ Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
+ ++ print_if ppf Clflags.dump_parsetree Printast.implementation
+ ++ Unused_var.warn ppf
+ ++ Typemod.type_implementation sourcefile outputprefix modulename env
+ ++ Translmod.transl_store_implementation modulename
+ +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+ +++ Simplif.simplify_lambda
+ +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+ ++ Asmgen.compile_implementation outputprefix ppf;
+ Compilenv.save_unit_info cmxfile;
+ end;
+ Warnings.check_fatal ();
+ Pparse.remove_preprocessed inputfile;
+ Stypes.dump (outputprefix ^ ".annot");
+ with x ->
+ remove_file objfile;
+ remove_file cmxfile;
+ Pparse.remove_preprocessed_if_ast inputfile;
+ Stypes.dump (outputprefix ^ ".annot");
+ raise x
+
+let c_file name =
+ if Ccomp.compile_file name <> 0 then exit 2
diff --git a/ocaml-binary-annot/driver/optcompile.mli b/ocaml-binary-annot/driver/optcompile.mli
new file mode 100644
index 0000000000..507d61bbd7
--- /dev/null
+++ b/ocaml-binary-annot/driver/optcompile.mli
@@ -0,0 +1,24 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Compile a .ml or .mli file *)
+
+open Format
+
+val interface: formatter -> string -> string -> unit
+val implementation: formatter -> string -> string -> unit
+val c_file: string -> unit
+
+val initial_env: unit -> Env.t
+val init_path: unit -> unit
diff --git a/ocaml-binary-annot/driver/opterrors.ml b/ocaml-binary-annot/driver/opterrors.ml
new file mode 100644
index 0000000000..581781997d
--- /dev/null
+++ b/ocaml-binary-annot/driver/opterrors.ml
@@ -0,0 +1,83 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* WARNING: if you change something in this file, you must look at
+ errors.ml to see if you need to make the same changes there.
+*)
+
+open Format
+
+(* Report an error *)
+
+let report_error ppf exn =
+ let report ppf = function
+ | Lexer.Error(err, l) ->
+ Location.print_error ppf l;
+ Lexer.report_error ppf err
+ | Syntaxerr.Error err ->
+ Syntaxerr.report_error ppf err
+ | Pparse.Error ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf "Preprocessor error"
+ | Env.Error err ->
+ Location.print_error_cur_file ppf;
+ Env.report_error ppf err
+ | Ctype.Tags(l, l') ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf
+ "In this program,@ variant constructors@ `%s and `%s@ \
+ have the same hash value.@ Change one of them." l l'
+ | Typecore.Error(loc, err) ->
+ Location.print_error ppf loc; Typecore.report_error ppf err
+ | Typetexp.Error(loc, err) ->
+ Location.print_error ppf loc; Typetexp.report_error ppf err
+ | Typedecl.Error(loc, err) ->
+ Location.print_error ppf loc; Typedecl.report_error ppf err
+ | Typeclass.Error(loc, err) ->
+ Location.print_error ppf loc; Typeclass.report_error ppf err
+ | Includemod.Error err ->
+ Location.print_error_cur_file ppf;
+ Includemod.report_error ppf err
+ | Typemod.Error(loc, err) ->
+ Location.print_error ppf loc; Typemod.report_error ppf err
+ | Translcore.Error(loc, err) ->
+ Location.print_error ppf loc; Translcore.report_error ppf err
+ | Translclass.Error(loc, err) ->
+ Location.print_error ppf loc; Translclass.report_error ppf err
+ | Translmod.Error(loc, err) ->
+ Location.print_error ppf loc; Translmod.report_error ppf err
+ | Compilenv.Error code ->
+ Location.print_error_cur_file ppf;
+ Compilenv.report_error ppf code
+ | Asmgen.Error code ->
+ Location.print_error_cur_file ppf;
+ Asmgen.report_error ppf code
+ | Asmlink.Error code ->
+ Location.print_error_cur_file ppf;
+ Asmlink.report_error ppf code
+ | Asmlibrarian.Error code ->
+ Location.print_error_cur_file ppf;
+ Asmlibrarian.report_error ppf code
+ | Asmpackager.Error code ->
+ Location.print_error_cur_file ppf;
+ Asmpackager.report_error ppf code
+ | Sys_error msg ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf "I/O error: %s" msg
+ | Warnings.Errors (n) ->
+ Location.print_error_cur_file ppf;
+ fprintf ppf "Error-enabled warnings (%d occurrences)" n
+ | x -> fprintf ppf "@]"; raise x in
+
+ fprintf ppf "@[%a@]@." report exn
diff --git a/ocaml-binary-annot/driver/opterrors.mli b/ocaml-binary-annot/driver/opterrors.mli
new file mode 100644
index 0000000000..d09dc733b6
--- /dev/null
+++ b/ocaml-binary-annot/driver/opterrors.mli
@@ -0,0 +1,17 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Error report *)
+
+val report_error: Format.formatter -> exn -> unit
diff --git a/ocaml-binary-annot/driver/optmain.ml b/ocaml-binary-annot/driver/optmain.ml
new file mode 100644
index 0000000000..1c7352c527
--- /dev/null
+++ b/ocaml-binary-annot/driver/optmain.ml
@@ -0,0 +1,216 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Config
+open Clflags
+
+let output_prefix name =
+ let oname =
+ match !output_name with
+ | None -> name
+ | Some n -> if !compile_only then (output_name := None; n) else name in
+ Misc.chop_extension_if_any oname
+
+let process_interface_file ppf name =
+ Optcompile.interface ppf name (output_prefix name)
+
+let process_implementation_file ppf name =
+ let opref = output_prefix name in
+ Optcompile.implementation ppf name opref;
+ objfiles := (opref ^ ".cmx") :: !objfiles
+
+let process_file ppf name =
+ if Filename.check_suffix name ".ml"
+ || Filename.check_suffix name ".mlt" then
+ process_implementation_file ppf name
+ else if Filename.check_suffix name !Config.interface_suffix then begin
+ let opref = output_prefix name in
+ Optcompile.interface ppf name opref;
+ if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
+ end
+ else if Filename.check_suffix name ".cmx"
+ || Filename.check_suffix name ".cmxa" then
+ objfiles := name :: !objfiles
+ else if Filename.check_suffix name ".cmi" && !make_package then
+ objfiles := name :: !objfiles
+ else if Filename.check_suffix name ext_obj
+ || Filename.check_suffix name ext_lib then
+ ccobjs := name :: !ccobjs
+ else if Filename.check_suffix name ".c" then begin
+ Optcompile.c_file name;
+ ccobjs := (Filename.chop_suffix (Filename.basename name) ".c" ^ ext_obj)
+ :: !ccobjs
+ end
+ else
+ raise(Arg.Bad("don't know what to do with " ^ name))
+
+let print_version_and_library () =
+ print_string "The Objective Caml native-code compiler, version ";
+ print_string Config.version; print_newline();
+ print_string "Standard library directory: ";
+ print_string Config.standard_library; print_newline();
+ exit 0
+
+let print_version_string () =
+ print_string Config.version; print_newline(); exit 0
+
+let print_standard_library () =
+ print_string Config.standard_library; print_newline(); exit 0
+
+let fatal err =
+ prerr_endline err;
+ exit 2
+
+let extract_output = function
+ | Some s -> s
+ | None ->
+ fatal "Please specify the name of the output file, using option -o"
+
+let default_output = function
+ | Some s -> s
+ | None -> Config.default_executable_name
+
+let usage = "Usage: ocamlopt <options> <files>\nOptions are:"
+
+(* Error messages to standard error formatter *)
+let anonymous = process_file Format.err_formatter;;
+let impl = process_implementation_file Format.err_formatter;;
+let intf = process_interface_file Format.err_formatter;;
+
+let show_config () =
+ Config.print_config stdout;
+ exit 0;
+;;
+
+module Options = Main_args.Make_optcomp_options (struct
+ let set r () = r := true
+ let clear r () = r := false
+
+ let _a = set make_archive
+ let _annot = set annotations
+ let _c = set compile_only
+ let _cc s = c_compiler := Some s
+ let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
+ let _ccopt s = ccopts := s :: !ccopts
+ let _compact = clear optimize_for_speed
+ let _config () = show_config ()
+ let _for_pack s = for_package := Some s
+ let _g = set debug
+ let _i () = print_types := true; compile_only := true
+ let _I dir = include_dirs := dir :: !include_dirs
+ let _impl = impl
+ let _inline n = inline_threshold := n * 8
+ let _intf = intf
+ let _intf_suffix s = Config.interface_suffix := s
+ let _labels = clear classic
+ let _linkall = set link_everything
+ let _no_app_funct = clear applicative_functors
+ let _noassert = set noassert
+ let _noautolink = set no_auto_link
+ let _nodynlink = clear dlcode
+ let _nolabels = set classic
+ let _nostdlib = set no_std_include
+ let _o s = output_name := Some s
+ let _output_obj = set output_c_object
+ let _p = set gprofile
+ let _pack = set make_package
+ let _pp s = preprocessor := Some s
+ let _principal = set principal
+ let _rectypes = set recursive_types
+ let _strict_sequence = set strict_sequence
+ let _shared () = shared := true; dlcode := true
+ let _S = set keep_asm_file
+ let _thread = set use_threads
+ let _unsafe = set fast
+ let _v () = print_version_and_library ()
+ let _version () = print_version_string ()
+ let _vnum () = print_version_string ()
+ let _verbose = set verbose
+ let _w s = Warnings.parse_options false s
+ let _warn_error s = Warnings.parse_options true s
+ let _warn_help = Warnings.help_warnings
+ let _where () = print_standard_library ()
+
+ let _nopervasives = set nopervasives
+ let _dparsetree = set dump_parsetree
+ let _drawlambda = set dump_rawlambda
+ let _dlambda = set dump_lambda
+ let _dcmm = set dump_cmm
+ let _dsel = set dump_selection
+ let _dcombine = set dump_combine
+ let _dlive () = dump_live := true; Printmach.print_live := true
+ let _dspill = set dump_spill
+ let _dsplit = set dump_split
+ let _dinterf = set dump_interf
+ let _dprefer = set dump_prefer
+ let _dalloc = set dump_regalloc
+ let _dreload = set dump_reload
+ let _dscheduling = set dump_scheduling
+ let _dlinear = set dump_linear
+ let _dstartup = set keep_startup_file
+
+ let anonymous = anonymous
+end);;
+
+let main () =
+ native_code := true;
+ let ppf = Format.err_formatter in
+ try
+ Arg.parse (Arch.command_line_options @ Options.list) anonymous usage;
+ if
+ List.length (List.filter (fun x -> !x)
+ [make_package; make_archive; shared;
+ compile_only; output_c_object]) > 1
+ then
+ fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj";
+ if !make_archive then begin
+ Optcompile.init_path();
+ let target = extract_output !output_name in
+ Asmlibrarian.create_archive (List.rev !objfiles) target;
+ end
+ else if !make_package then begin
+ Optcompile.init_path();
+ let target = extract_output !output_name in
+ Asmpackager.package_files ppf (List.rev !objfiles) target;
+ end
+ else if !shared then begin
+ Optcompile.init_path();
+ let target = extract_output !output_name in
+ Asmlink.link_shared ppf (List.rev !objfiles) target;
+ end
+ else if not !compile_only && !objfiles <> [] then begin
+ let target =
+ if !output_c_object then
+ let s = extract_output !output_name in
+ if (Filename.check_suffix s Config.ext_obj
+ || Filename.check_suffix s Config.ext_dll)
+ then s
+ else
+ fatal
+ (Printf.sprintf
+ "The extension of the output file must be %s or %s"
+ Config.ext_obj Config.ext_dll
+ )
+ else
+ default_output !output_name
+ in
+ Optcompile.init_path();
+ Asmlink.link ppf (List.rev !objfiles) target
+ end;
+ exit 0
+ with x ->
+ Opterrors.report_error ppf x;
+ exit 2
+
+let _ = main ()
diff --git a/ocaml-binary-annot/driver/optmain.mli b/ocaml-binary-annot/driver/optmain.mli
new file mode 100644
index 0000000000..628d2d398b
--- /dev/null
+++ b/ocaml-binary-annot/driver/optmain.mli
@@ -0,0 +1,17 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Damien Doligez, projet Moscova, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2000 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(*
+ this "empty" file is here to speed up garbage collection in ocamlopt.opt
+*)
diff --git a/ocaml-binary-annot/driver/pparse.ml b/ocaml-binary-annot/driver/pparse.ml
new file mode 100644
index 0000000000..0622ddad9f
--- /dev/null
+++ b/ocaml-binary-annot/driver/pparse.ml
@@ -0,0 +1,83 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Format
+
+exception Error
+
+(* Optionally preprocess a source file *)
+
+let preprocess sourcefile =
+ match !Clflags.preprocessor with
+ None -> sourcefile
+ | Some pp ->
+ let tmpfile = Filename.temp_file "camlpp" "" in
+ let comm = Printf.sprintf "%s %s > %s"
+ pp (Filename.quote sourcefile) tmpfile
+ in
+ if Ccomp.command comm <> 0 then begin
+ Misc.remove_file tmpfile;
+ raise Error;
+ end;
+ tmpfile
+
+let remove_preprocessed inputfile =
+ match !Clflags.preprocessor with
+ None -> ()
+ | Some _ -> Misc.remove_file inputfile
+
+let remove_preprocessed_if_ast inputfile =
+ match !Clflags.preprocessor with
+ None -> ()
+ | Some _ ->
+ if inputfile <> !Location.input_name then Misc.remove_file inputfile
+
+(* Parse a file or get a dumped syntax tree in it *)
+
+exception Outdated_version
+
+let file ppf inputfile parse_fun ast_magic =
+ let ic = open_in_bin inputfile in
+ let is_ast_file =
+ try
+ let buffer = String.create (String.length ast_magic) in
+ really_input ic buffer 0 (String.length ast_magic);
+ if buffer = ast_magic then true
+ else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
+ raise Outdated_version
+ else false
+ with
+ Outdated_version ->
+ Misc.fatal_error "Ocaml and preprocessor have incompatible versions"
+ | _ -> false
+ in
+ let ast =
+ try
+ if is_ast_file then begin
+ if !Clflags.fast then
+ fprintf ppf "@[Warning: %s@]@."
+ "option -unsafe used with a preprocessor returning a syntax tree";
+ Location.input_name := input_value ic;
+ input_value ic
+ end else begin
+ seek_in ic 0;
+ Location.input_name := inputfile;
+ let lexbuf = Lexing.from_channel ic in
+ Location.init lexbuf inputfile;
+ parse_fun lexbuf
+ end
+ with x -> close_in ic; raise x
+ in
+ close_in ic;
+ ast
diff --git a/ocaml-binary-annot/driver/pparse.mli b/ocaml-binary-annot/driver/pparse.mli
new file mode 100644
index 0000000000..0ed0391360
--- /dev/null
+++ b/ocaml-binary-annot/driver/pparse.mli
@@ -0,0 +1,22 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2002 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Format
+
+exception Error
+
+val preprocess : string -> string
+val remove_preprocessed : string -> unit
+val remove_preprocessed_if_ast : string -> unit
+val file : formatter -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a
View Lorry Controller Status