1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *)
(* *)
(* Copyright 2013 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
open Clflags
exception Exit_with_status of int
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
Filename.remove_extension oname
let print_version_and_library compiler =
Printf.printf "The OCaml %s, version " compiler;
print_string Config.version; print_newline();
print_string "Standard library directory: ";
print_string Config.standard_library; print_newline();
raise (Exit_with_status 0)
let print_version_string () =
print_string Config.version; print_newline();
raise (Exit_with_status 0)
let print_standard_library () =
print_string Config.standard_library; print_newline();
raise (Exit_with_status 0)
let fatal err =
prerr_endline err;
raise (Exit_with_status 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 first_include_dirs = ref []
let last_include_dirs = ref []
let first_ccopts = ref []
let last_ccopts = ref []
let first_ppx = ref []
let last_ppx = ref []
let first_objfiles = ref []
let last_objfiles = ref []
let stop_early = ref false
type filename = string
type readenv_position =
Before_args | Before_compile of filename | Before_link
(* Syntax of OCAMLPARAM: SEP?(name=VALUE SEP)* _ (SEP name=VALUE)*
where VALUE should not contain SEP, and SEP is ',' if unspecified,
or ':', '|', ';', ' ' or ',' *)
exception SyntaxError of string
let print_error ppf msg =
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable ("OCAMLPARAM", msg))
let parse_args s =
let args =
let len = String.length s in
if len = 0 then []
else
(* allow first char to specify an alternative separator in ":|; ," *)
match s.[0] with
| ( ':' | '|' | ';' | ' ' | ',' ) as c ->
List.tl (String.split_on_char c s)
| _ -> String.split_on_char ',' s
in
let rec iter is_after args before after =
match args with
[] ->
if not is_after then
raise (SyntaxError "no '_' separator found")
else
(List.rev before, List.rev after)
| "" :: tail -> iter is_after tail before after
| "_" :: _ when is_after -> raise (SyntaxError "too many '_' separators")
| "_" :: tail -> iter true tail before after
| arg :: tail ->
let binding = try
Misc.cut_at arg '='
with Not_found ->
raise (SyntaxError ("missing '=' in " ^ arg))
in
if is_after then
iter is_after tail before (binding :: after)
else
iter is_after tail (binding :: before) after
in
iter false args [] []
let setter ppf f name options s =
try
let bool = match s with
| "0" -> false
| "1" -> true
| _ -> raise Not_found
in
List.iter (fun b -> b := f bool) options
with Not_found ->
Printf.ksprintf (print_error ppf)
"bad value %s for %s" s name
let int_setter ppf name option s =
try
option := int_of_string s
with _ ->
Printf.ksprintf (print_error ppf)
"non-integer parameter %s for %S" s name
let int_option_setter ppf name option s =
try
option := Some (int_of_string s)
with _ ->
Printf.ksprintf (print_error ppf)
"non-integer parameter %s for %S" s name
(*
let float_setter ppf name option s =
try
option := float_of_string s
with _ ->
Location.print_warning Location.none ppf
(Warnings.Bad_env_variable
("OCAMLPARAM", Printf.sprintf "non-float parameter for \"%s\"" name))
*)
let check_bool ppf name s =
match s with
| "0" -> false
| "1" -> true
| _ ->
Printf.ksprintf (print_error ppf)
"bad value %s for %s" s name;
false
let decode_compiler_pass ppf v ~name ~filter =
let module P = Clflags.Compiler_pass in
let passes = P.available_pass_names ~filter ~native:!native_code in
begin match List.find_opt (String.equal v) passes with
| None ->
Printf.ksprintf (print_error ppf)
"bad value %s for option \"%s\" (expected one of: %s)"
v name (String.concat ", " passes);
None
| Some v -> P.of_string v
end
let set_compiler_pass ppf ~name v flag ~filter =
match decode_compiler_pass ppf v ~name ~filter with
| None -> ()
| Some pass ->
match !flag with
| None -> flag := Some pass
| Some p ->
if not (p = pass) then begin
Printf.ksprintf (print_error ppf)
"Please specify at most one %s <pass>." name
end
let handle_dump_option ppf v =
let module D = Clflags.Dump_option in
let value, key =
(* "foo" => true, "foo"
"-foo" => false, "foo"
"+foo" => true, "foo" *)
let tail () = String.sub v 1 (String.length v - 1) in
if String.starts_with ~prefix:"-" v
then false, tail ()
else if String.starts_with ~prefix:"+" v
then true, tail ()
else true, v
in
match D.of_string key with
| None ->
Printf.ksprintf (print_error ppf)
"bad value %s for option \"dump\"." key
| Some option ->
match D.available option with
| Error msg ->
Printf.ksprintf (print_error ppf)
"dump=%s: %s." key msg
| Ok () ->
D.flag option := value
(* 'can-discard=' specifies which arguments can be discarded without warning
because they are not understood by some versions of OCaml. *)
let can_discard = ref []
let parse_warnings error v =
Option.iter Location.(prerr_alert none) @@ Warnings.parse_options error v
let read_one_param ppf position name v =
let set name options s = setter ppf (fun b -> b) name options s in
let clear name options s = setter ppf (fun b -> not b) name options s in
let compat name s =
let error_if_unset = function
| true -> true
| false ->
Printf.ksprintf (print_error ppf)
"Unsetting %s is not supported anymore" name;
true
in
setter ppf error_if_unset name [ ref true ] s
in
match name with
| "g" -> set "g" [ Clflags.debug ] v
| "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v
| "afl-instrument" -> set "afl-instrument" [ Clflags.afl_instrument ] v
| "afl-inst-ratio" ->
int_setter ppf "afl-inst-ratio" afl_inst_ratio v
| "annot" -> set "annot" [ Clflags.annotations ] v
| "absname" -> set "absname" [ Clflags.absname ] v
| "compat-32" -> set "compat-32" [ bytecode_compatible_32 ] v
| "noassert" -> set "noassert" [ noassert ] v
| "noautolink" -> set "noautolink" [ no_auto_link ] v
| "nostdlib" -> set "nostdlib" [ no_std_include ] v
| "nocwd" -> set "nocwd" [ no_cwd ] v
| "linkall" -> set "linkall" [ link_everything ] v
| "nolabels" -> set "nolabels" [ classic ] v
| "principal" -> set "principal" [ principal ] v
| "rectypes" -> set "rectypes" [ recursive_types ] v
| "safe-string" -> compat "safe-string" v (* kept for compatibility *)
| "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v
| "strict-formats" -> set "strict-formats" [ strict_formats ] v
| "thread" -> set "thread" [ use_threads ] v
| "unboxed-types" -> set "unboxed-types" [ unboxed_types ] v
| "unsafe" -> set "unsafe" [ unsafe ] v
| "verbose" -> set "verbose" [ verbose ] v
| "nopervasives" -> set "nopervasives" [ nopervasives ] v
| "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)
| "no-slash" -> clear "no-slash" [ force_slash ] v (* for ocamldep *)
| "keep-docs" -> set "keep-docs" [ Clflags.keep_docs ] v
| "keep-locs" -> set "keep-locs" [ Clflags.keep_locs ] v
| "compact" -> clear "compact" [ optimize_for_speed ] v
| "no-app-funct" -> clear "no-app-funct" [ applicative_functors ] v
| "nodynlink" -> clear "nodynlink" [ dlcode ] v
| "short-paths" -> clear "short-paths" [ real_paths ] v
| "no-alias-deps" -> set "no-alias-deps" [ no_alias_deps ] v
| "opaque" -> set "opaque" [ opaque ] v
| "pp" -> preprocessor := Some v
| "runtime-variant" -> runtime_variant := v
| "with-runtime" -> set "with-runtime" [ with_runtime ] v
| "open" ->
open_modules := List.rev_append (String.split_on_char ',' v) !open_modules
| "cc" -> c_compiler := Some v
| "clambda-checks" -> set "clambda-checks" [ clambda_checks ] v
| "function-sections" ->
set "function-sections" [ Clflags.function_sections ] v
(* assembly sources *)
| "s" ->
set "s" [ Clflags.keep_asm_file ; Clflags.keep_startup_file ] v
| "S" -> set "S" [ Clflags.keep_asm_file ] v
| "dstartup" -> set "dstartup" [ Clflags.keep_startup_file ] v
(* warn-errors *)
| "we" | "warn-error" -> parse_warnings true v
(* warnings *)
| "w" -> parse_warnings false v
(* warn-errors *)
| "wwe" -> parse_warnings false v
(* alerts *)
| "alert" -> Warnings.parse_alert_option v
(* inlining *)
| "inline" ->
let module F = Float_arg_helper in
begin match F.parse_no_error v inline_threshold with
| F.Ok -> ()
| F.Parse_failed exn ->
Printf.ksprintf (print_error ppf)
"bad syntax %s for \"inline\": %s" v (Printexc.to_string exn)
end
| "inline-toplevel" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-toplevel'"
inline_toplevel_threshold
| "rounds" -> int_option_setter ppf "rounds" simplify_rounds v
| "inline-max-unroll" ->
Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'inline-max-unroll'"
inline_max_unroll
| "inline-call-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-call-cost'"
inline_call_cost
| "inline-alloc-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-alloc-cost'"
inline_alloc_cost
| "inline-prim-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-prim-cost'"
inline_prim_cost
| "inline-branch-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-branch-cost'"
inline_branch_cost
| "inline-indirect-cost" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-indirect-cost'"
inline_indirect_cost
| "inline-lifting-benefit" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-lifting-benefit'"
inline_lifting_benefit
| "inline-branch-factor" ->
Float_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-branch-factor'"
inline_branch_factor
| "inline-max-depth" ->
Int_arg_helper.parse v
"Bad syntax in OCAMLPARAM for 'inline-max-depth'"
inline_max_depth
| "Oclassic" ->
set "Oclassic" [ classic_inlining ] v
| "O2" ->
if check_bool ppf "O2" v then begin
default_simplify_rounds := 2;
use_inlining_arguments_set o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
end
| "O3" ->
if check_bool ppf "O3" v then begin
default_simplify_rounds := 3;
use_inlining_arguments_set o3_arguments;
use_inlining_arguments_set ~round:1 o2_arguments;
use_inlining_arguments_set ~round:0 o1_arguments
end
| "unbox-closures" ->
set "unbox-closures" [ unbox_closures ] v
| "unbox-closures-factor" ->
int_setter ppf "unbox-closures-factor" unbox_closures_factor v
| "remove-unused-arguments" ->
set "remove-unused-arguments" [ remove_unused_arguments ] v
| "inlining-report" ->
if !native_code then
set "inlining-report" [ inlining_report ] v
| "flambda-verbose" ->
set "flambda-verbose" [ dump_flambda_verbose ] v
| "flambda-invariants" ->
set "flambda-invariants" [ flambda_invariant_checks ] v
| "cmm-invariants" ->
set "cmm-invariants" [ cmm_invariants ] v
| "linscan" ->
set "linscan" [ use_linscan ] v
| "insn-sched" -> set "insn-sched" [ insn_sched ] v
| "no-insn-sched" -> clear "insn-sched" [ insn_sched ] v
(* color output *)
| "color" ->
begin match color_reader.parse v with
| None ->
Printf.ksprintf (print_error ppf)
"bad value %s for \"color\", (%s)" v color_reader.usage
| Some setting -> color := Some setting
end
| "error-style" ->
begin match error_style_reader.parse v with
| None ->
Printf.ksprintf (print_error ppf)
"bad value %s for \"error-style\", (%s)" v error_style_reader.usage
| Some setting -> error_style := Some setting
end
| "intf-suffix" -> Config.interface_suffix := v
| "I" -> begin
match position with
| Before_args -> first_include_dirs := v :: !first_include_dirs
| Before_link | Before_compile _ ->
last_include_dirs := v :: !last_include_dirs
end
| "cclib" ->
begin
match position with
| Before_compile _ -> ()
| Before_link | Before_args ->
ccobjs := Misc.rev_split_words v @ !ccobjs
end
| "ccopt"
| "ccopts"
->
begin
match position with
| Before_link | Before_compile _ ->
last_ccopts := v :: !last_ccopts
| Before_args ->
first_ccopts := v :: !first_ccopts
end
| "ppx" ->
begin
match position with
| Before_link | Before_compile _ ->
last_ppx := v :: !last_ppx
| Before_args ->
first_ppx := v :: !first_ppx
end
| "cmo" | "cma" ->
if not !native_code then
begin
match position with
| Before_link | Before_compile _ ->
last_objfiles := v ::! last_objfiles
| Before_args ->
first_objfiles := v :: !first_objfiles
end
| "cmx" | "cmxa" ->
if !native_code then
begin
match position with
| Before_link | Before_compile _ ->
last_objfiles := v ::! last_objfiles
| Before_args ->
first_objfiles := v :: !first_objfiles
end
| "pic" ->
if !native_code then
set "pic" [ pic_code ] v
| "can-discard" ->
can_discard := v ::!can_discard
| "timings" | "profile" ->
let if_on = if name = "timings" then [ `Time ] else Profile.all_columns in
profile_columns := if check_bool ppf name v then if_on else []
| "stop-after" ->
set_compiler_pass ppf v ~name Clflags.stop_after ~filter:(fun _ -> true)
| "save-ir-after" ->
if !native_code then begin
let filter = Clflags.Compiler_pass.can_save_ir_after in
match decode_compiler_pass ppf v ~name ~filter with
| None -> ()
| Some pass -> set_save_ir_after pass true
end
| "dump-into-file" -> Clflags.dump_into_file := true
| "dump-dir" -> Clflags.dump_dir := Some v
| "dump" ->
handle_dump_option ppf v
| "keywords" -> Clflags.keyword_edition := Some v
| _ ->
if not (List.mem name !can_discard) then begin
can_discard := name :: !can_discard;
Printf.ksprintf (print_error ppf)
"Warning: discarding value of variable %S in OCAMLPARAM\n%!"
name
end
let read_OCAMLPARAM ppf position =
try
let s = Sys.getenv "OCAMLPARAM" in
if s <> "" then
let (before, after) =
try
parse_args s
with SyntaxError s ->
print_error ppf s;
[],[]
in
List.iter (fun (name, v) -> read_one_param ppf position name v)
(match position with
Before_args -> before
| Before_compile _ | Before_link -> after)
with Not_found -> ()
(* OCAMLPARAM passed as file *)
type pattern =
| Filename of string
| Any
type file_option = {
pattern : pattern;
name : string;
value : string;
}
let scan_line ic =
Scanf.bscanf ic "%[0-9a-zA-Z_.*/] : %[a-zA-Z_-] = %s "
(fun pattern name value ->
let pattern =
match pattern with
| "*" -> Any
| _ -> Filename pattern
in
{ pattern; name; value })
let load_config ppf filename =
match open_in_bin filename with
| exception e ->
Location.errorf ~loc:(Location.in_file filename)
"Cannot open file %s" (Printexc.to_string e)
|> Location.print_report ppf;
raise Exit
| ic ->
let sic = Scanf.Scanning.from_channel ic in
let rec read line_number line_start acc =
match scan_line sic with
| exception End_of_file ->
close_in ic;
acc
| exception Scanf.Scan_failure error ->
let position = Lexing.{
pos_fname = filename;
pos_lnum = line_number;
pos_bol = line_start;
pos_cnum = pos_in ic;
}
in
let loc = Location.{
loc_start = position;
loc_end = position;
loc_ghost = false;
}
in
Location.errorf ~loc "Configuration file error %s" error
|> Location.print_report ppf;
close_in ic;
raise Exit
| line ->
read (line_number + 1) (pos_in ic) (line :: acc)
in
let lines = read 0 0 [] in
lines
let matching_filename filename { pattern } =
match pattern with
| Any -> true
| Filename pattern ->
let filename = String.lowercase_ascii filename in
let pattern = String.lowercase_ascii pattern in
filename = pattern
let apply_config_file ppf position =
let config_file =
Filename.concat Config.standard_library "ocaml_compiler_internal_params"
in
let config =
if Sys.file_exists config_file then
load_config ppf config_file
else
[]
in
let config =
match position with
| Before_compile filename ->
List.filter (matching_filename filename) config
| Before_args | Before_link ->
List.filter (fun { pattern } -> pattern = Any) config
in
List.iter (fun { name; value } -> read_one_param ppf position name value)
config
let readenv ppf position =
last_include_dirs := [];
last_ccopts := [];
last_ppx := [];
last_objfiles := [];
apply_config_file ppf position;
read_OCAMLPARAM ppf position;
all_ccopts := !last_ccopts @ !first_ccopts;
all_ppx := !last_ppx @ !first_ppx
let get_objfiles ~with_ocamlparam =
if with_ocamlparam then
List.rev (!last_objfiles @ !objfiles @ !first_objfiles)
else
List.rev !objfiles
let has_linker_inputs = ref false
type deferred_action =
| ProcessImplementation of string
| ProcessInterface of string
| ProcessCFile of string
| ProcessOtherFile of string
| ProcessObjects of string list
| ProcessDLLs of string list
let c_object_of_filename name =
Filename.chop_suffix (Filename.basename name) ".c" ^ Config.ext_obj
let process_action
(ppf, implementation, interface, ocaml_mod_ext, ocaml_lib_ext) action =
let impl ~start_from name =
readenv ppf (Before_compile name);
let opref = output_prefix name in
implementation ~start_from ~source_file:name ~output_prefix:opref;
objfiles := (opref ^ ocaml_mod_ext) :: !objfiles
in
match action with
| ProcessImplementation name ->
impl ~start_from:Compiler_pass.Parsing name
| ProcessInterface name ->
readenv ppf (Before_compile name);
let opref = output_prefix name in
interface ~source_file:name ~output_prefix:opref;
if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
| ProcessCFile name ->
readenv ppf (Before_compile name);
Location.input_name := name;
let obj_name = match !output_name with
| None -> c_object_of_filename name
| Some n -> n
in
if Ccomp.compile_file ?output:!output_name name <> 0
then raise (Exit_with_status 2);
ccobjs := obj_name :: !ccobjs
| ProcessObjects names ->
ccobjs := names @ !ccobjs
| ProcessDLLs names ->
dllibs := names @ !dllibs
| ProcessOtherFile name ->
if Filename.check_suffix name ocaml_mod_ext
|| Filename.check_suffix name ocaml_lib_ext then
objfiles := name :: !objfiles
else if Filename.check_suffix name ".cmi" && !make_package then
objfiles := name :: !objfiles
else if Filename.check_suffix name Config.ext_obj
|| Filename.check_suffix name Config.ext_lib then begin
has_linker_inputs := true;
ccobjs := name :: !ccobjs
end
else if not !native_code && Filename.check_suffix name Config.ext_dll then
dllibs := name :: !dllibs
else
match Compiler_pass.of_input_filename name with
| Some start_from ->
Location.input_name := name;
impl ~start_from name
| None -> raise(Arg.Bad("Don't know what to do with " ^ name))
let action_of_file name =
if Filename.check_suffix name ".ml"
|| Filename.check_suffix name ".mlt" then
ProcessImplementation name
else if Filename.check_suffix name !Config.interface_suffix then
ProcessInterface name
else if Filename.check_suffix name ".c" then
ProcessCFile name
else
ProcessOtherFile name
let deferred_actions = ref []
let defer action =
deferred_actions := action :: !deferred_actions
let anonymous filename = defer (action_of_file filename)
let impl filename = defer (ProcessImplementation filename)
let intf filename = defer (ProcessInterface filename)
let process_deferred_actions env =
let final_output_name = !output_name in
(* Make sure the intermediate products don't clash with the final one
when we're invoked like: ocamlopt -o foo bar.c baz.ml. *)
if not !compile_only then output_name := None;
begin
match final_output_name with
| None -> ()
| Some _output_name ->
if !compile_only then begin
if List.length (List.filter (function
| ProcessCFile _
| ProcessImplementation _
| ProcessInterface _ -> true
| _ -> false) !deferred_actions) > 1 then
fatal "Options -c -o are incompatible with compiling multiple files"
end;
end;
if !make_archive then begin
if List.exists (function
| ProcessOtherFile name -> Filename.check_suffix name ".cmxa"
| _ -> false) !deferred_actions then
fatal "Option -a cannot be used with .cmxa input files."
end
else if !deferred_actions = [] then
fatal "No input files";
List.iter (process_action env) (List.rev !deferred_actions);
output_name := final_output_name;
stop_early :=
!compile_only ||
!print_types ||
match !stop_after with
| None -> false
| Some p -> Clflags.Compiler_pass.is_compilation_pass p
(* This function is almost the same as [Arg.parse_expand], except
that [Arg.parse_expand] could not be used because it does not take a
reference for [arg_spec].
We use a marker \000 for Arg.parse_and_expand_argv_dynamic
so we can split out error message from usage options, because
it always concatenates
error message with usage options *)
let parse_arguments ?(current=ref 0) argv f program =
try
Arg.parse_and_expand_argv_dynamic current argv Clflags.arg_spec f "\000"
with
| Arg.Bad err_msg ->
let usage_msg = create_usage_msg program in
let err_msg = err_msg
|> String.split_on_char '\000'
|> List.hd
|> String.trim in
Printf.eprintf "%s\n%s\n" err_msg usage_msg;
raise (Exit_with_status 2)
| Arg.Help msg ->
let err_msg =
msg
|> String.split_on_char '\000'
|> String.concat "" in
let help_msg =
Printf.sprintf "Usage: %s <options> <files>\nOptions are:" program in
Printf.printf "%s\n%s" help_msg err_msg;
raise (Exit_with_status 0)
|