diff options
| -rw-r--r-- | Changes | 3 | ||||
| -rw-r--r-- | driver/main.ml | 5 | ||||
| -rw-r--r-- | driver/optmain.ml | 6 | ||||
| -rw-r--r-- | utils/clflags.ml | 30 | ||||
| -rw-r--r-- | utils/clflags.mli | 17 |
5 files changed, 56 insertions, 5 deletions
@@ -74,6 +74,9 @@ Next version (4.05.0): the "always link" flag on all units of the given library. (Xavier Leroy) +- GPR#796: allow compiler plugins to declare their own arguments. + (Fabrice Le Fessant) + ### Standard library: - PR#6975, GPR#902: Truncate function added to stdlib Buffer module diff --git a/driver/main.ml b/driver/main.ml index 057d294838..7b918be8c5 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -126,9 +126,10 @@ module Options = Main_args.Make_bytecomp_options (struct end) let main () = + Clflags.add_arguments __LOC__ Options.list; try readenv ppf Before_args; - Arg.parse_expand Options.list anonymous usage; + Clflags.parse_arguments anonymous usage; begin try Compenv.process_deferred_actions (ppf, @@ -139,7 +140,7 @@ let main () = with Arg.Bad msg -> begin prerr_endline msg; - Arg.usage Options.list usage; + Clflags.print_arguments usage; exit 2 end end; diff --git a/driver/optmain.ml b/driver/optmain.ml index 5fd3d27755..be262f8028 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -236,8 +236,8 @@ let main () = let ppf = Format.err_formatter in try readenv ppf Before_args; - let spec = Arch.command_line_options @ Options.list in - Arg.parse_expand spec anonymous usage; + Clflags.add_arguments __LOC__ (Arch.command_line_options @ Options.list); + Clflags.parse_arguments anonymous usage; if !gprofile && not Config.profiling then fatal "Profiling with \"gprof\" is not supported on this platform."; begin try @@ -250,7 +250,7 @@ let main () = with Arg.Bad msg -> begin prerr_endline msg; - Arg.usage spec usage; + Clflags.print_arguments usage; exit 2 end end; diff --git a/utils/clflags.ml b/utils/clflags.ml index 62ced4578f..0d185b07bc 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -361,3 +361,33 @@ let parse_color_setting = function let color = ref Misc.Color.Auto ;; (* -color *) let unboxed_types = ref false + +let arg_spec = ref [] +let arg_names = ref Misc.StringMap.empty +let add_arguments loc args = + List.iter (function (arg_name, _, _) as arg -> + try + let loc2 = Misc.StringMap.find arg_name !arg_names in + Printf.eprintf + "Warning: plugin argument %s is already defined:\n" arg_name; + Printf.eprintf " First definition: %s\n" loc2; + Printf.eprintf " New definition: %s\n" loc; + with Not_found -> + arg_spec := !arg_spec @ [ arg ]; + arg_names := Misc.StringMap.add arg_name loc !arg_names + ) args + +let print_arguments usage = + Arg.usage !arg_spec usage + +(* 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].*) +let parse_arguments f msg = + try + let argv = ref Sys.argv in + let current = ref (!Arg.current) in + Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg + with + | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2 + | Arg.Help msg -> Printf.printf "%s" msg; exit 0 diff --git a/utils/clflags.mli b/utils/clflags.mli index 7efc4f8ef1..65353609e3 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -204,3 +204,20 @@ val parse_color_setting : string -> Misc.Color.setting option val color : Misc.Color.setting ref val unboxed_types : bool ref + +val arg_spec : (string * Arg.spec * string) list ref + +(* [add_arguments __LOC__ args] will add the arguments from [args] at + the end of [arg_spec], checking that they have not already been + added by [add_arguments] before. A warning is printed showing the + locations of the function from which the argument was previously + added. *) +val add_arguments : string -> (string * Arg.spec * string) list -> unit + +(* [parse_arguments anon_arg usage] will parse the arguments, using + the arguments provided in [Clflags.arg_spec]. It allows plugins to + provide their own arguments. +*) +val parse_arguments : Arg.anon_fun -> string -> unit + +val print_arguments : string -> unit |