[m-rev.] for review: mmc --make [4]
Simon Taylor
stayl at cs.mu.OZ.AU
Wed Feb 6 02:21:10 AEDT 2002
Index: compiler/make.program_target.m
===================================================================
RCS file: compiler/make.program_target.m
diff -N compiler/make.program_target.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/make.program_target.m 4 Feb 2002 02:03:11 -0000
@@ -0,0 +1,398 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+:- module make__program_target.
+
+:- interface.
+
+:- pred make_linked_target(linked_target_file::in, bool::out,
+ make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+:- pred make_misc_target(pair(module_name, misc_target_type)::in,
+ bool::out, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+:- implementation.
+
+make_linked_target(MainModuleName - FileType, Succeeded, Info0, Info) -->
+ find_reachable_local_modules(MainModuleName, DepsSuccess,
+ AllModules, Info0, Info1),
+ globals__io_lookup_bool_option(keep_going, KeepGoing),
+ ( { DepsSuccess = no, KeepGoing = no } ->
+ { Succeeded = no },
+ { Info = Info1 }
+ ;
+ globals__io_get_target(CompilationTarget),
+ ( { CompilationTarget = asm } ->
+ % An assembler file is only produced for the top-level
+ % module in each source file.
+ list__foldl3(
+ (pred(ModuleName::in, ObjModules0::in, ObjModules1::out,
+ MInfo0::in, MInfo::out, di, uo) is det -->
+ get_module_dependencies(ModuleName, MaybeImports,
+ MInfo0, MInfo),
+ {
+ MaybeImports = yes(Imports),
+ ModuleName = Imports ^ source_file_module_name
+ ->
+ ObjModules1 = [ModuleName | ObjModules0]
+ ;
+ ObjModules1 = ObjModules0
+ }
+ ),
+ set__to_sorted_list(AllModules), [],
+ ObjModules, Info1, Info4)
+ ;
+ { Info4 = Info1 },
+ { ObjModules = set__to_sorted_list(AllModules) }
+ ),
+
+ globals__io_get_globals(Globals),
+ module_name_to_file_name(MainModuleName,
+ linked_target_extension(Globals, FileType),
+ no, OutputFileName),
+ get_file_timestamp([dir__this_directory], OutputFileName,
+ MaybeTimestamp, Info4, Info5),
+
+ globals__io_lookup_string_option(pic_object_file_extension, PicObjExt),
+ globals__io_lookup_string_option(object_file_extension, ObjExt),
+ { FileType = shared_library, PicObjExt \= ObjExt ->
+ ObjectCodeType = pic,
+ ObjExtToUse = PicObjExt
+ ;
+ ObjectCodeType = non_pic,
+ ObjExtToUse = ObjExt
+ },
+
+ %
+ % Build the `.c' files first so that errors are
+ % reported as soon as possible.
+ %
+ {
+ CompilationTarget = c,
+ IntermediateTargetType = c_code,
+ ObjectTargetType = object_code(ObjectCodeType)
+ ;
+ CompilationTarget = asm,
+ IntermediateTargetType = asm_code(ObjectCodeType),
+ ObjectTargetType = object_code(ObjectCodeType)
+ ;
+ CompilationTarget = il,
+ IntermediateTargetType = il_code,
+ ObjectTargetType = il_asm
+ ;
+ CompilationTarget = java,
+ IntermediateTargetType = java_code,
+ % XXX Whoever finishes the Java backend can fill this in.
+ ObjectTargetType = object_code(non_pic)
+ },
+
+ { IntermediateTargets = make_dependency_list(ObjModules,
+ IntermediateTargetType) },
+ { ObjTargets = make_dependency_list(ObjModules, ObjectTargetType) },
+
+ foldl2_maybe_stop_at_error(KeepGoing,
+ foldl2_maybe_stop_at_error(KeepGoing, make_module_target),
+ [IntermediateTargets, ObjTargets], _, Info5, Info6),
+ check_dependencies(OutputFileName, MaybeTimestamp,
+ ObjTargets, BuildDepsResult, Info6, Info7),
+
+ (
+ { DepsSuccess = yes },
+ { BuildDepsResult \= error }
+ ->
+ build_with_check_for_interrupt(
+ build_with_module_options_and_output_redirect(
+ MainModuleName, [],
+ build_linked_target(MainModuleName, FileType,
+ OutputFileName, MaybeTimestamp, AllModules,
+ ObjModules, CompilationTarget, ObjExtToUse,
+ DepsSuccess, BuildDepsResult)),
+ linked_target_cleanup(MainModuleName, FileType, OutputFileName,
+ CompilationTarget),
+ Succeeded, Info7, Info)
+ ;
+ { Succeeded = no },
+ { Info = Info7 }
+ )
+ ).
+
+:- pred build_linked_target(module_name::in, linked_target_type::in,
+ file_name::in, maybe_error(timestamp)::in, set(module_name)::in,
+ list(module_name)::in, compilation_target::in, string::in, bool::in,
+ dependencies_result::in, list(string)::in, io__output_stream::in,
+ bool::out, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+build_linked_target(MainModuleName, FileType, OutputFileName, MaybeTimestamp,
+ AllModules, ObjModules, CompilationTarget, ObjExtToUse,
+ DepsSuccess, BuildDepsResult, _, ErrorStream, Succeeded,
+ Info0, Info) -->
+
+ globals__io_lookup_accumulating_option(link_objects, ExtraObjects0),
+
+ % Clear the option -- we'll pass the list of files directly.
+ globals__io_set_option(link_objects, accumulating([])),
+
+ %
+ % Remake the `_init.o' file.
+ % XXX We should probably make a `_init.o' file for shared
+ % libraries linked using dlopen().
+ %
+ { AllModulesList = set__to_sorted_list(AllModules) },
+ (
+ { FileType = executable },
+ { CompilationTarget = c ; CompilationTarget = asm }
+ ->
+ mercury_compile__make_init_obj_file(ErrorStream,
+ MainModuleName, AllModulesList, InitObjectResult),
+ (
+ { InitObjectResult = yes(InitObject) },
+
+ % We may need to update the timestamp
+ % of the `_init.o' file.
+ { Info1 = Info0 ^ file_timestamps :=
+ map__delete(Info0 ^ file_timestamps,
+ InitObject) },
+ { ExtraObjects = [InitObject | ExtraObjects0] },
+ { DepsResult2 = BuildDepsResult }
+ ;
+ { InitObjectResult = no },
+ { Info1 = Info0 },
+ { DepsResult2 = error },
+ { ExtraObjects = ExtraObjects0 }
+ )
+ ;
+ { DepsResult2 = BuildDepsResult },
+ { Info1 = Info0 },
+ { ExtraObjects = ExtraObjects0 }
+ ),
+
+ list__map_foldl2(get_file_timestamp([dir__this_directory]),
+ ExtraObjects, ExtraObjectTimestamps, Info1, Info2),
+ check_dependency_timestamps(OutputFileName, MaybeTimestamp,
+ ExtraObjects, io__write, ExtraObjectTimestamps,
+ ExtraObjectDepsResult),
+
+ { DepsResult3 = ( DepsSuccess = yes -> DepsResult2 ; error ) },
+ { DepsResult3 = error, DepsResult = DepsResult3
+ ; DepsResult3 = out_of_date, DepsResult = DepsResult3
+ ; DepsResult3 = up_to_date, DepsResult = ExtraObjectDepsResult
+ },
+ (
+ { DepsResult = error },
+ file_error(OutputFileName),
+ { Succeeded = no },
+ { Info = Info2 }
+ ;
+ { DepsResult = up_to_date },
+ { Succeeded = yes },
+ { Info = Info2 }
+ ;
+ { DepsResult = out_of_date },
+ maybe_make_linked_target_message(OutputFileName),
+
+ %
+ % Find the extra object files for externally compiled
+ % foreign procedures and fact tables. We don't need
+ % to include these in the timestamp checking above --
+ % they will have been checked when the module's object
+ % file was built.
+ %
+ list__map_foldl2(
+ (pred(ModuleName::in, ForeignFiles::out,
+ MakeInfo0::in, MakeInfo::out, di, uo) is det -->
+ get_module_dependencies(ModuleName, MaybeImports,
+ MakeInfo0, MakeInfo),
+ (
+ { MaybeImports = yes(Imports) },
+ external_foreign_code_files(Imports, ForeignFiles)
+ ;
+ { MaybeImports = no },
+ % This error should have been detected earlier.
+ { error(
+ "build_linked_target: error in dependencies") }
+ )
+ ), AllModulesList, ExtraForeignFiles, Info2, Info3),
+ { ForeignObjects = list__map(
+ (func(foreign_code_file(_, _, ObjFile)) = ObjFile),
+ list__condense(ExtraForeignFiles)) },
+ { AllExtraObjects = ExtraObjects ++ ForeignObjects },
+
+ list__map_foldl(
+ (pred(ObjModule::in, ObjToLink::out, di, uo) is det -->
+ module_name_to_file_name(ObjModule,
+ ObjExtToUse, no, ObjToLink)
+ ), ObjModules, ObjList),
+ { AllObjects = AllExtraObjects ++ ObjList },
+
+ (
+ { CompilationTarget = c },
+ % Run the link in a separate process so it can
+ % be killed if an interrupt is received.
+ call_in_forked_process(
+ mercury_compile__link(ErrorStream, FileType,
+ MainModuleName, AllObjects),
+ Succeeded)
+ ;
+ { CompilationTarget = asm },
+ % Run the link in a separate process so it can
+ % be killed if an interrupt is received.
+ call_in_forked_process(
+ mercury_compile__link(ErrorStream, FileType,
+ MainModuleName, AllObjects),
+ Succeeded)
+ ;
+ %
+ % IL doesn't need any linking. XXX Is this right?
+ %
+ { CompilationTarget = il },
+ { Succeeded = yes }
+ ;
+ { CompilationTarget = java },
+ { Succeeded = no },
+ io__write_string(
+ "Sorry, not implemented, linking for `--target java'")
+ ),
+
+ ( { Succeeded = yes } ->
+ { Info = Info3 ^ file_timestamps :=
+ map__delete(Info3 ^ file_timestamps,
+ OutputFileName) }
+ ;
+ file_error(OutputFileName),
+ { Info = Info3 }
+ )
+ ).
+
+:- pred linked_target_cleanup(module_name::in, linked_target_type::in,
+ file_name::in, compilation_target::in, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+linked_target_cleanup(MainModuleName, FileType, OutputFileName,
+ CompilationTarget, Info0, Info) -->
+ remove_file(OutputFileName, Info0, Info1),
+ (
+ { FileType = executable },
+ { CompilationTarget = c
+ ; CompilationTarget = asm
+ }
+ ->
+ globals__io_lookup_string_option(object_file_extension,
+ ObjExt),
+ remove_file(MainModuleName, "_init.c", Info1, Info2),
+ remove_file(MainModuleName, "_init" ++ ObjExt, Info2, Info)
+ ;
+ { Info = Info1 }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+make_misc_target(MainModuleName - TargetType, Succeeded, Info0, Info) -->
+ % Don't rebuild dependencies when cleaning up.
+ { RebuildDeps = Info0 ^ rebuild_dependencies },
+ { ( TargetType = clean ; TargetType = realclean ) ->
+ Info1 = Info0 ^ rebuild_dependencies := no
+ ;
+ Info1 = Info0
+ },
+ find_reachable_local_modules(MainModuleName, Succeeded0,
+ AllModules0, Info1, Info2),
+ { Info3 = Info2 ^ rebuild_dependencies := RebuildDeps },
+
+ { AllModules = set__to_sorted_list(AllModules0) },
+ (
+ { TargetType = clean },
+ { Succeeded = yes },
+ list__foldl2(make_clean, AllModules, Info3, Info)
+ ;
+ { TargetType = realclean },
+ { Succeeded = yes },
+ list__foldl2(make_realclean, AllModules, Info3, Info4),
+ globals__io_lookup_string_option(executable_file_extension,
+ ExeExt),
+ globals__io_lookup_string_option(library_extension, LibExt),
+ globals__io_lookup_string_option(shared_library_extension,
+ SharedLibExt),
+
+ list__foldl2(remove_file(MainModuleName),
+ [ExeExt, LibExt, SharedLibExt, "_init.c", "_init.o"],
+ Info4, Info)
+ ;
+ { TargetType = check },
+ globals__io_lookup_bool_option(keep_going, KeepGoing),
+ ( { Succeeded0 = no, KeepGoing = no } ->
+ { Info = Info3 },
+ { Succeeded = no }
+ ;
+ foldl2_maybe_stop_at_error(KeepGoing,
+ make_module_target,
+ make_dependency_list(AllModules, errors),
+ Succeeded1, Info3, Info),
+ { Succeeded = Succeeded0 `and` Succeeded1 }
+ )
+ ;
+ { TargetType = install_library },
+ { Succeeded = no },
+ { error("sorry, not implemented: mmc --make module.install") }
+ ).
+
+:- pred make_clean(module_name::in, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+make_clean(ModuleName, Info0, Info) -->
+ list__foldl2(remove_target_file(ModuleName),
+ [errors, c_code, c_header,
+ object_code(pic), object_code(non_pic),
+ asm_code(pic), asm_code(non_pic),
+ il_code, java_code
+ ],
+ Info0, Info1),
+
+ globals__io_lookup_string_option(object_file_extension, ObjExt),
+ list__foldl2(remove_file(ModuleName),
+ ["_init.c", "_init" ++ ObjExt, ".used", ".prof",
+ ".derived_schema", ".base_schema"],
+ Info1, Info2),
+
+ get_module_dependencies(ModuleName, MaybeImports, Info2, Info3),
+ (
+ { MaybeImports = yes(Imports) },
+ external_foreign_code_files(Imports, ForeignCodeFiles),
+ list__foldl2(
+ (pred(ForeignCodeFile::in, MakeInfo0::in, MakeInfo::out,
+ di, uo) is det -->
+ { ForeignCodeFile = foreign_code_file(_,
+ TargetFile, ObjectFile) },
+ remove_file(TargetFile, MakeInfo0, MakeInfo1),
+ remove_file(ObjectFile, MakeInfo1, MakeInfo)
+ ), ForeignCodeFiles, Info3, Info)
+ ;
+ { MaybeImports = no },
+ { Info = Info3 }
+ ).
+
+:- pred make_realclean(module_name::in, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+make_realclean(ModuleName, Info0, Info) -->
+ make_clean(ModuleName, Info0, Info1),
+ list__foldl2(remove_target_file(ModuleName),
+ [private_interface, long_interface, short_interface,
+ unqualified_short_interface, intermodule_interface,
+ aditi_code, c_header
+ ],
+ Info1, Info2),
+ globals__io_lookup_string_option(executable_file_extension, ExeExt),
+ globals__io_lookup_string_option(library_extension, LibExt),
+ globals__io_lookup_string_option(shared_library_extension,
+ SharedLibExt),
+ list__foldl2(remove_file(ModuleName),
+ [module_dep_file_extension, ExeExt, LibExt, SharedLibExt],
+ Info2, Info).
+
+%-----------------------------------------------------------------------------%
Index: compiler/make.util.m
===================================================================
RCS file: compiler/make.util.m
diff -N compiler/make.util.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/make.util.m 4 Feb 2002 18:09:49 -0000
@@ -0,0 +1,1010 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+% File: make.util.m
+% Main author: stayl
+%
+% Assorted predicates used to implement `mmc --make'.
+%-----------------------------------------------------------------------------%
+:- module make__util.
+
+:- interface.
+
+ %
+ % Versions of foldl which stop if the supplied predicate returns `no'
+ % for any element of the list.
+ %
+
+ % foldl2_pred_with_status(T, Succeeded, Info0, Info).
+:- type foldl2_pred_with_status(T, Info, IO) ==
+ pred(T, bool, Info, Info, IO, IO).
+:- inst foldl2_pred_with_status == (pred(in, out, in, out, di, uo) is det).
+
+ % foldl2_maybe_stop_at_error(KeepGoing, P, List,
+ % Succeeded, Info0, Info).
+:- pred foldl2_maybe_stop_at_error(bool::in,
+ foldl2_pred_with_status(T, Info, IO)::in(foldl2_pred_with_status),
+ list(T)::in, bool::out, Info::in, Info::out, IO::di, IO::uo) is det.
+
+ % foldl3_pred_with_status(T, Succeeded, Acc0, Acc, Info0, Info).
+:- type foldl3_pred_with_status(T, Acc, Info, IO) ==
+ pred(T, bool, Acc, Acc, Info, Info, IO, IO).
+:- inst foldl3_pred_with_status ==
+ (pred(in, out, in, out, in, out, di, uo) is det).
+
+ % foldl3_maybe_stop_at_error(KeepGoing, P, List,
+ % Succeeded, Acc0, Acc, Info0, Info).
+:- pred foldl3_maybe_stop_at_error(bool::in,
+ foldl3_pred_with_status(T, Acc, Info, IO)::in(foldl3_pred_with_status),
+ list(T)::in, bool::out, Acc::in, Acc::out, Info::in, Info::out,
+ IO::di, IO::uo) is det.
+
+%-----------------------------------------------------------------------------%
+ % Code to handle cleaning up when a signal is received.
+
+:- type build0 == pred(bool, make_info, make_info, io__state, io__state).
+:- inst build0 == (pred(out, in, out, di, uo) is det).
+
+:- type post_signal_cleanup ==
+ pred(make_info, make_info, io__state, io__state).
+:- inst post_signal_cleanup == (pred(in, out, di, uo) is det).
+
+ % build_with_check_for_interrupt(Build, Cleanup,
+ % Succeeded, Info0, Info)
+ %
+ % Apply `Build' with signal handlers installed to check for signals
+ % which would normally kill the process. If a signal occurs call
+ % `Cleanup', then restore signal handlers to their defaults and
+ % reraise the signal to kill the current process.
+ % An action being performed in a child process by
+ % call_in_forked_process will be killed if a fatal signal
+ % (SIGINT, SIGTERM, SIGHUP or SIGQUIT) is received by the
+ % current process.
+ % An action being performed within the current process or by
+ % system() will run to completion, with the interrupt being taken
+ % immediately afterwards.
+:- pred build_with_check_for_interrupt(build0::in(build0),
+ post_signal_cleanup::in(post_signal_cleanup),
+ bool::out, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- type build(T) == pred(T, bool, make_info, make_info, io__state, io__state).
+:- inst build == (pred(in, out, in, out, di, uo) is det).
+
+ % Perform the given closure after updating the option_table in
+ % the globals in the io__state to contain the module-specific
+ % options for the specified module.
+:- pred build_with_module_options(module_name::in,
+ list(string)::in, build(list(string))::in(build), bool::out,
+ make_info::in, make_info::out, io__state::di, io__state::uo) is det.
+
+ % Perform the given closure with an output stream created
+ % to append to the error file for the given module.
+:- pred build_with_output_redirect(module_name::in,
+ build(io__output_stream)::in(build), bool::out,
+ make_info::in, make_info::out, io__state::di, io__state::uo) is det.
+
+ % Produce an output stream which writes to the error file
+ % for the given module.
+:- pred redirect_output(module_name::in, maybe(io__output_stream)::out,
+ make_info::in, make_info::out, io__state::di, io__state::uo) is det.
+
+ % Close the module error output stream.
+:- pred unredirect_output(module_name::in, io__output_stream::in,
+ make_info::in, make_info::out, io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- type build2(T, U) == pred(T, U, bool, make_info, make_info,
+ io__state, io__state).
+:- inst build2 == (pred(in, in, out, in, out, di, uo) is det).
+
+:- pred build_with_module_options_and_output_redirect(module_name::in,
+ list(string)::in, build2(list(string), io__output_stream)::in(build2),
+ bool::out, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- type io_pred == pred(bool, io__state, io__state).
+:- inst io_pred == (pred(out, di, uo) is det).
+
+ % call_in_forked_process(P, AltP, Succeeded)
+ %
+ % Execute `P' in a separate process.
+ %
+ % We prefer to use fork() rather than system() because
+ % that will avoid shell and Mercury runtime startup overhead.
+ % Interrupt handling will also work better (system() on Linux
+ % ignores SIGINT).
+ %
+ % If fork() is not supported on the current architecture,
+ % `AltP' will be called instead in the current process.
+:- pred call_in_forked_process(io_pred::in(io_pred), io_pred::in(io_pred),
+ bool::out, io__state::di, io__state::uo) is det.
+
+ % As above, but if fork() is not available, just call the
+ % predicate in the current process.
+:- pred call_in_forked_process(io_pred::in(io_pred),
+ bool::out, io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+ % Timestamp handling.
+
+ % Find the timestamp updated when a target is produced.
+:- pred get_timestamp_file_timestamp(target_file::in,
+ maybe_error(timestamp)::out, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+:- pred get_dependency_timestamp(dependency_file::in,
+ maybe_error(timestamp)::out, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+:- pred get_target_timestamp(target_file::in, maybe_error(timestamp)::out,
+ make_info::in, make_info::out, io__state::di, io__state::uo) is det.
+
+:- pred get_file_name(target_file::in, file_name::out,
+ make_info::in, make_info::out, io__state::di, io__state::uo) is det.
+
+:- pred get_file_timestamp(list(dir_name)::in, file_name::in,
+ maybe_error(timestamp)::out, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+ % Remove file a file, deleting the cached timestamp.
+
+:- pred remove_target_file(target_file::in, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+:- pred remove_target_file(module_name::in, module_target_type::in,
+ make_info::in, make_info::out, io__state::di, io__state::uo) is det.
+
+ % remove_file(ModuleName, Extension, Info0, Info).
+:- pred remove_file(module_name::in, string::in, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+:- pred remove_file(file_name::in, make_info::in, make_info::out,
+ io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- func make_target_list(list(K), V) = assoc_list(K, V).
+
+:- func make_dependency_list(list(module_name), module_target_type) =
+ list(dependency_file).
+
+:- func target_extension(globals, module_target_type) = string.
+:- mode target_extension(in, in) = out is det.
+:- mode target_extension(in, out) = in is nondet.
+
+:- func linked_target_extension(globals, linked_target_type) = string.
+:- mode linked_target_extension(in, in) = out is det.
+:- mode linked_target_extension(in, out) = in is nondet.
+
+ % Find the extension for the timestamp file for the
+ % given target type, if one exists.
+:- func timestamp_extension(module_target_type) = string is semidet.
+
+%-----------------------------------------------------------------------------%
+ % Debugging, verbose and error messages.
+
+ % Apply the given predicate if `--debug-make' is set.
+:- pred debug_msg(pred(io__state, io__state)::(pred(di, uo) is det),
+ io__state::di, io__state::uo) is det.
+
+ % Apply the given predicate if `--verbose-make' is set.
+:- pred verbose_msg(pred(io__state, io__state)::(pred(di, uo) is det),
+ io__state::di, io__state::uo) is det.
+
+ % Write a debugging message relating to a given target file.
+:- pred debug_file_msg(target_file::in, string::in,
+ io__state::di, io__state::uo) is det.
+
+:- pred write_dependency_file(dependency_file::in,
+ io__state::di, io__state::uo) is det.
+
+:- pred write_target_file(target_file::in,
+ io__state::di, io__state::uo) is det.
+
+ % Write a message "Making <filename>" if `--verbose-make' is set.
+:- pred maybe_make_linked_target_message(file_name::in,
+ io__state::di, io__state::uo) is det.
+
+ % Write a message "Making <filename>" if `--verbose-make' is set.
+:- pred maybe_make_target_message(target_file::in,
+ io__state::di, io__state::uo) is det.
+
+:- pred maybe_make_target_message(io__output_stream::in, target_file::in,
+ io__state::di, io__state::uo) is det.
+
+ % Write a message "** Error making <filename>".
+:- pred target_file_error(target_file::in,
+ io__state::di, io__state::uo) is det.
+
+ % Write a message "** Error making <filename>".
+:- pred file_error(file_name::in, io__state::di, io__state::uo) is det.
+
+%-----------------------------------------------------------------------------%
+:- implementation.
+
+foldl2_maybe_stop_at_error(KeepGoing, MakeTarget,
+ Targets, Success, Info0, Info) -->
+ foldl2_maybe_stop_at_error_2(KeepGoing, MakeTarget, Targets,
+ yes, Success, Info0, Info).
+
+:- pred foldl2_maybe_stop_at_error_2(bool::in,
+ foldl2_pred_with_status(T, Info, IO)::in(foldl2_pred_with_status),
+ list(T)::in, bool::in, bool::out, Info::in, Info::out,
+ IO::di, IO::uo) is det.
+
+foldl2_maybe_stop_at_error_2(_KeepGoing, _P, [],
+ Success, Success, Info, Info) --> [].
+foldl2_maybe_stop_at_error_2(KeepGoing, P, [T | Ts],
+ Success0, Success, Info0, Info) -->
+ P(T, Success1, Info0, Info1),
+ ( { Success1 = yes ; KeepGoing = yes } ->
+ foldl2_maybe_stop_at_error_2(KeepGoing, P, Ts,
+ Success0 `and` Success1, Success, Info1, Info)
+ ;
+ { Success = no },
+ { Info = Info0 }
+ ).
+
+foldl3_maybe_stop_at_error(KeepGoing, P, Ts, Success,
+ Acc0, Acc, Info0, Info) -->
+ foldl3_maybe_stop_at_error_2(KeepGoing, P, Ts,
+ yes, Success, Acc0, Acc, Info0, Info).
+
+:- pred foldl3_maybe_stop_at_error_2(bool::in,
+ foldl3_pred_with_status(T, Acc, Info, IO)::in(foldl3_pred_with_status),
+ list(T)::in, bool::in, bool::out, Acc::in, Acc::out,
+ Info::in, Info::out, IO::di, IO::uo) is det.
+
+foldl3_maybe_stop_at_error_2(_KeepGoing, _P, [],
+ Success, Success, Acc, Acc, Info, Info) --> [].
+foldl3_maybe_stop_at_error_2(KeepGoing, P, [T | Ts],
+ Success0, Success, Acc0, Acc, Info0, Info) -->
+ P(T, Success1, Acc0, Acc1, Info0, Info1),
+ ( { Success1 = yes ; KeepGoing = yes } ->
+ foldl3_maybe_stop_at_error_2(KeepGoing, P, Ts,
+ Success0 `and` Success1, Success, Acc1, Acc,
+ Info1, Info)
+ ;
+ { Success = no },
+ { Acc = Acc0 },
+ { Info = Info0 }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+build_with_check_for_interrupt(Build, Cleanup, Succeeded, Info0, Info) -->
+ setup_signal_handlers(SigIntHandler),
+ Build(Succeeded0, Info0, Info1),
+ restore_signal_handlers(SigIntHandler),
+ check_for_signal(Signalled, Signal),
+ ( { Signalled = 1 } ->
+ { Succeeded = no },
+ verbose_msg(
+ (pred(di, uo) is det -->
+ io__write_string("** Received signal "),
+ io__write_int(Signal),
+ io__write_string(", cleaning up.\n")
+ )),
+ Cleanup(Info1, Info),
+
+ % The signal handler has been restored to the default,
+ % so this should kill us.
+ raise_signal(Signal)
+ ;
+ { Succeeded = Succeeded0 },
+ { Info = Info1 }
+ ).
+
+:- type signal_action ---> signal_action(c_pointer).
+
+:- pragma foreign_decl("C",
+"
+#ifdef HAVE_UNISTD_H
+ #include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TYPES_H
+ #include <sys/types.h>
+#endif
+
+#ifdef HAVE_SYS_WAIT
+ #include <sys/wait.h>
+#endif
+
+#include <errno.h>
+
+#include ""mercury_signal.h""
+#include ""mercury_types.h""
+#include ""mercury_heap.h""
+#include ""mercury_misc.h""
+
+#if defined(HAVE_FORK) && defined(HAVE_WAIT) && defined(HAVE_KILL)
+ #define MC_CAN_FORK 1
+#endif
+
+#define MC_SETUP_SIGNAL_HANDLER(sig, handler) \
+ MR_setup_signal(sig, (MR_Code *) handler, FALSE, \
+ ""mercury_compile: cannot install signal handler"");
+
+ /* Have we received a signal. */
+volatile sig_atomic_t MC_signalled;
+
+ /* Which signal did we receive. */
+volatile sig_atomic_t MC_signal_received;
+
+void MC_mercury_compile_signal_handler(int sig);
+").
+
+:- pragma foreign_code("C",
+"
+volatile sig_atomic_t MC_signalled = FALSE;
+volatile sig_atomic_t MC_signal_received = 0;
+
+void
+MC_mercury_compile_signal_handler(int sig)
+{
+ MC_signalled = TRUE;
+ MC_signal_received = sig;
+}
+").
+
+:- pred setup_signal_handlers(signal_action::out,
+ io__state::di, io__state::uo) is det.
+
+:- pragma foreign_proc("C",
+ setup_signal_handlers(SigintHandler::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"{
+ IO = IO0;
+ MC_signalled = FALSE;
+
+ MR_incr_hp_msg(SigintHandler,
+ MR_bytes_to_words(sizeof(MR_signal_action)),
+ MR_PROC_LABEL, ""make.util.signal_action/0"");
+
+ /*
+ ** mdb sets up a SIGINT handler, so we should restore
+ ** it after we're done.
+ */
+ MR_get_signal_action(SIGINT, (MR_signal_action *) SigintHandler,
+ ""error getting SIGINT handler"");
+ MC_SETUP_SIGNAL_HANDLER(SIGINT, MC_mercury_compile_signal_handler);
+ MC_SETUP_SIGNAL_HANDLER(SIGTERM, MC_mercury_compile_signal_handler);
+#ifdef SIGHUP
+ MC_SETUP_SIGNAL_HANDLER(SIGHUP, MC_mercury_compile_signal_handler);
+#endif
+#ifdef SIGQUIT
+ MC_SETUP_SIGNAL_HANDLER(SIGQUIT, MC_mercury_compile_signal_handler);
+#endif
+}").
+
+:- pred restore_signal_handlers(signal_action::in,
+ io__state::di, io__state::uo) is det.
+
+:- pragma foreign_proc("C",
+ restore_signal_handlers(SigintHandler::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"{
+ IO = IO0;
+ MR_set_signal_action(SIGINT, (MR_signal_action *) SigintHandler,
+ ""error resetting SIGINT handler"");
+ MC_SETUP_SIGNAL_HANDLER(SIGTERM, SIG_DFL);
+#ifdef SIGHUP
+ MC_SETUP_SIGNAL_HANDLER(SIGHUP, SIG_DFL);
+#endif
+#ifdef SIGQUIT
+ MC_SETUP_SIGNAL_HANDLER(SIGQUIT, SIG_DFL);
+#endif
+}").
+
+:- pred check_for_signal(int::out, int::out,
+ io__state::di, io__state::uo) is det.
+
+:- pragma foreign_proc("C",
+ check_for_signal(Signalled::out, Signal::out, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ IO = IO0;
+ Signalled = (MC_signalled ? 1 : 0);
+ Signal = MC_signal_received;
+").
+
+:- pred raise_signal(int::in, io__state::di, io__state::uo) is det.
+
+:- pragma foreign_proc("C",
+ raise_signal(Signal::in, IO0::di, IO::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ IO = IO0;
+ raise(Signal);
+").
+
+%-----------------------------------------------------------------------------%
+
+call_in_forked_process(P, Success) -->
+ call_in_forked_process(P, P, Success).
+
+call_in_forked_process(P, AltP, Success) -->
+ ( { can_fork } ->
+ debug_msg(io__write_string("call_in_forked_process\n")),
+ call_in_forked_process_2(P, ForkStatus, CallStatus),
+ { ForkStatus = 1 ->
+ Success = no
+ ;
+ Status = io__handle_system_command_exit_status(
+ CallStatus),
+ Success = (Status = ok(exited(0)) -> yes ; no)
+ },
+ debug_msg(io__write_string(
+ "finished call_in_forked_process\n"))
+ ;
+ AltP(Success)
+ ).
+
+:- pred can_fork is semidet.
+
+:- pragma foreign_proc("C", can_fork,
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+#ifdef MC_CAN_FORK
+ SUCCESS_INDICATOR = TRUE;
+#else
+ SUCCESS_INDICATOR = FALSE;
+#endif
+").
+
+:- pred call_in_forked_process_2(io_pred::in(io_pred), int::out, int::out,
+ io__state::di, io__state::uo) is det.
+
+:- pragma foreign_proc("C",
+ call_in_forked_process_2(Pred::in(io_pred),
+ ForkStatus::out, Status::out, IO0::di, IO::uo),
+ [may_call_mercury, promise_pure],
+"{
+#ifdef MC_CAN_FORK
+ pid_t child_pid;
+
+ IO = IO0;
+ ForkStatus = 0;
+ Status = 0;
+
+ child_pid = fork();
+ if (child_pid == -1) { /* error */
+ MR_perror(""error in fork()"");
+ ForkStatus = 1;
+ } else if (child_pid == 0) { /* child */
+ MR_Integer exit_status;
+
+ call_io_pred(Pred, &exit_status);
+ exit(exit_status);
+ } else { /* parent */
+ int child_status;
+ pid_t wait_status;
+
+ /*
+ ** Make sure the wait() is interrupted by the signals
+ ** which cause us to exit.
+ */
+ MR_signal_should_restart(SIGINT, FALSE);
+ MR_signal_should_restart(SIGTERM, FALSE);
+#ifdef SIGHUP
+ MR_signal_should_restart(SIGHUP, FALSE);
+#endif
+#ifdef SIGQUIT
+ MR_signal_should_restart(SIGQUIT, FALSE);
+#endif
+
+ while (1) {
+ wait_status = wait(&child_status);
+ if (wait_status == child_pid) {
+ Status = child_status;
+ break;
+ } else if (wait_status == -1) {
+ if (errno == EINTR) {
+ if (MC_signalled) {
+ /*
+ ** A normally fatal signal has been received,
+ ** so kill the child immediately.
+ ** Use SIGTERM, not MC_signal_received,
+ ** because the child may be inside a call
+ ** to system() which would cause SIGINT
+ ** to be ignored on some systems (e.g. Linux).
+ */
+ kill(child_pid, SIGTERM);
+ }
+ } else {
+ /*
+ ** This should never happen.
+ */
+ MR_perror(""error in wait(): "");
+ ForkStatus = 1;
+ Status = 1;
+ break;
+ }
+ }
+ }
+
+ /*
+ ** Restore the system call signal behaviour.
+ */
+ MR_signal_should_restart(SIGINT, TRUE);
+ MR_signal_should_restart(SIGTERM, TRUE);
+#ifdef SIGHUP
+ MR_signal_should_restart(SIGHUP, TRUE);
+#endif
+#ifdef SIGQUIT
+ MR_signal_should_restart(SIGQUIT, TRUE);
+#endif
+
+ }
+#else
+ IO = IO0;
+ ForkStatus = 1;
+ Status = 1;
+#endif
+}").
+
+ % call_io_pred(P, ExitStatus).
+:- pred call_io_pred(io_pred::in(io_pred), int::out,
+ io__state::di, io__state::uo) is det.
+:- pragma export(call_io_pred(in(io_pred), out, di, uo), "call_io_pred").
+
+call_io_pred(P, Status) -->
+ P(Success),
+ { Status = ( Success = yes -> 0 ; 1 ) }.
+
+%-----------------------------------------------------------------------------%
+
+build_with_module_options_and_output_redirect(ModuleName,
+ ExtraOptions, Build, Succeeded, Info0, Info) -->
+ build_with_module_options(ModuleName, ExtraOptions,
+ (pred(AllOptions::in, Succeeded1::out,
+ Info1::in, Info2::out, di, uo) is det -->
+ build_with_output_redirect(ModuleName,
+ (pred(ErrorStream::in, Succeeded2::out,
+ Info3::in, Info4::out, di, uo) is det -->
+ Build(AllOptions, ErrorStream, Succeeded2, Info3, Info4)
+ ), Succeeded1, Info1, Info2)
+ ), Succeeded, Info0, Info).
+
+build_with_output_redirect(ModuleName, Build, Succeeded, Info0, Info) -->
+ redirect_output(ModuleName, RedirectResult, Info0, Info1),
+ (
+ { RedirectResult = no },
+ { Succeeded = no },
+ { Info = Info1 }
+ ;
+ { RedirectResult = yes(ErrorStream) },
+ Build(ErrorStream, Succeeded, Info1, Info2),
+ unredirect_output(ModuleName, ErrorStream, Info2, Info)
+ ).
+
+build_with_module_options(ModuleName, ExtraOptions,
+ Build, Succeeded, Info0, Info) -->
+ lookup_mmc_module_options(Info0 ^ options_variables,
+ ModuleName, OptionsResult),
+ (
+ { OptionsResult = no },
+ { Info = Info0 },
+ { Succeeded = no }
+ ;
+ { OptionsResult = yes(OptionArgs) },
+ globals__io_get_globals(Globals),
+
+ % --no-generate-mmake-module-dependencies disables
+ % generation of `.d' files.
+ { AllOptionArgs = list__condense(
+ [["--no-generate-mmake-module-dependencies" | OptionArgs],
+ Info0 ^ option_args, ExtraOptions,
+ ["--no-make", "--no-rebuild"]]) },
+
+ handle_options(AllOptionArgs, OptionsError, _, _, _),
+ (
+ { OptionsError = yes(OptionsMessage) },
+ { Succeeded = no },
+ { Info = Info0 },
+ usage_error(OptionsMessage)
+ ;
+ { OptionsError = no },
+ Build(AllOptionArgs, Succeeded, Info0, Info),
+ globals__io_set_globals(unsafe_promise_unique(Globals))
+ )
+ ).
+
+redirect_output(_ModuleName, MaybeErrorStream, Info, Info) -->
+ %
+ % Write the output to a temporary file first, so it's
+ % easy to just print the part of the error file
+ % that relates to the current command. It will
+ % be appended to the error file later.
+ %
+ io__make_temp(ErrorFileName),
+ io__open_output(ErrorFileName, ErrorFileRes),
+ (
+ { ErrorFileRes = ok(ErrorOutputStream) },
+ { MaybeErrorStream = yes(ErrorOutputStream) }
+ ;
+ { ErrorFileRes = error(IOError) },
+ { MaybeErrorStream = no },
+ io__write_string("** Error opening `"),
+ io__write_string(ErrorFileName),
+ io__write_string("' for output: "),
+ { io__error_message(IOError, Msg) },
+ io__write_string(Msg),
+ io__nl
+ ).
+
+unredirect_output(ModuleName, ErrorOutputStream, Info0, Info) -->
+ io__output_stream_name(ErrorOutputStream, TmpErrorFileName),
+ io__close_output(ErrorOutputStream),
+
+ io__open_input(TmpErrorFileName, TmpErrorInputRes),
+ (
+ { TmpErrorInputRes = ok(TmpErrorInputStream) },
+ module_name_to_file_name(ModuleName, ".err", yes, ErrorFileName),
+ ( { set__member(ModuleName, Info0 ^ error_file_modules) } ->
+ io__open_append(ErrorFileName, ErrorFileRes)
+ ;
+ io__open_output(ErrorFileName, ErrorFileRes)
+ ),
+ (
+ { ErrorFileRes = ok(ErrorFileOutputStream) },
+ globals__io_lookup_int_option(output_compile_error_lines,
+ LinesToWrite),
+ io__output_stream(CurrentOutputStream),
+ io__input_stream_foldl2_io(TmpErrorInputStream,
+ write_error_char(ErrorFileOutputStream,
+ CurrentOutputStream, LinesToWrite),
+ 0, TmpFileInputRes),
+ (
+ { TmpFileInputRes = ok(_) }
+ ;
+ { TmpFileInputRes = error(_, TmpFileInputError) },
+ io__write_string("Error reading `"),
+ io__write_string(TmpErrorFileName),
+ io__write_string("': "),
+ io__write_string(io__error_message(TmpFileInputError)),
+ io__nl
+ ),
+
+ io__close_output(ErrorFileOutputStream),
+
+ { Info = Info0 ^ error_file_modules :=
+ set__insert(Info0 ^ error_file_modules, ModuleName) }
+ ;
+ { ErrorFileRes = error(Error) },
+ { Info = Info0 },
+ io__write_string("Error opening `"),
+ io__write_string(TmpErrorFileName),
+ io__write_string("': "),
+ io__write_string(io__error_message(Error)),
+ io__nl
+ ),
+ io__close_input(TmpErrorInputStream)
+ ;
+ { TmpErrorInputRes = error(Error) },
+ { Info = Info0 },
+ io__write_string("Error opening `"),
+ io__write_string(TmpErrorFileName),
+ io__write_string("': "),
+ io__write_string(io__error_message(Error)),
+ io__nl
+ ),
+ io__remove_file(TmpErrorFileName, _).
+
+:- pred write_error_char(io__output_stream::in, io__output_stream::in,
+ int::in, char::in, int::in, int::out,
+ io__state::di, io__state::uo) is det.
+
+write_error_char(FullOutputStream, PartialOutputStream, LineLimit,
+ Char, Lines0, Lines) -->
+ io__write_char(FullOutputStream, Char),
+ ( { Lines0 < LineLimit } ->
+ io__write_char(PartialOutputStream, Char)
+ ;
+ []
+ ),
+ { Lines = ( Char = '\n' -> Lines0 + 1 ; Lines0 ) }.
+
+%-----------------------------------------------------------------------------%
+
+get_timestamp_file_timestamp(ModuleName - FileType,
+ MaybeTimestamp, Info0, Info) -->
+ globals__io_get_globals(Globals),
+ { TimestampExt = timestamp_extension(FileType) ->
+ Ext = TimestampExt
+ ;
+ Ext = target_extension(Globals, FileType)
+ },
+ module_name_to_file_name(ModuleName, Ext, no, FileName),
+
+ % We should only ever look for timestamp files
+ % in the current directory. Timestamp files are
+ % only used when processing a module, and only
+ % modules in the current directory are processed.
+ { SearchDirs = [dir__this_directory] },
+ get_file_timestamp(SearchDirs, FileName, MaybeTimestamp, Info0, Info).
+
+get_dependency_timestamp(file(FileName, MaybeOption), MaybeTimestamp,
+ Info0, Info) -->
+ (
+ { MaybeOption = yes(Option) },
+ globals__io_lookup_accumulating_option(Option, SearchDirs)
+ ;
+ { MaybeOption = no },
+ { SearchDirs = [dir__this_directory] }
+ ),
+ get_file_timestamp(SearchDirs, FileName, MaybeTimestamp, Info0, Info).
+get_dependency_timestamp(target(Target), MaybeTimestamp, Info0, Info) -->
+ get_target_timestamp(Target, MaybeTimestamp, Info0, Info).
+
+get_target_timestamp(ModuleName - FileType, MaybeTimestamp, Info0, Info) -->
+ get_file_name(ModuleName - FileType, FileName, Info0, Info1),
+ get_search_directories(FileType, SearchDirs),
+ get_file_timestamp(SearchDirs, FileName, MaybeTimestamp0,
+ Info1, Info2),
+ (
+ { MaybeTimestamp0 = error(_) },
+ { FileType = intermodule_interface }
+ ->
+ %
+ % If a `.opt' file in another directory doesn't exist,
+ % it just means that a library wasn't compiled with
+ % `--intermodule-optimization'.
+ %
+ get_module_dependencies(ModuleName, MaybeImports,
+ Info2, Info3),
+ {
+ MaybeImports = yes(Imports),
+ Imports ^ module_dir \= dir__this_directory
+ ->
+ MaybeTimestamp = ok(oldest_timestamp),
+ Info = Info3 ^ file_timestamps
+ ^ elem(FileName) := MaybeTimestamp
+ ;
+ MaybeTimestamp = MaybeTimestamp0,
+ Info = Info3
+ }
+ ;
+ { MaybeTimestamp = MaybeTimestamp0 },
+ { Info = Info2 }
+ ).
+
+get_file_name(ModuleName - FileType, FileName, Info0, Info) -->
+ ( { FileType = source } ->
+ %
+ % In some cases the module name won't match the file
+ % name (module mdb.parse might be in parse.m or mdb.m),
+ % so we need to look up the file name here.
+ %
+ get_module_dependencies(ModuleName, MaybeImports, Info0, Info),
+ (
+ { MaybeImports = yes(Imports) },
+ { FileName = Imports ^ source_file_name }
+ ;
+ { MaybeImports = no },
+
+ % Something has gone wrong generating the dependencies,
+ % so just take a punt (which probably won't work).
+ module_name_to_file_name(ModuleName, ".m",
+ no, FileName)
+ )
+ ;
+ { Info = Info0 },
+ globals__io_get_globals(Globals),
+ module_name_to_file_name(ModuleName,
+ target_extension(Globals, FileType), no, FileName)
+ ).
+
+get_file_timestamp(SearchDirs, FileName, MaybeTimestamp, Info0, Info) -->
+ ( { MaybeTimestamp0 = Info0 ^ file_timestamps ^ elem(FileName) } ->
+ { Info = Info0 },
+ { MaybeTimestamp = MaybeTimestamp0 }
+ ;
+ io__input_stream(OldInputStream),
+ search_for_file(SearchDirs, FileName, SearchResult),
+ ( { SearchResult = yes(_) } ->
+ io__input_stream_name(FullFileName),
+ io__set_input_stream(OldInputStream, FileStream),
+ io__close_input(FileStream),
+ io__file_modification_time(FullFileName, TimeTResult),
+ {
+ TimeTResult = ok(TimeT),
+ Timestamp = time_t_to_timestamp(TimeT),
+ MaybeTimestamp = ok(Timestamp)
+ ;
+ TimeTResult = error(Error),
+ MaybeTimestamp = error(
+ io__error_message(Error))
+ },
+ { Info = Info0 ^ file_timestamps
+ ^ elem(FileName) := MaybeTimestamp }
+ ;
+ { MaybeTimestamp = error("file `" ++ FileName
+ ++ "' not found") },
+ { Info = Info0 }
+ )
+ ).
+
+:- pred get_search_directories(module_target_type::in, list(dir_name)::out,
+ io__state::di, io__state::uo) is det.
+
+get_search_directories(FileType, SearchDirs) -->
+ ( { yes(SearchDirOpt) = search_for_file_type(FileType) } ->
+ globals__io_lookup_accumulating_option(SearchDirOpt,
+ SearchDirs)
+ ;
+ { SearchDirs = [dir__this_directory] }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+remove_target_file(ModuleName - FileType, Info0, Info) -->
+ remove_target_file(ModuleName, FileType, Info0, Info).
+
+remove_target_file(ModuleName, FileType, Info0, Info) -->
+ globals__io_get_globals(Globals),
+ remove_file(ModuleName, target_extension(Globals, FileType),
+ Info0, Info1),
+ ( { TimestampExt = timestamp_extension(FileType) } ->
+ remove_file(ModuleName, TimestampExt, Info1, Info)
+ ;
+ { Info = Info1 }
+ ).
+
+remove_file(ModuleName, Ext, Info0, Info) -->
+ module_name_to_file_name(ModuleName, Ext, no, FileName),
+ remove_file(FileName, Info0, Info).
+
+remove_file(FileName, Info0, Info) -->
+ io__remove_file(FileName, _),
+ { Info = Info0 ^ file_timestamps :=
+ map__delete(Info0 ^ file_timestamps, FileName) }.
+
+%-----------------------------------------------------------------------------%
+
+make_target_list(Ks, V) = list__map((func(K) = K - V), Ks).
+
+make_dependency_list(ModuleNames, FileType) =
+ list__map((func(Module) = target(Module - FileType)), ModuleNames).
+
+target_extension(_, source) = ".m".
+target_extension(_, errors) = ".err".
+target_extension(_, private_interface) = ".int0".
+target_extension(_, long_interface) = ".int".
+target_extension(_, short_interface) = ".int2".
+target_extension(_, unqualified_short_interface) = ".int3".
+target_extension(_, intermodule_interface) = ".opt".
+target_extension(_, aditi_code) = ".rlo".
+target_extension(_, c_header) = ".h".
+target_extension(_, c_code) = ".c".
+target_extension(_, il_code) = ".il".
+target_extension(_, il_asm) = ".dll". % XXX ".exe" if the module contains main.
+target_extension(_, java_code) = ".java".
+target_extension(_, asm_code(non_pic)) = ".s".
+target_extension(_, asm_code(pic)) = ".pic_s".
+target_extension(Globals, object_code(non_pic)) = Ext :-
+ globals__lookup_string_option(Globals, object_file_extension, Ext).
+target_extension(Globals, object_code(pic)) = Ext :-
+ globals__lookup_string_option(Globals, pic_object_file_extension, Ext).
+
+linked_target_extension(Globals, executable) = Ext :-
+ globals__lookup_string_option(Globals, executable_file_extension, Ext).
+linked_target_extension(Globals, static_library) = Ext :-
+ globals__lookup_string_option(Globals, library_extension, Ext).
+linked_target_extension(Globals, shared_library) = Ext :-
+ globals__lookup_string_option(Globals, shared_library_extension, Ext).
+
+ % Note that we need a timestamp file for `.err' files because
+ % errors is written to the `.err'. The timestamp is only updated
+ % when compiling to target code.
+timestamp_extension(errors) = ".err_date".
+timestamp_extension(private_interface) = ".date0".
+timestamp_extension(long_interface) = ".date".
+timestamp_extension(short_interface) = ".date".
+timestamp_extension(unqualified_short_interface) = ".date3".
+timestamp_extension(intermodule_interface) = ".optdate".
+timestamp_extension(c_code) = ".c_date".
+timestamp_extension(il_code) = ".il_date".
+timestamp_extension(java_code) = ".java_date".
+timestamp_extension(asm_code(non_pic)) = ".s_date".
+timestamp_extension(asm_code(pic)) = ".pic_s_date".
+
+:- func search_for_file_type(module_target_type) = maybe(option).
+
+search_for_file_type(source) = no.
+search_for_file_type(errors) = no.
+ % XXX only for inter-module optimization.
+search_for_file_type(private_interface) = yes(search_directories).
+search_for_file_type(long_interface) = yes(search_directories).
+search_for_file_type(short_interface) = yes(search_directories).
+search_for_file_type(unqualified_short_interface) = yes(search_directories).
+search_for_file_type(intermodule_interface) = yes(intermod_directories).
+search_for_file_type(aditi_code) = no.
+search_for_file_type(c_header) = yes(c_include_directory).
+search_for_file_type(c_code) = no.
+search_for_file_type(il_code) = no.
+search_for_file_type(il_asm) = no.
+search_for_file_type(java_code) = no.
+search_for_file_type(asm_code(_)) = no.
+search_for_file_type(object_code(_)) = no.
+
+%-----------------------------------------------------------------------------%
+
+debug_msg(P) -->
+ globals__io_lookup_bool_option(debug_make, Debug),
+ ( { Debug = yes } ->
+ P,
+ io__flush_output
+ ;
+ []
+ ).
+
+verbose_msg(P) -->
+ globals__io_lookup_bool_option(verbose_make, Verbose),
+ ( { Verbose = yes } ->
+ P,
+ io__flush_output
+ ;
+ []
+ ).
+
+debug_file_msg(TargetFile, Msg) -->
+ debug_msg(
+ (pred(di, uo) is det -->
+ write_target_file(TargetFile),
+ io__write_string(": "),
+ io__write_string(Msg),
+ io__nl
+ )).
+
+write_dependency_file(target(TargetFile)) --> write_target_file(TargetFile).
+write_dependency_file(file(FileName, _)) --> io__write_string(FileName).
+
+write_target_file(ModuleName - FileType) -->
+ prog_out__write_sym_name(ModuleName),
+ globals__io_get_globals(Globals),
+ io__write_string(target_extension(Globals, FileType)).
+
+maybe_make_linked_target_message(TargetFile) -->
+ verbose_msg(
+ (pred(di, uo) is det -->
+ io__write_string("Making "),
+ io__write_string(TargetFile),
+ io__nl
+ )).
+
+maybe_make_target_message(TargetFile) -->
+ io__output_stream(OutputStream),
+ maybe_make_target_message(OutputStream, TargetFile).
+
+maybe_make_target_message(OutputStream, TargetFile) -->
+ verbose_msg(
+ (pred(di, uo) is det -->
+ io__set_output_stream(OutputStream, OldOutputStream),
+ io__write_string("Making "),
+ write_target_file(TargetFile),
+ io__nl,
+ io__set_output_stream(OldOutputStream, _)
+ )).
+
+target_file_error(TargetFile) -->
+ io__write_string("** Error making `"),
+ write_target_file(TargetFile),
+ io__write_string("'.\n").
+
+file_error(TargetFile) -->
+ io__write_string("** Error making `"),
+ io__write_string(TargetFile),
+ io__write_string("'.\n").
+
+%-----------------------------------------------------------------------------%
Index: compiler/options_file.m
===================================================================
RCS file: compiler/options_file.m
diff -N compiler/options_file.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/options_file.m 4 Feb 2002 02:36:59 -0000
@@ -0,0 +1,986 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2002 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+% File: options_file.m
+% Main author: stayl
+%
+% Code to deal with options for `mmc --make', including code to parse
+% an Mmakefile equivalent.
+%-----------------------------------------------------------------------------%
+:- module options_file.
+
+:- interface.
+
+:- import_module list, io, prog_data, std_util.
+
+:- type options_variables.
+
+:- func options_variables_init = options_variables.
+
+:- pred read_options_files(maybe(options_variables)::out,
+ io__state::di, io__state::uo) is det.
+
+ % Look up the DEFAULT_MCFLAGS variable.
+:- pred lookup_default_options(options_variables::in, maybe(list(string))::out,
+ io__state::di, io__state::uo) is det.
+
+ % Look up all the non-module specific options.
+:- pred lookup_mmc_options(options_variables::in, maybe(list(string))::out,
+ io__state::di, io__state::uo) is det.
+
+ % Same as lookup_mmc_module_options, but also adds the
+ % module-specific (MCFLAGS-module) options.
+:- pred lookup_mmc_module_options(options_variables::in, module_name::in,
+ maybe(list(string))::out, io__state::di, io__state::uo) is det.
+
+ % Look up $(MAIN_TARGET).
+:- pred lookup_main_target(options_variables::in, maybe(list(string))::out,
+ io__state::di, io__state::uo) is det.
+
+ % Quote any strings containing whitespace.
+:- func quote_args(list(string)) = list(string).
+
+%-----------------------------------------------------------------------------%
+:- implementation.
+
+:- import_module error_util, globals, options, prog_io, prog_out.
+:- import_module assoc_list, bool, char, dir, exception, map.
+:- import_module require, string, term.
+
+:- type options_variable == string.
+
+:- type options_file_error
+ ---> options_file_error(string).
+
+:- type found_options_file_error
+ ---> found_options_file_error.
+
+:- type options_variables == map(options_variable, options_variable_value).
+
+:- type options_variable_value
+ ---> options_variable_value(
+ list(char),
+ list(string), % split into words.
+ variable_source
+ ).
+
+:- type variable_source
+ ---> options_file
+ ; command_line
+ ; environment
+ .
+
+options_variables_init = map__init.
+
+read_options_files(MaybeVariables) -->
+ promise_only_solution_io(
+ (pred(R::out, di, uo) is cc_multi -->
+ try_io(
+ (pred((Variables1)::out, di, uo) is det -->
+ globals__io_lookup_accumulating_option(options_files,
+ OptionsFiles),
+ { Variables0 = options_variables_init },
+ (
+ { OptionsFiles = [_|_] },
+ list__foldl2(
+ read_options_file(error, search, no),
+ OptionsFiles, Variables0, Variables1)
+ ;
+ { OptionsFiles = [] },
+ read_options_file(no_error, no_search,
+ yes(dir__this_directory),
+ "Mercury.options",
+ Variables0, Variables1)
+ )
+ ), R)
+ ), OptionsFileResult),
+ (
+ { OptionsFileResult = succeeded(Variables) },
+ { MaybeVariables = yes(Variables) }
+ ;
+ { OptionsFileResult = exception(Exception) },
+ { Exception = univ(found_options_file_error) ->
+ MaybeVariables = no
+ ;
+ rethrow(OptionsFileResult)
+ }
+ ;
+ { OptionsFileResult = failed },
+ { error("read_options_files") }
+ ).
+
+:- type error_if_not_exist
+ ---> error
+ ; no_error.
+
+:- type search
+ ---> search
+ ; no_search.
+
+ % read_options_file(ErrorIfNotExist, Search, MaybeDirName,
+ % FileName, Variables0, Variables).
+:- pred read_options_file(error_if_not_exist::in, search::in,
+ maybe(dir_name)::in, string::in, options_variables::in,
+ options_variables::out, io__state::di, io__state::uo) is det.
+
+read_options_file(ErrorIfNotExist, Search, MaybeDirName, OptionsFile0,
+ Variables0, Variables) -->
+ ( { Search = search } ->
+ globals__io_lookup_accumulating_option(
+ options_search_directories, SearchDirs)
+ ;
+ { SearchDirs = [dir__this_directory] }
+ ),
+
+ { dir__split_name(OptionsFile0, OptionsDir, OptionsFile) },
+ (
+ % Is it an absolute pathname?
+ % XXX This won't work on Windows
+ % (but GNU Make does it this way too).
+ { string__index(OptionsDir, 0, dir__directory_separator) }
+ ->
+ { FileToFind = OptionsFile },
+ { Dirs = [OptionsDir] }
+ ;
+ { MaybeDirName = yes(DirName) }
+ ->
+ { FileToFind = OptionsFile },
+ { Dirs = [dir__make_path_name(DirName, OptionsDir)
+ | SearchDirs] }
+ ;
+ { Dirs = SearchDirs },
+ { FileToFind = OptionsFile0 }
+ ),
+ io__input_stream(OldInputStream),
+ search_for_file(Dirs, FileToFind, MaybeDir),
+ (
+ { MaybeDir = yes(FoundDir) },
+ read_options_lines(FoundDir, Variables0, Variables),
+ io__input_stream(OptionsStream),
+ io__set_input_stream(OldInputStream, _),
+ io__close_input(OptionsStream)
+ ;
+ { MaybeDir = no },
+ { Variables = Variables0 },
+ ( { ErrorIfNotExist = error } ->
+ { Dirs = [SingleDir] ->
+ ErrorFile = maybe_add_path_name(SingleDir,
+ OptionsFile)
+ ;
+ ErrorFile = OptionsFile
+ },
+ io__write_string("Error reading options file `"),
+ io__write_string(ErrorFile),
+ io__write_string("'.\n"),
+ io__set_exit_status(1)
+ ;
+ []
+ )
+ ).
+
+:- func maybe_add_path_name(dir_name, file_name) = file_name.
+
+maybe_add_path_name(Dir, File) =
+ ( Dir = dir__this_directory -> File ; dir__make_path_name(Dir, File) ).
+
+:- pred read_options_lines(dir_name::in, options_variables::in,
+ options_variables::out, io__state::di, io__state::uo) is det.
+
+read_options_lines(Dir, Variables0, Variables) -->
+ io__get_line_number(LineNumber),
+ promise_only_solution_io(
+ (pred(R::out, di, uo) is cc_multi -->
+ try_io(
+ (pred((Variables1 - FoundEOF1)::out, di, uo) is det -->
+ read_options_line(FoundEOF1, [], Line0),
+ (
+ { Line0 = [] },
+ { Variables1 = Variables0 }
+ ;
+ { Line0 = [_|_] },
+ { parse_options_line(Line0, ParsedLine) },
+ (
+ { ParsedLine = define_variable(VarName,
+ AddToValue, Value) },
+ update_variable(VarName, AddToValue, Value,
+ Variables0, Variables1)
+ ;
+ { ParsedLine = include_options_files(
+ ErrorIfNotExist,
+ IncludedFilesChars0) },
+ expand_variables(Variables0,
+ IncludedFilesChars0,
+ IncludedFilesChars, UndefVars),
+ report_undefined_variables(UndefVars),
+ { IncludedFileNames =
+ split_into_words(IncludedFilesChars) },
+ list__foldl2(
+ read_options_file(ErrorIfNotExist,
+ search, yes(Dir)),
+ IncludedFileNames,
+ Variables0, Variables1)
+ )
+ )
+ ), R)
+ ), LineResult),
+ (
+ { LineResult = succeeded(Variables2 - FoundEOF) },
+ (
+ { FoundEOF = yes },
+ { Variables = Variables2 }
+ ;
+ { FoundEOF = no },
+ read_options_lines(Dir, Variables2, Variables)
+ )
+ ;
+ { LineResult = exception(Exception) },
+ ( { Exception = univ(options_file_error(Error)) } ->
+ { Variables = Variables0 },
+ io__input_stream_name(FileName),
+ prog_out__write_context(
+ term__context_init(FileName, LineNumber)),
+ io__write_string(Error),
+ io__nl,
+
+ % This will be caught by `read_options_files'.
+ % The open options files aren't closed on
+ % the way up, but we'll be exiting straight
+ % away so that doesn't matter.
+ { throw(found_options_file_error) }
+ ;
+ { rethrow(LineResult) }
+ )
+ ;
+ { LineResult = failed },
+ { error("read_options_lines") }
+ ).
+
+:- pred read_options_line(bool::out, list(char)::in, list(char)::out,
+ io__state::di, io__state::uo) is det.
+
+read_options_line(FoundEOF, Chars0, list__reverse(RevChars)) -->
+ io__ignore_whitespace(SpaceResult),
+ { SpaceResult = error(Error) ->
+ throw(options_file_error(io__error_message(Error)))
+ ;
+ true
+ },
+ read_options_line_2(FoundEOF, Chars0, RevChars).
+
+:- pred read_options_line_2(bool::out, list(char)::in, list(char)::out,
+ io__state::di, io__state::uo) is det.
+
+read_options_line_2(FoundEOF, Chars0, Chars) -->
+ read_item_or_eof(io__read_char, MaybeChar),
+ (
+ { MaybeChar = yes(Char) },
+ ( { Char = '#' } ->
+ skip_comment_line(FoundEOF),
+ { Chars = Chars0 }
+ ; { Char = ('\\') } ->
+ read_item_or_eof(io__read_char, MaybeChar2),
+ (
+ { MaybeChar2 = yes(Char2) },
+ ( { Char2 = '\n' } ->
+ read_options_line_2(FoundEOF, ['\n' | Chars0], Chars)
+ ;
+ read_options_line_2(FoundEOF,
+ [Char2, Char | Chars0], Chars)
+ )
+ ;
+ { MaybeChar2 = no },
+ { FoundEOF = yes },
+ { Chars = [Char | Chars0] }
+ )
+ ; { Char = '\n' } ->
+ { FoundEOF = no },
+ { Chars = Chars0 }
+ ;
+ read_options_line_2(FoundEOF, [Char | Chars0], Chars)
+ )
+ ;
+ { MaybeChar = no },
+ { FoundEOF = yes },
+ { Chars = Chars0 }
+ ).
+
+:- pred update_variable(options_variable::in, bool::in, list(char)::in,
+ options_variables::in, options_variables::out,
+ io__state::di, io__state::uo) is det.
+
+update_variable(VarName, AddToValue, NewValue0, Variables0, Variables) -->
+ expand_variables(Variables0, NewValue0, NewValue1, Undef),
+ report_undefined_variables(Undef),
+ { Words1 = split_into_words(NewValue1) },
+ io__get_environment_var(VarName, MaybeEnvValue),
+ (
+ { MaybeEnvValue = yes(EnvValue) }
+ ->
+ { Value = string__to_char_list(EnvValue) },
+ { Words = split_into_words(Value) },
+ { map__set(Variables0, VarName,
+ options_variable_value(string__to_char_list(EnvValue),
+ Words, environment),
+ Variables) }
+ ;
+ { map__search(Variables0, VarName,
+ options_variable_value(OldValue, OldWords, Source)) }
+ ->
+ (
+ { Source = environment },
+ { Variables = Variables0 }
+ ;
+ { Source = command_line },
+ { Variables = Variables0 }
+ ;
+ { Source = options_file },
+ { AddToValue = yes ->
+ NewValue = OldValue ++ [' ' | NewValue1],
+ Words = OldWords ++ Words1
+ ;
+ NewValue = NewValue1,
+ Words = Words1
+ },
+ { map__set(Variables0, VarName,
+ options_variable_value(NewValue,
+ Words, options_file),
+ Variables) }
+ )
+ ;
+ { map__set(Variables0, VarName,
+ options_variable_value(NewValue1,
+ Words1, options_file),
+ Variables) }
+ ).
+
+:- pred expand_variables(options_variables::in, list(char)::in,
+ list(char)::out, list(string)::out,
+ io__state::di, io__state::uo) is det.
+
+expand_variables(Variables, Chars0, Chars, UndefVars) -->
+ expand_variables_2(Variables, Chars0, [], Chars, [], UndefVars).
+
+:- pred expand_variables_2(options_variables::in, list(char)::in,
+ list(char)::in, list(char)::out,
+ list(string)::in, list(string)::out,
+ io__state::di, io__state::uo) is det.
+
+expand_variables_2(_, [], RevChars, list__reverse(RevChars),
+ Undef, list__reverse(Undef)) --> [].
+expand_variables_2(Variables, [Char | Chars], RevChars0, RevChars,
+ Undef0, Undef) -->
+ ( { Char = '$' } ->
+ (
+ { Chars = [] },
+ { throw(
+ options_file_error("unterminated variable reference")) }
+ ;
+ { Chars = [Char2 | Chars1] },
+ ( { Char2 = '$' } ->
+ expand_variables_2(Variables, Chars1,
+ ['$' | RevChars0], RevChars, Undef0, Undef)
+ ;
+ {
+ ( Char2 = '(', EndChar = ')'
+ ; Char2 = '{', EndChar = '}'
+ )
+ ->
+ parse_variable(VarName0, Chars1, Chars2),
+ ( Chars2 = [EndChar | Chars3] ->
+ Chars4 = Chars3,
+ VarName = VarName0
+ ;
+ throw(options_file_error(
+ "unterminated variable reference"))
+ )
+ ;
+ Chars4 = Chars1,
+ VarName = string__char_to_string(Char2)
+ },
+
+ lookup_variable_chars(Variables, VarName,
+ VarChars, Undef0, Undef1),
+ expand_variables_2(Variables, Chars4,
+ reverse(VarChars) ++ RevChars0,
+ RevChars, Undef1, Undef)
+ )
+ )
+ ;
+ expand_variables_2(Variables, Chars, [Char | RevChars0],
+ RevChars, Undef0, Undef)
+ ).
+
+:- pred report_undefined_variables(list(string)::in,
+ io__state::di, io__state::uo) is det.
+
+report_undefined_variables([]) --> [].
+report_undefined_variables([_|Rest] @ UndefVars) -->
+ globals__io_lookup_bool_option(warn_undefined_options_variables, Warn),
+ ( { Warn = yes } ->
+ io__input_stream_name(FileName),
+ io__get_line_number(LineNumber),
+ { Context = term__context_init(FileName, LineNumber) },
+
+ { error_util__list_to_pieces(
+ list__map((func(Var) = "`" ++ Var ++ "'"), UndefVars),
+ VarList) },
+ { Rest = [], Word = "variable"
+ ; Rest = [_|_], Word = "variables"
+ },
+ { Pieces =
+ [words("Warning: "), words(Word) | VarList]
+ ++ [words("are undefined.")] },
+ write_error_pieces(Context, 0, Pieces),
+
+ globals__io_lookup_bool_option(halt_at_warn, Halt),
+ ( { Halt = yes } ->
+ { throw(found_options_file_error) }
+ ;
+ []
+ )
+ ;
+ []
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- type options_file_line
+ ---> define_variable(
+ options_variable,
+ bool, % Add to any existing value?
+ list(char)
+ )
+ ; include_options_files(
+ error_if_not_exist,
+ list(char)
+ ).
+
+:- pred parse_options_line(list(char)::in, options_file_line::out) is det.
+
+parse_options_line(Line0, OptionsFileLine) :-
+ (
+ ( Line0 = [('-') | Line1] ->
+ ErrorIfNotExist = no_error,
+ Line2 = Line1
+ ;
+ ErrorIfNotExist = error,
+ Line2 = Line0
+ ),
+ list__append(string__to_char_list("include"), Line3, Line2)
+ ->
+ list__takewhile(char__is_whitespace, Line3, _, Line4),
+ OptionsFileLine = include_options_files(
+ ErrorIfNotExist, Line4)
+ ;
+ parse_variable(VarName, Line0, Line1),
+ list__takewhile(char__is_whitespace, Line1, _, Line2),
+ ( Line2 = [('=') | Line3] ->
+ Add = no,
+ Line4 = Line3
+ ; Line2 = [('+'), ('=') | Line3] ->
+ Add = yes,
+ Line4 = Line3
+ ; Line2 = [(':'), ('=') | Line3] ->
+ Add = no,
+ Line4 = Line3
+ ;
+ throw(options_file_error(
+ "expected `=', `:=' or `+=' after `"
+ ++ VarName ++ "'"))
+ ),
+ list__takewhile(char__is_whitespace, Line4, _, VarValue),
+ OptionsFileLine = define_variable(VarName, Add, VarValue)
+ ).
+
+:- pred parse_file_name(file_name::out,
+ list(char)::in, list(char)::out) is det.
+
+parse_file_name(FileName, Chars0, Chars) :-
+ ( Chars0 = ['"' | Chars1] ->
+ parse_string(FileName, Chars1, Chars)
+ ;
+ list__takewhile(isnt(char__is_whitespace), Chars0,
+ FileNameChars, Chars),
+ FileName = string__from_char_list(FileNameChars)
+ ).
+
+:- pred parse_variable(options_variable::out,
+ list(char)::in, list(char)::out) is det.
+
+parse_variable(VarName, Chars0, Chars) :-
+ parse_variable_2(yes, [], VarList, Chars0, Chars),
+ string__from_rev_char_list(VarList, VarName),
+ ( VarName = "" ->
+ list__takewhile(isnt(char__is_whitespace), Chars,
+ FirstWord, _),
+ throw(options_file_error(
+ string__append_list(["expected variable at `",
+ string__from_char_list(FirstWord), "'"])))
+ ;
+ true
+ ).
+
+:- pred parse_variable_2(bool::in, list(char)::in, list(char)::out,
+ list(char)::in, list(char)::out) is det.
+
+parse_variable_2(_, Var, Var, [], []).
+parse_variable_2(IsFirst, Var0, Var, [Char | Chars0], Chars) :-
+ (
+ \+ char__is_whitespace(Char),
+ ( IsFirst = yes ->
+ char__is_alpha(Char)
+ ;
+ ( char__is_alnum_or_underscore(Char)
+ ; Char = ('-')
+ ; Char = ('.')
+ )
+ )
+ ->
+ parse_variable_2(no, [Char | Var0], Var, Chars0, Chars)
+ ;
+ Var = Var0,
+ Chars = [Char | Chars0]
+ ).
+
+:- pred parse_string(string::out, list(char)::in, list(char)::out) is det.
+
+parse_string(String, Chars0, Chars) :-
+ parse_string_chars([], StringChars, Chars0, Chars),
+ String = string__from_rev_char_list(StringChars).
+
+:- pred parse_string_chars(list(char)::in, list(char)::out,
+ list(char)::in, list(char)::out) is det.
+
+parse_string_chars(_, _, [], _) :-
+ throw(options_file_error("unterminated string")).
+parse_string_chars(String0, String, [Char | Chars0], Chars) :-
+ ( Char = '"' ->
+ Chars = Chars0,
+ String = String0
+ ; Char = ('\\') ->
+ (
+ Chars0 = [Char2 | Chars1],
+ ( Char2 = '"' ->
+ String1 = [Char2 | String0]
+ ;
+ String1 = [Char2, Char | String0]
+ ),
+ parse_string_chars(String1, String, Chars1, Chars)
+ ;
+ Chars0 = [],
+ throw(options_file_error("unterminated string"))
+ )
+ ;
+ parse_string_chars([Char | String0], String, Chars0, Chars)
+ ).
+
+:- pred skip_comment_line(bool::out, io__state::di, io__state::uo) is det.
+
+skip_comment_line(FoundEOF) -->
+ read_item_or_eof(io__read_char, MaybeChar),
+ (
+ { MaybeChar = yes(Char) },
+ ( { Char = '\n' } ->
+ { FoundEOF = no }
+ ;
+ skip_comment_line(FoundEOF)
+ )
+ ;
+ { MaybeChar = no },
+ { FoundEOF = yes }
+ ).
+
+:- pred read_item_or_eof(
+ pred(io__result(T), io__state, io__state)::(pred(out, di, uo) is det),
+ maybe(T)::out, io__state::di, io__state::uo) is det.
+
+read_item_or_eof(Pred, MaybeItem) -->
+ Pred(Result),
+ (
+ { Result = ok(Item) },
+ { MaybeItem = yes(Item) }
+ ;
+ { Result = eof },
+ { MaybeItem = no }
+ ;
+ { Result = error(Error) },
+ { throw(options_file_error(io__error_message(Error))) }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- func checked_split_into_words(list(char)) = maybe_error(list(string)).
+
+checked_split_into_words(Chars) = Result :-
+ TryResult =
+ promise_only_solution(
+ (pred(TResult::out) is cc_multi :-
+ try(
+ (pred(Words0::out) is det :-
+ Words0 = split_into_words(Chars)
+ ), TResult)
+ )),
+ (
+ TryResult = succeeded(Words),
+ Result = ok(Words)
+ ;
+ TryResult = failed,
+ error("split_into_words failed")
+ ;
+ TryResult = exception(Exception),
+ ( Exception = univ(options_file_error(Msg)) ->
+ Result = error(Msg)
+ ;
+ rethrow(TryResult)
+ )
+ ).
+
+:- func split_into_words(list(char)) = list(string).
+
+split_into_words(Chars) = list__reverse(split_into_words_2(Chars, [])).
+
+:- func split_into_words_2(list(char), list(string)) = list(string).
+
+split_into_words_2(Chars0, Words0) = Words :-
+ list__takewhile(char__is_whitespace, Chars0, _, Chars1),
+ (
+ Chars1 = [],
+ Words = Words0
+ ;
+ Chars1 = [_|_],
+ get_word(Word, Chars1, Chars),
+ Words = split_into_words_2(Chars, [Word | Words0])
+ ).
+
+:- pred get_word(string::out, list(char)::in, list(char)::out) is det.
+
+get_word(string__from_rev_char_list(RevWord), Chars0, Chars) :-
+ get_word_2([], RevWord, Chars0, Chars).
+
+:- pred get_word_2(list(char)::in, list(char)::out,
+ list(char)::in, list(char)::out) is det.
+
+get_word_2(RevWord, RevWord, [], []).
+get_word_2(RevWord0, RevWord, [Char | Chars0], Chars) :-
+ ( char__is_whitespace(Char) ->
+ Chars = Chars0,
+ RevWord = RevWord0
+ ; Char = '"' ->
+ parse_string_chars([], RevStringChars, Chars0, Chars1),
+ get_word_2(RevStringChars ++ RevWord0, RevWord,
+ Chars1, Chars)
+ ; Char = ('\\') ->
+ (
+ Chars0 = [],
+ RevWord = [Char | RevWord0],
+ Chars = []
+ ;
+ Chars0 = [Char2 | Chars1],
+ get_word_2([Char2 | RevWord0], RevWord,
+ Chars1, Chars)
+ )
+ ;
+ get_word_2([Char | RevWord0], RevWord, Chars0, Chars)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+lookup_main_target(Vars, MaybeMainTarget) -->
+ lookup_variable_words_report_error(Vars,
+ "MAIN_TARGET", MaybeMainTarget).
+
+lookup_default_options(Vars, Result) -->
+ lookup_mmc_maybe_module_options(Vars, default, Result).
+
+lookup_mmc_options(Vars, Result) -->
+ lookup_mmc_maybe_module_options(Vars, non_module_specific, Result).
+
+lookup_mmc_module_options(Vars, ModuleName, Result) -->
+ lookup_mmc_maybe_module_options(Vars,
+ module_specific(ModuleName), Result).
+
+:- pred lookup_mmc_maybe_module_options(options_variables::in,
+ options_variable_class::in, maybe(list(string))::out,
+ io__state::di, io__state::uo) is det.
+
+lookup_mmc_maybe_module_options(Vars, MaybeModuleName, Result) -->
+ { VariableTypes = options_variable_types },
+ list__map_foldl(lookup_options_variable(Vars, MaybeModuleName),
+ VariableTypes, Results),
+ {
+ list__map((pred(yes(Value)::in, Value::out) is semidet),
+ Results, Values)
+ ->
+ assoc_list__from_corresponding_lists(VariableTypes,
+ Values, VariableValues),
+ Result = yes(list__condense(
+ list__map(convert_to_mmc_options, VariableValues)))
+ ;
+ Result = no
+ }.
+
+:- type options_variable_class
+ ---> default
+ ; non_module_specific
+ ; module_specific(module_name)
+ .
+
+
+:- type options_variable_type
+ ---> grade_flags
+ ; mmc_flags
+ ; c_flags
+ ; java_flags
+ ; ilasm_flags
+ ; csharp_flags
+ ; mcpp_flags
+ ; ml_flags
+ ; ml_objs
+ ; ml_libs
+ ; c2init_args
+ ; libraries
+ ; lib_dirs
+ .
+
+:- func options_variable_types = list(options_variable_type).
+
+options_variable_types =
+ [grade_flags, mmc_flags, c_flags, java_flags,
+ ilasm_flags, csharp_flags, mcpp_flags, ml_flags, ml_objs,
+ ml_libs, c2init_args, libraries, lib_dirs].
+
+:- func options_variable_name(options_variable_type) = string.
+
+options_variable_name(grade_flags) = "GRADEFLAGS".
+options_variable_name(mmc_flags) = "MCFLAGS".
+options_variable_name(c_flags) = "CFLAGS".
+options_variable_name(java_flags) = "JAVAFLAGS".
+options_variable_name(ilasm_flags) = "MS_ILASM_FLAGS".
+options_variable_name(mcpp_flags) = "MS_CL_FLAGS".
+options_variable_name(csharp_flags) = "MS_CSC_FLAGS".
+options_variable_name(ml_flags) = "MLFLAGS".
+options_variable_name(ml_objs) = "MLOBJS".
+options_variable_name(ml_libs) = "MLLIBS".
+options_variable_name(c2init_args) = "C2INITARGS".
+options_variable_name(libraries) = "LIBRARIES".
+options_variable_name(lib_dirs) = "LIB_DIRS".
+
+:- func options_variable_type_is_target_specific(options_variable_type) = bool.
+
+options_variable_type_is_target_specific(grade_flags) = no.
+options_variable_type_is_target_specific(mmc_flags) = yes.
+options_variable_type_is_target_specific(c_flags) = yes.
+options_variable_type_is_target_specific(java_flags) = yes.
+options_variable_type_is_target_specific(ilasm_flags) = yes.
+options_variable_type_is_target_specific(mcpp_flags) = yes.
+options_variable_type_is_target_specific(csharp_flags) = yes.
+options_variable_type_is_target_specific(ml_flags) = yes.
+options_variable_type_is_target_specific(ml_objs) = yes.
+options_variable_type_is_target_specific(ml_libs) = yes.
+options_variable_type_is_target_specific(c2init_args) = yes.
+options_variable_type_is_target_specific(libraries) = yes.
+options_variable_type_is_target_specific(lib_dirs) = no.
+
+:- func convert_to_mmc_options(pair(options_variable_type, list(string)))
+ = list(string).
+
+convert_to_mmc_options(VariableType - VariableValue) = OptionsStrings :-
+ MMCOptionType = mmc_option_type(VariableType),
+ (
+ MMCOptionType = mmc_flags,
+ OptionsStrings = VariableValue
+ ;
+ MMCOptionType = option(not_split, OptionName),
+ OptionsStrings = [OptionName,
+ string__join_list(" ", VariableValue)]
+ ;
+ MMCOptionType = option(split, OptionName),
+ OptionsStrings = list__condense(
+ list__map((func(Word) = [OptionName, Word]),
+ VariableValue))
+ ).
+
+:- type mmc_option_type
+ ---> mmc_flags % The options can be passed directly to mmc.
+
+ ; option(split_into_words, option_name :: string)
+ % The options need to be passed as an
+ % argument of an option to mmc.
+ .
+
+ % The split_into_words type specifies whether there should be
+ % one mmc option per word in a variable's value, or just a single
+ % mmc option.
+ % The value of CFLAGS is converted into a single `--cflags' option.
+ % The value of MLOBJS is converted into as multiple
+ % `--link-object' options.
+:- type split_into_words
+ ---> split
+ ; not_split
+ .
+
+:- func mmc_option_type(options_variable_type) = mmc_option_type.
+
+mmc_option_type(grade_flags) = mmc_flags.
+mmc_option_type(mmc_flags) = mmc_flags.
+mmc_option_type(c_flags) = option(not_split, "--cflags").
+mmc_option_type(java_flags) = option(not_split, "--java-flags").
+mmc_option_type(ilasm_flags) = option(not_split, "--ilasm-flags").
+mmc_option_type(mcpp_flags) = option(not_split, "--mcpp-flags").
+mmc_option_type(csharp_flags) = option(not_split, "--csharp-flags").
+mmc_option_type(ml_flags) = option(not_split, "--link-flags").
+mmc_option_type(ml_objs) = option(split, "--link_object").
+mmc_option_type(ml_libs) = option(not_split, "--link-flags").
+mmc_option_type(c2init_args) = option(split, "--init-files").
+mmc_option_type(libraries) = option(split, "--mercury-library").
+mmc_option_type(lib_dirs) = option(split, "--mercury-library-directory").
+
+%-----------------------------------------------------------------------------%
+
+:- pred lookup_options_variable(options_variables::in,
+ options_variable_class::in, options_variable_type::in,
+ maybe(list(string))::out, io__state::di, io__state::uo) is det.
+
+lookup_options_variable(Vars, OptionsVariableClass, FlagsVar, Result) -->
+ { VarName = options_variable_name(FlagsVar) },
+ lookup_variable_words_report_error(Vars, "DEFAULT_" ++ VarName,
+ DefaultFlagsResult),
+ (
+ { OptionsVariableClass = default }
+ ->
+ { FlagsResult = yes([]) },
+ { ExtraFlagsResult = yes([]) }
+ ;
+ lookup_variable_words_report_error(Vars, VarName, FlagsResult),
+ lookup_variable_words_report_error(Vars, VarName,
+ ExtraFlagsResult)
+ ),
+ (
+ { OptionsVariableClass = module_specific(ModuleName) },
+ { options_variable_type_is_target_specific(FlagsVar) = yes }
+ ->
+ { prog_out__sym_name_to_string(ModuleName,
+ ".", ModuleFileNameBase) },
+ { ModuleVarName = VarName ++ "-" ++ ModuleFileNameBase },
+ lookup_variable_words_report_error(Vars, ModuleVarName,
+ ModuleFlagsResult)
+ ;
+ { ModuleFlagsResult = yes([]) }
+ ),
+
+ (
+ { DefaultFlagsResult = yes(DefaultFlags) },
+ { FlagsResult = yes(Flags) },
+ { ExtraFlagsResult = yes(ExtraFlags) },
+ { ModuleFlagsResult = yes(TargetFlags) }
+ ->
+ { Result = yes(list__condense([DefaultFlags,
+ Flags, ExtraFlags, TargetFlags])) }
+ ;
+ { Result = no }
+ ).
+
+:- pred lookup_variable_words_report_error(options_variables::in,
+ options_variable::in, maybe(list(string))::out,
+ io__state::di, io__state::uo) is det.
+
+lookup_variable_words_report_error(Vars, VarName, Result) -->
+ lookup_variable_words(Vars, VarName, Result0),
+ (
+ { Result0 = ok(Words) },
+ { Result = yes(Words) }
+ ;
+ { Result0 = error(Error) },
+ { Result = no },
+ io__write_string(Error),
+ io__nl
+ ).
+
+:- pred lookup_variable_words(options_variables::in, options_variable::in,
+ maybe_error(list(string))::out,
+ io__state::di, io__state::uo) is det.
+
+lookup_variable_words(Vars, VarName, Result) -->
+ io__get_environment_var(VarName, MaybeEnvValue),
+ ( { MaybeEnvValue = yes(EnvValue) } ->
+ { SplitResult = checked_split_into_words(
+ string__to_char_list(EnvValue)) },
+ {
+ SplitResult = ok(EnvWords),
+ Result = ok(EnvWords)
+ ;
+ SplitResult = error(Msg),
+ Result = error(string__append_list(
+ ["Error: in environment variable `",
+ VarName, "': ", Msg]))
+ }
+ ; { map__search(Vars, VarName, MapValue) } ->
+ { MapValue = options_variable_value(_, Words, _) },
+ { Result = ok(Words) }
+ ;
+ { Result = ok([]) }
+ ).
+
+:- pred lookup_variable_chars(options_variables::in, string::in, list(char)::out,
+ list(string)::in, list(string)::out,
+ io__state::di, io__state::uo) is det.
+
+lookup_variable_chars(Variables, Var, Value, Undef0, Undef) -->
+ io__get_environment_var(Var, MaybeValue),
+ {
+ MaybeValue = yes(ValueString),
+ Value = string__to_char_list(ValueString),
+ Undef = Undef0
+ ;
+ MaybeValue = no,
+ (
+ map__search(Variables, Var,
+ options_variable_value(Value0, _, _))
+ ->
+ Value = Value0,
+ Undef = Undef0
+ ;
+ Value = [],
+ Undef = [Var | Undef0]
+ )
+ }.
+
+%-----------------------------------------------------------------------------%
+
+quote_args(Args) = list__map(quote_arg, Args).
+
+:- func quote_arg(string) = string.
+
+quote_arg(Arg0) = Arg :-
+ ArgList = quote_arg_2(string__to_char_list(Arg0)),
+ (
+ list__member(Char, ArgList),
+ ( char__is_whitespace(Char)
+ ; Char = ('\\')
+ ; Char = '"'
+ )
+ ->
+ Arg = "'" ++ string__from_char_list(ArgList) ++ "'"
+ ;
+ Arg = string__from_char_list(ArgList)
+ ).
+
+:- func quote_arg_2(list(char)) = list(char).
+
+quote_arg_2([]) = [].
+quote_arg_2([Char | Chars0]) = Chars :-
+ Chars1 = quote_arg_2(Chars0),
+ ( Char = ('\\') ->
+ Chars = [Char, Char | Chars1]
+ ; Char = '\n' ->
+ Chars = [('\\'), 'n' | Chars1]
+ ; Char = '"' ->
+ Chars = [('\\'), '"' | Chars1]
+ ;
+ Chars = [Char | Chars1]
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list