[m-rev.] diff/for review: break up make_hlds.m
Zoltan Somogyi
zs at cs.mu.OZ.AU
Mon Jul 25 19:24:51 AEST 2005
Divide make_hlds.m into submodules of manageable size.
compiler/make_hlds.m:
Distribute all the code that was previous here to new submodules.
Include those submodules. Keep the existing interface of this module
by defining predicates that do nothing except call the actual
implementation in one of those submodules. The only changes visible
from outside are the renaming of a predicate and the creation of a
second name, make_hlds_qual_info, for qual_info. Both changes are
designed to avoid ambiguity in the presence of intermodule
optimization.
compiler/add_aditi.m:
Submodule for dealing with aditi-specific issues.
compiler/add_class.m:
Submodule for handling typeclasses.
compiler/add_clause.m:
Submodule for handling the general processing of clauses.
compiler/add_pred.m:
Submodule for handling new predicates.
compiler/add_special_pred.m:
Submodule for handling special (unify/compare/index/init) predicates.
compiler/add_type.m:
Submodule for handling new types.
compiler/add_mode.m:
Submodule for handling new insts and modes.
compiler/add_solver.m:
Submodule for handling new solver types.
compiler/add_pragma.m:
Submodule for handling new solver types.
compiler/state_var.m:
Submodule for handling the state variable transformation.
compiler/superhomogeneous.m:
Submodule for converting clauses to superhomogeneous form.
compiler/field_access.m:
Submodule for field access syntax.
compiler/make_hlds_passes.m:
Submodule containing the code performs passes on the item list,
adding things to the HLDS, calling the other submodules as necessary.
compiler/make_hlds_warn.m:
Submodule that looks for constructs that merit warnings.
compiler/make_hlds_error.m:
Submodule containing error messages used by more than one submodule.
compiler/hlds_pred.m:
Since this module defines the clauses_info and proc_id types, move
the predicates that initialize values of that type here as well from
make_hlds.m (deleting an unnecessary parameter from one).
compiler/hlds_pred.m:
compiler/prog_data.m:
Move the type tvar_name_map from from hlds_pred.m to prog_data.m,
since that is where similar maps are.
compiler/check_typeclass.m:
compiler/mercury_compile.m:
Conform to the change to make_hlds_qual_info.
compiler/hlds_out.m:
compiler/prog_out.m:
Replace two identical predicates for printing out lists of strings
in hlds_out.m and make_hlds.m with just one in prog_out.m, since that
is where it belongs in the compiler.
compiler/prog_util.m:
Move some utility predicates for substitutions and term recognition
here from make_hlds.m, since they are needed by more than one
submodule.
Make this module conform to our coding guidelines, and convert it to
four-space indentation to eliminate bad line breaks.
compiler/clause_to_proc.m:
compiler/hlds_code_util.m:
compiler/make_tags.m:
compiler/prog_mode.m:
compiler/quantification.m:
compiler/type_util.m:
Trivial formatting changes.
compiler/notes/compiler_design.html:
Describe the new modules.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/add_aditi.m
===================================================================
RCS file: compiler/add_aditi.m
diff -N compiler/add_aditi.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_aditi.m 25 Jul 2005 08:54:17 -0000
@@ -0,0 +1,602 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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 hlds__make_hlds__add_aditi.
+:- interface.
+
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module hlds__make_hlds__state_var.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module io.
+:- import_module list.
+
+:- inst aditi_update_str
+ ---> "aditi_insert"
+ ; "aditi_delete"
+ ; "aditi_bulk_insert"
+ ; "aditi_bulk_delete"
+ ; "aditi_bulk_modify".
+
+ % See the "Aditi update syntax" section of the
+ % Mercury Language Reference Manual.
+ %
+:- pred transform_aditi_builtin(string::in(aditi_update_str),
+ list(prog_term)::in, prog_context::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+ % Produce an invalid goal when parsing of an Aditi update fails.
+ %
+:- pred invalid_goal(string::in, list(prog_term)::in, hlds_goal_info::in,
+ hlds_goal::out, prog_varset::in, prog_varset::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+:- pred set_pred_owner(sym_name::in, arity::in, string::in, import_status::in,
+ prog_context::in, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+:- pred add_base_relation_index(sym_name::in, arity::in, index_spec::in,
+ import_status::in, prog_context::in, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module check_hlds__type_util.
+:- import_module hlds__goal_util.
+:- import_module hlds__hlds_out.
+:- import_module hlds__make_hlds__add_clause.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module hlds__make_hlds__superhomogeneous.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_io_goal.
+:- import_module parse_tree__prog_io_util.
+:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_util.
+
+:- import_module bool.
+:- import_module int.
+:- import_module map.
+:- import_module require.
+:- import_module set.
+:- import_module std_util.
+:- import_module term.
+:- import_module varset.
+
+%-----------------------------------------------------------------------------%
+
+transform_aditi_builtin(UpdateStr, Args0, Context, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ (
+ ( UpdateStr = "aditi_insert", Update = insert
+ ; UpdateStr = "aditi_delete", Update = delete
+ )
+ ->
+ transform_aditi_tuple_update(UpdateStr, Update, Args0,
+ Context, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ ( UpdateStr = "aditi_bulk_insert", Update = bulk_insert
+ ; UpdateStr = "aditi_bulk_delete", Update = bulk_delete
+ ; UpdateStr = "aditi_bulk_modify", Update = bulk_modify
+ )
+ ->
+ transform_aditi_bulk_update(UpdateStr, Update, Args0,
+ Context, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ error("transform_aditi_builtin")
+ ).
+
+:- pred transform_aditi_tuple_update(string::in, aditi_tuple_update::in,
+ list(prog_term)::in, prog_context::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+transform_aditi_tuple_update(UpdateStr, Update, Args0, Context,
+ Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ % Build an empty goal_info.
+ goal_info_init(Context, GoalInfo),
+
+ %
+ % Syntax -
+ % aditi_insert(p(_DB, X, Y), DB0, DB).
+ %
+ % `p(_DB, X, Y)' is the tuple to insert, not a higher-order term.
+ %
+ ( Args0 = [InsertTupleTerm, AditiState0Term, AditiStateTerm] ->
+ (
+ % Parse the tuple to insert.
+ parse_pred_or_func_and_args(InsertTupleTerm,
+ PredOrFunc, SymName, TupleArgTerms)
+ ->
+ %
+ % Make new variables for the arguments.
+ % The argument list of the `aditi_insert'
+ % goal contains the arguments of the tuple
+ % to insert and the `aditi__state' arguments.
+ %
+ make_fresh_arg_var(AditiState0Term, AditiState0Var, [],
+ !VarSet, !SInfo, !IO),
+ make_fresh_arg_var(AditiStateTerm, AditiStateVar, [],
+ !VarSet, !SInfo, !IO),
+ make_fresh_arg_vars(TupleArgTerms, TupleArgVars,
+ !VarSet, !SInfo, !IO),
+ list__append(TupleArgVars,
+ [AditiState0Var, AditiStateVar], AllArgs),
+ list__length(TupleArgVars, InsertArity),
+
+ PredId = invalid_pred_id,
+ Builtin = aditi_tuple_update(Update, PredId),
+ InsertCallId = PredOrFunc - SymName/InsertArity,
+ Call = generic_call(
+ aditi_builtin(Builtin, InsertCallId),
+ AllArgs, [], det),
+ Goal0 = Call - GoalInfo,
+ CallId = generic_call(aditi_builtin(Builtin,
+ InsertCallId)),
+ list__append(TupleArgTerms,
+ [AditiState0Term, AditiStateTerm],
+ AllArgTerms),
+
+ record_called_pred_or_func(PredOrFunc, SymName, InsertArity,
+ !QualInfo),
+ insert_arg_unifications(AllArgs, AllArgTerms, Context,
+ call(CallId), Goal0, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO)
+ ;
+ invalid_goal(UpdateStr, Args0, GoalInfo,
+ Goal, !VarSet, !SInfo, !IO),
+ qual_info_set_found_syntax_error(yes, !QualInfo),
+ io__set_exit_status(1, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: expected tuple to ", !IO),
+ io__write(Update, !IO),
+ io__write_string(" in `", !IO),
+ io__write_string(UpdateStr, !IO),
+ io__write_string("'.\n", !IO)
+ )
+ ;
+ invalid_goal(UpdateStr, Args0, GoalInfo, Goal, !VarSet,
+ !SInfo, !IO),
+ qual_info_set_found_syntax_error(yes, !QualInfo),
+ list__length(Args0, Arity),
+ aditi_update_arity_error(Context, UpdateStr, Arity, [3], !IO)
+ ).
+
+ % Parse an `aditi_delete' or `aditi_modify' goal.
+ %
+:- pred transform_aditi_bulk_update(string::in, aditi_bulk_update::in,
+ list(prog_term)::in, prog_context::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+transform_aditi_bulk_update(Descr, Update, Args0, Context, UpdateGoal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ goal_info_init(Context, GoalInfo),
+ (
+ list__length(Args0, Arity),
+ Arity \= 3,
+ Arity \= 4
+ ->
+ invalid_goal(Descr, Args0, GoalInfo, UpdateGoal, !VarSet, !SInfo, !IO),
+ qual_info_set_found_syntax_error(yes, !QualInfo),
+ aditi_update_arity_error(Context, Descr, Arity, [3, 4], !IO)
+ ;
+ %
+ % First syntax -
+ % aditi_insert((p(X, Y, _DB0) :- X = 2, Y = 1), DB0, DB).
+ % or
+ % aditi_delete((p(X, Y, _DB0) :- X = 2), DB0, DB).
+ % or
+ % aditi_modify((p(X0, Y0, _DB0) ==> p(X0, Y, _DB) :-
+ % X0 < 100, Y = Y0 + 1), DB0, DB).
+ %
+ Args0 = [HOTerm, AditiState0Term, AditiStateTerm],
+ parse_rule_term(Context, HOTerm, HeadTerm, GoalTerm1),
+ (
+ Update = bulk_insert,
+ parse_pred_or_func_and_args(HeadTerm, PredOrFunc, SymName,
+ HeadArgs1),
+ list__length(HeadArgs1, PredArity)
+ ;
+ Update = bulk_delete,
+ parse_pred_or_func_and_args(HeadTerm,
+ PredOrFunc, SymName, HeadArgs1),
+ list__length(HeadArgs1, PredArity)
+ ;
+ Update = bulk_modify,
+ HeadTerm = term__functor(term__atom("==>"),
+ [LeftHeadTerm, RightHeadTerm], _),
+ parse_pred_or_func_and_args(LeftHeadTerm,
+ PredOrFunc, SymName, LeftHeadArgs),
+ parse_pred_or_func_and_args(RightHeadTerm,
+ PredOrFunc, SymName, RightHeadArgs),
+ list__append(LeftHeadArgs, RightHeadArgs, HeadArgs1),
+ list__length(LeftHeadArgs, PredArity),
+ list__length(RightHeadArgs, PredArity)
+ )
+ ->
+ %
+ % This syntax is transformed into a construction of
+ % a lambda expression for the modification condition
+ % and a call to an update goal with that closure.
+ % The transformed code is equivalent to the
+ % `sym_name_and_closure' syntax which is parsed below.
+ %
+ Syntax = pred_term,
+
+ %
+ % Parse the modification goal as for a lambda expression.
+ %
+ make_fresh_arg_vars(HeadArgs1, HeadArgs, !VarSet, !SInfo, !IO),
+ term__coerce(GoalTerm1, GoalTerm),
+ parse_goal(GoalTerm, ParsedGoal, !VarSet),
+
+ prepare_for_lambda(!SInfo),
+
+ hlds_goal__true_goal(PredHead0),
+ ArgContext = head(PredOrFunc, PredArity),
+ insert_arg_unifications(HeadArgs, HeadArgs1, Context, ArgContext,
+ PredHead0, PredHead, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
+
+ map__init(Substitution),
+ transform_goal(ParsedGoal, Substitution, PredBody,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ finish_head_and_body(Context, FinalSVarMap, PredHead, PredBody,
+ PredGoal0, !.SInfo),
+
+ % Quantification will reduce this down to
+ % the proper set of nonlocal arguments.
+ goal_util__goal_vars(PredGoal, LambdaGoalVars0),
+ set__delete_list(LambdaGoalVars0, HeadArgs, LambdaGoalVars1),
+ set__to_sorted_list(LambdaGoalVars1, LambdaNonLocals),
+ aditi_bulk_update_goal_info(Update,
+ PredOrFunc, SymName, PredArity, HeadArgs,
+ LambdaPredOrFunc, EvalMethod, LambdaModes,
+ Detism, PredGoal0, PredGoal),
+ ModifiedCallId = PredOrFunc - SymName/PredArity,
+
+ PredId = invalid_pred_id,
+ Builtin = aditi_bulk_update(Update, PredId, Syntax),
+ MainContext =
+ call(generic_call(
+ aditi_builtin(Builtin, ModifiedCallId)),
+ 1),
+ varset__new_var(!.VarSet, LambdaVar, !:VarSet),
+
+ % Tell purity.m to change the mode of the `aditi__state'
+ % arguments of the closure to `unused', to make sure
+ % that the closure does not call any Aditi relations.
+ % We don't know which argument is the `aditi__state' until
+ % after typechecking.
+ % The `aditi__state's are passed even though they are not
+ % used to make the arguments of the closure match the
+ % arguments of the relation being updated.
+ FixModes = modes_need_fixing,
+
+ % Build the lambda expression for the modification condition.
+ make_atomic_unification(LambdaVar,
+ lambda_goal((pure), LambdaPredOrFunc, EvalMethod,
+ FixModes, LambdaNonLocals,
+ HeadArgs, LambdaModes, Detism, PredGoal),
+ Context, MainContext, [], LambdaConstruct, !QualInfo),
+
+ make_fresh_arg_var(AditiState0Term, AditiState0Var, [],
+ !VarSet, !SInfo, !IO),
+ make_fresh_arg_var(AditiStateTerm, AditiStateVar, [],
+ !VarSet, !SInfo, !IO),
+ AllArgs = [LambdaVar, AditiState0Var, AditiStateVar],
+
+ % post_typecheck.m will fill this in.
+ GenericCallModes = [],
+
+ Call = generic_call(aditi_builtin(Builtin, ModifiedCallId),
+ AllArgs, GenericCallModes, det) - GoalInfo,
+
+ %
+ % Wrap an explicit quantification around the goal to make
+ % sure that the closure construction and the
+ % `aditi_delete' or `aditi_modify' call are not separated.
+ % Separating the goals would make optimization of the update
+ % using indexes more difficult.
+ %
+ UpdateConj = scope(barrier(not_removable),
+ conj([LambdaConstruct, Call]) - GoalInfo) - GoalInfo,
+
+ CallId = call(generic_call(
+ aditi_builtin(Builtin, ModifiedCallId))),
+
+ record_called_pred_or_func(PredOrFunc, SymName, PredArity, !QualInfo),
+ insert_arg_unifications(AllArgs,
+ [term__variable(LambdaVar), AditiState0Term, AditiStateTerm],
+ Context, CallId, UpdateConj, UpdateGoal, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO)
+ ;
+ %
+ % Second syntax -
+ % aditi_bulk_delete(pred p/3,
+ % (aditi_bottom_up pred(..) :- ..), DB0, DB).
+ %
+ % The `pred_term' syntax parsed above is transformed
+ % into the equivalent of this syntax.
+ %
+ Args0 = [PredCallIdTerm | OtherArgs0],
+ OtherArgs0 = [_, _, _],
+
+ parse_pred_or_func_name_and_arity(PredCallIdTerm, PredOrFunc, SymName,
+ Arity0),
+ adjust_func_arity(PredOrFunc, Arity0, Arity)
+ ->
+ Syntax = sym_name_and_closure,
+
+ make_fresh_arg_vars(OtherArgs0, OtherArgs, !VarSet, !SInfo, !IO),
+ PredId = invalid_pred_id,
+
+ Builtin = aditi_bulk_update(Update, PredId, Syntax),
+
+ ModifiedCallId = PredOrFunc - SymName/Arity,
+
+ % post_typecheck.m will fill this in.
+ GenericCallModes = [],
+
+ Call = generic_call(aditi_builtin(Builtin, ModifiedCallId),
+ OtherArgs, GenericCallModes, det) - GoalInfo,
+ CallId = call(generic_call(aditi_builtin(Builtin, ModifiedCallId))),
+ record_called_pred_or_func(PredOrFunc, SymName, Arity, !QualInfo),
+ insert_arg_unifications(OtherArgs, OtherArgs0, Context, CallId,
+ Call, UpdateGoal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ invalid_goal(Descr, Args0, GoalInfo, UpdateGoal, !VarSet, !SInfo, !IO),
+ qual_info_set_found_syntax_error(yes, !QualInfo),
+ io__set_exit_status(1, !IO),
+ output_expected_aditi_update_syntax(Context, Update, !IO)
+ ).
+
+:- pred aditi_bulk_update_goal_info(aditi_bulk_update::in, pred_or_func::in,
+ sym_name::in, arity::in, list(prog_var)::in, pred_or_func::out,
+ lambda_eval_method::out, list(mode)::out, determinism::out,
+ hlds_goal::in, hlds_goal::out) is det.
+
+aditi_bulk_update_goal_info(bulk_insert, PredOrFunc, _SymName,
+ PredArity, _Args, LambdaPredOrFunc, EvalMethod,
+ LambdaModes, Detism, Goal, Goal) :-
+ LambdaPredOrFunc = PredOrFunc,
+ EvalMethod = (aditi_bottom_up),
+ out_mode(OutMode),
+ Detism = nondet,
+ % Modes for the arguments of the input tuple.
+ list__duplicate(PredArity, OutMode, LambdaModes).
+
+aditi_bulk_update_goal_info(bulk_delete, PredOrFunc,
+ SymName, PredArity, Args, LambdaPredOrFunc, EvalMethod,
+ LambdaModes, Detism, Goal0, Goal) :-
+ LambdaPredOrFunc = PredOrFunc,
+ EvalMethod = (aditi_bottom_up),
+ Detism = nondet,
+ out_mode(OutMode),
+ list__duplicate(PredArity, OutMode, LambdaModes),
+
+ % Join the result of the deletion goal with the relation to be updated.
+ conjoin_aditi_update_goal_with_call(PredOrFunc, SymName,
+ Args, Goal0, Goal).
+
+aditi_bulk_update_goal_info(bulk_modify, PredOrFunc,
+ SymName, PredArity, Args, LambdaPredOrFunc, EvalMethod,
+ LambdaModes, Detism, Goal0, Goal) :-
+
+ % The closure passed to `aditi_modify' and `aditi_bulk_modify'
+ % is always a predicate closure.
+ LambdaPredOrFunc = predicate,
+
+ out_mode(OutMode),
+ EvalMethod = (aditi_bottom_up),
+ Detism = nondet,
+
+ % Modes for the arguments corresponding to the input tuple.
+ list__duplicate(PredArity, OutMode, DeleteModes),
+
+ % `Args' must have length `PredArity * 2', so this will always succeed.
+ ( list__take(PredArity, Args, CallArgs0) ->
+ CallArgs = CallArgs0
+ ;
+ error("aditi_delete_insert_delete_modify_goal_info")
+ ),
+
+ % Join the result of the modify goal with the relation to be updated.
+ conjoin_aditi_update_goal_with_call(PredOrFunc, SymName,
+ CallArgs, Goal0, Goal),
+
+ % Modes for the arguments corresponding to the output tuple.
+ list__duplicate(PredArity, OutMode, InsertModes),
+ list__append(DeleteModes, InsertModes, LambdaModes).
+
+:- pred conjoin_aditi_update_goal_with_call(pred_or_func::in, sym_name::in,
+ list(prog_var)::in, hlds_goal::in, hlds_goal::out) is det.
+
+conjoin_aditi_update_goal_with_call(PredOrFunc, SymName, Args, Goal0, Goal) :-
+ PredId = invalid_pred_id,
+ Goal0 = _ - GoalInfo,
+
+ % The predicate is recorded as used in
+ % transform_aditi_tuple_update and
+ % transform_aditi_insert_delete_modify
+ do_construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args,
+ GoalInfo, CallGoal),
+
+ Goal = conj([CallGoal, Goal0]) - GoalInfo.
+
+:- pred output_expected_aditi_update_syntax(prog_context::in,
+ aditi_bulk_update::in, io::di, io::uo) is det.
+
+output_expected_aditi_update_syntax(Context, bulk_insert, !IO) :-
+ output_insert_or_delete_expected_syntax(Context, "aditi_bulk_insert", !IO).
+output_expected_aditi_update_syntax(Context, bulk_delete, !IO) :-
+ output_insert_or_delete_expected_syntax(Context, "aditi_bulk_delete", !IO).
+output_expected_aditi_update_syntax(Context, bulk_modify, !IO) :-
+ Name = "aditi_bulk_modify",
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: expected\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" `", !IO),
+ io__write_string(Name, !IO),
+ io__write_string("(\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" (p(<Args0>) ==> p(<Args>) :- <Goal>),\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string( " DB0, DB)'\n", !IO),
+ output_aditi_closure_syntax(Context, Name, !IO).
+
+:- pred output_insert_or_delete_expected_syntax(prog_context::in, string::in,
+ io::di, io::uo) is det.
+
+output_insert_or_delete_expected_syntax(Context, Name, !IO) :-
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: expected `", !IO),
+ io__write_string(Name, !IO),
+ io__write_string("((p(<Args>) :- <Goal>), DB0, DB)'\n", !IO),
+ output_aditi_closure_syntax(Context, Name, !IO).
+
+:- pred output_aditi_closure_syntax(prog_context::in, string::in,
+ io::di, io::uo) is det.
+
+output_aditi_closure_syntax(Context, Name, !IO) :-
+ prog_out__write_context(Context, !IO),
+ io__write_string(" or `", !IO),
+ io__write_string(Name, !IO),
+ io__write_string("(PredOrFunc p/N, Closure, DB0, DB)'.\n", !IO).
+
+ % Report an error for an Aditi update with the wrong number
+ % of arguments.
+ %
+:- pred aditi_update_arity_error(prog_context::in, string::in, int::in,
+ list(int)::in, io::di, io::uo) is det.
+
+aditi_update_arity_error(Context, UpdateStr, Arity, ExpectedArities, !IO) :-
+ io__set_exit_status(1, !IO),
+ MaybePredOrFunc = no,
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: ", !IO),
+ MaybePredOrFunc = no,
+ report_error_num_args(MaybePredOrFunc, Arity, ExpectedArities, !IO),
+ io__nl(!IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" in `", !IO),
+ io__write_string(UpdateStr, !IO),
+ io__write_string("'.\n", !IO).
+
+invalid_goal(UpdateStr, Args0, GoalInfo, Goal, !VarSet, !SInfo, !IO) :-
+ make_fresh_arg_vars(Args0, HeadVars, !VarSet, !SInfo, !IO),
+ MaybeUnifyContext = no,
+ Goal = call(invalid_pred_id, invalid_proc_id, HeadVars, not_builtin,
+ MaybeUnifyContext, unqualified(UpdateStr)) - GoalInfo.
+
+set_pred_owner(Name, Arity, Owner, Status, Context, !ModuleInfo, !IO) :-
+ SetOwner = (pred(PredInfo0::in, PredInfo::out) is det :-
+ pred_info_set_aditi_owner(Owner, PredInfo0, PredInfo)
+ ),
+ MarkerMustBeExported = yes,
+ do_add_pred_marker("owner", Name, Arity, Status, MarkerMustBeExported,
+ Context, SetOwner, !ModuleInfo, _, !IO).
+
+add_base_relation_index(Name, Arity, Index, Status, Context, !ModuleInfo,
+ !IO) :-
+ AddIndex = (pred(PredInfo0::in, PredInfo::out) is det :-
+ pred_info_get_indexes(PredInfo0, Indexes0),
+ Indexes = [Index | Indexes0],
+ pred_info_set_indexes(Indexes, PredInfo0, PredInfo)
+ ),
+ MarkerMustBeExported = yes,
+ do_add_pred_marker("aditi_index", Name, Arity, Status,
+ MarkerMustBeExported, Context, AddIndex, !ModuleInfo, PredIds, !IO),
+ Index = index_spec(_, Attrs),
+ list__foldl(check_index_attribute(Name, Arity, Context), Attrs, !IO),
+ list__foldl(
+ check_index_attribute_pred(!.ModuleInfo, Name, Arity, Context, Attrs),
+ PredIds, !IO).
+
+ % Check that the index attributes are legal for the predicate's arity.
+ %
+:- pred check_index_attribute(sym_name::in, arity::in, term__context::in,
+ int::in, io::di, io::uo) is det.
+
+check_index_attribute(Name, Arity, Context, Attr, !IO) :-
+ (
+ Attr > 0,
+ Attr =< Arity
+ ->
+ true
+ ;
+ prog_out__write_context(Context, !IO),
+ io__write_string("In `:- pragma aditi_index' declaration for `", !IO),
+ prog_out__write_sym_name_and_arity(Name/Arity, !IO),
+ io__write_string("':\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" attribute ", !IO),
+ io__write_int(Attr, !IO),
+ io__write_string(" is out of range.\n", !IO),
+ io__set_exit_status(1, !IO)
+ ).
+
+ % Check that a relation with an index specified is a base relation
+ % and that the indexed attributes do not include aditi__states.
+ %
+:- pred check_index_attribute_pred(module_info::in, sym_name::in, arity::in,
+ term__context::in, list(int)::in, pred_id::in, io::di, io::uo) is det.
+
+check_index_attribute_pred(ModuleInfo, Name, Arity, Context, Attrs, PredId,
+ !IO) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_markers(PredInfo, Markers),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+ ( check_marker(Markers, base_relation) ->
+ true
+ ;
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma aditi_index' declaration", !IO),
+ io__nl(!IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, Name/Arity, !IO),
+ io__write_string(" without preceding\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" `:- pragma base_relation' declaration.\n", !IO),
+ io__set_exit_status(1, !IO)
+ ),
+
+ pred_info_arg_types(PredInfo, ArgTypes),
+ AttrIsAditiState = (pred(Attr::in) is semidet :-
+ list__index0(ArgTypes, Attr, ArgType),
+ type_is_aditi_state(ArgType)
+ ),
+ list__filter(AttrIsAditiState, Attrs, AditiStateAttrs),
+ ( AditiStateAttrs = [AditiStateAttr | _] ->
+ % Indexing on aditi__state attributes is pretty silly,
+ % since they're removed by magic.m.
+ prog_out__write_context(Context, !IO),
+ io__write_string("In `:- pragma aditi_index' declaration for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, Name/Arity, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" attribute ", !IO),
+ io__write_int(AditiStateAttr, !IO),
+ io__write_string(" is an aditi__state.\n", !IO),
+ io__set_exit_status(1, !IO)
+ ;
+ true
+ ).
Index: compiler/add_class.m
===================================================================
RCS file: compiler/add_class.m
diff -N compiler/add_class.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_class.m 25 Jul 2005 04:10:56 -0000
@@ -0,0 +1,559 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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 hlds__make_hlds__add_class.
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module io.
+:- import_module list.
+:- import_module term.
+
+:- pred module_add_class_defn(list(prog_constraint)::in,
+ list(prog_fundep)::in, sym_name::in, list(tvar)::in, class_interface::in,
+ tvarset::in, prog_context::in, item_status::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+:- pred module_add_instance_defn(module_name::in, list(prog_constraint)::in,
+ sym_name::in, list(type)::in, instance_body::in, tvarset::in,
+ import_status::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+ % Given the definition for a predicate or function from a
+ % type class instance declaration, produce the clauses_info
+ % for that definition.
+ %
+:- pred do_produce_instance_method_clauses(instance_proc_def::in,
+ pred_or_func::in, arity::in, list(type)::in, pred_markers::in,
+ term__context::in, import_status::in, clauses_info::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module check_hlds__clause_to_proc.
+:- import_module check_hlds__type_util.
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_goal.
+:- import_module hlds__make_hlds__add_clause.
+:- import_module hlds__make_hlds__add_pred.
+:- import_module hlds__make_hlds__add_type.
+:- import_module hlds__make_hlds__make_hlds_error.
+:- import_module hlds__make_hlds__make_hlds_warn.
+:- import_module hlds__make_hlds__state_var.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_type.
+:- import_module parse_tree__prog_util.
+
+:- import_module bool.
+:- import_module int.
+:- import_module map.
+:- import_module multi_map.
+:- import_module require.
+:- import_module set.
+:- import_module std_util.
+:- import_module string.
+:- import_module varset.
+
+module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface, VarSet,
+ Context, Status, !ModuleInfo, !IO) :-
+ module_info_classes(!.ModuleInfo, Classes0),
+ module_info_superclasses(!.ModuleInfo, SuperClasses0),
+ list__length(Vars, ClassArity),
+ ClassId = class_id(Name, ClassArity),
+ Status = item_status(ImportStatus0, _),
+ ( Interface = abstract ->
+ make_status_abstract(ImportStatus0, ImportStatus1)
+ ;
+ ImportStatus1 = ImportStatus0
+ ),
+ HLDSFunDeps = list__map(make_hlds_fundep(Vars), FunDeps),
+ (
+ % The typeclass is exported if *any* occurrence is exported,
+ % even a previous abstract occurrence.
+ map__search(Classes0, ClassId, OldDefn)
+ ->
+ OldDefn = hlds_class_defn(OldStatus, OldConstraints, OldFunDeps,
+ _OldAncestors, OldVars, OldInterface, OldMethods, OldVarSet,
+ OldContext),
+ combine_status(ImportStatus1, OldStatus, ImportStatus),
+ (
+ OldInterface = concrete(_),
+ ClassMethods0 = OldMethods,
+ ClassInterface = OldInterface
+ ;
+ OldInterface = abstract,
+ ClassMethods0 = [],
+ ClassInterface = Interface
+ ),
+ (
+ \+ superclass_constraints_are_identical(OldVars, OldVarSet,
+ OldConstraints, Vars, VarSet, Constraints)
+ ->
+ % Always report the error, even in `.opt' files.
+ DummyStatus = local,
+ multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
+ Context, OldContext, _, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" The superclass constraints do not match.\n",
+ !IO),
+ io__set_exit_status(1, !IO),
+ ErrorOrPrevDef = yes
+ ;
+ \+ class_fundeps_are_identical(OldFunDeps, HLDSFunDeps)
+ ->
+ % Always report the error, even in `.opt' files.
+ DummyStatus = local,
+ multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
+ Context, OldContext, _, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" The functional dependencies do not match.\n",
+ !IO),
+ io__set_exit_status(1, !IO),
+ ErrorOrPrevDef = yes
+ ;
+ Interface = concrete(_),
+ OldInterface = concrete(_)
+ ->
+ multiple_def_error(ImportStatus, Name, ClassArity,
+ "typeclass", Context, OldContext, _, !IO),
+ ErrorOrPrevDef = yes
+ ;
+ ErrorOrPrevDef = no
+ ),
+
+ IsNewDefn = no
+ ;
+ IsNewDefn = yes `with_type` bool,
+ ErrorOrPrevDef = no `with_type` bool,
+ ClassMethods0 = [],
+ ClassInterface = Interface,
+ ImportStatus = ImportStatus1
+ ),
+ (
+ ErrorOrPrevDef = no,
+ (
+ Interface = concrete(Methods),
+ module_add_class_interface(Name, Vars, Methods,
+ Status, PredProcIds0, !ModuleInfo, !IO),
+ % Get rid of the `no's from the list of maybes
+ IsYes = (pred(Maybe::in, PredProcId::out) is semidet :-
+ Maybe = yes(Pred - Proc),
+ PredProcId = hlds_class_proc(Pred, Proc)
+ ),
+ list__filter_map(IsYes, PredProcIds0, PredProcIds1),
+
+ %
+ % The list must be sorted on pred_id and then
+ % proc_id -- check_typeclass.m assumes this
+ % when it is generating the corresponding list
+ % of pred_proc_ids for instance definitions.
+ %
+ list__sort(PredProcIds1, ClassMethods)
+ ;
+ Interface = abstract,
+ ClassMethods = ClassMethods0
+ ),
+
+ % Ancestors is not set until check_typeclass.
+ Ancestors = [],
+ Defn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
+ Ancestors, Vars, ClassInterface, ClassMethods, VarSet, Context),
+ map__set(Classes0, ClassId, Defn, Classes),
+ module_info_set_classes(Classes, !ModuleInfo),
+
+ (
+ IsNewDefn = yes,
+ update_superclass_table(ClassId, Vars, VarSet, Constraints,
+ SuperClasses0, SuperClasses),
+
+ module_info_set_superclasses(SuperClasses, !ModuleInfo),
+
+ % When we find the class declaration, make an
+ % entry for the instances.
+ module_info_instances(!.ModuleInfo, Instances0),
+ map__det_insert(Instances0, ClassId, [], Instances),
+ module_info_set_instances(Instances, !ModuleInfo)
+ ;
+ IsNewDefn = no
+ )
+ ;
+ ErrorOrPrevDef = yes
+ ).
+
+:- func make_hlds_fundep(list(tvar), prog_fundep) = hlds_class_fundep.
+
+make_hlds_fundep(TVars, fundep(Domain0, Range0)) = fundep(Domain, Range) :-
+ Domain = make_hlds_fundep_2(TVars, Domain0),
+ Range = make_hlds_fundep_2(TVars, Range0).
+
+:- func make_hlds_fundep_2(list(tvar), list(tvar)) = set(hlds_class_argpos).
+
+make_hlds_fundep_2(TVars, List) = list.foldl(Func, List, set.init) :-
+ Func = (func(TVar, Set0) = set.insert(Set0, N) :-
+ N = get_list_index(TVars, 1, TVar)
+ ).
+
+:- func get_list_index(list(T), hlds_class_argpos, T) = hlds_class_argpos.
+
+get_list_index([], _, _) = _ :-
+ error("get_list_index: element not found").
+get_list_index([E | Es], N, X) =
+ ( X = E ->
+ N
+ ;
+ get_list_index(Es, N + 1, X)
+ ).
+
+:- pred superclass_constraints_are_identical(list(tvar)::in, tvarset::in,
+ list(prog_constraint)::in, list(tvar)::in, tvarset::in,
+ list(prog_constraint)::in) is semidet.
+
+superclass_constraints_are_identical(OldVars0, OldVarSet, OldConstraints0,
+ Vars, VarSet, Constraints) :-
+ varset__merge_subst(VarSet, OldVarSet, _, Subst),
+ apply_subst_to_prog_constraint_list(Subst, OldConstraints0,
+ OldConstraints1),
+ OldVars = term__term_list_to_var_list(map__apply_to_list(OldVars0, Subst)),
+
+ map__from_corresponding_lists(OldVars, Vars, VarRenaming),
+ apply_variable_renaming_to_prog_constraint_list(VarRenaming,
+ OldConstraints1, OldConstraints),
+ OldConstraints = Constraints.
+
+:- pred class_fundeps_are_identical(hlds_class_fundeps::in,
+ hlds_class_fundeps::in) is semidet.
+
+class_fundeps_are_identical(OldFunDeps0, FunDeps0) :-
+ % Allow for the functional dependencies to be in a different order.
+ % we rely on the fact that sets (ordered lists) have a canonical
+ % representation.
+ sort_and_remove_dups(OldFunDeps0, OldFunDeps),
+ sort_and_remove_dups(FunDeps0, FunDeps),
+ OldFunDeps = FunDeps.
+
+:- pred module_add_class_interface(sym_name::in, list(tvar)::in,
+ list(class_method)::in, item_status::in,
+ list(maybe(pair(pred_id, proc_id)))::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+module_add_class_interface(Name, Vars, Methods, Status, PredProcIds,
+ !ModuleInfo, !IO) :-
+ module_add_class_interface_2(Name, Vars, Methods, Status, PredProcIds0,
+ !ModuleInfo, !IO),
+ check_method_modes(Methods, PredProcIds0, PredProcIds,
+ !ModuleInfo, !IO).
+
+:- pred module_add_class_interface_2(sym_name::in, list(tvar)::in,
+ list(class_method)::in, item_status::in,
+ list(maybe(pair(pred_id, proc_id)))::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+module_add_class_interface_2(_, _, [], _, [], !ModuleInfo, !IO).
+module_add_class_interface_2(Name, Vars, [M | Ms], Status, [P | Ps],
+ !ModuleInfo, !IO) :-
+ module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !IO),
+ module_add_class_interface_2(Name, Vars, Ms, Status, Ps, !ModuleInfo, !IO).
+
+:- pred module_add_class_method(class_method::in, sym_name::in, list(tvar)::in,
+ item_status::in, maybe(pair(pred_id, proc_id))::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+module_add_class_method(Method, Name, Vars, Status, MaybePredIdProcId,
+ !ModuleInfo, !IO) :-
+ (
+ Method = pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
+ PredName, TypesAndModes, _WithType, _WithInst, MaybeDet, _Cond,
+ Purity, ClassContext, Context),
+ term__var_list_to_term_list(Vars, VarTerms),
+ ClassContext = constraints(UnivCnstrs, ExistCnstrs),
+ NewUnivCnstrs = [constraint(Name, VarTerms) | UnivCnstrs],
+ NewClassContext = constraints(NewUnivCnstrs, ExistCnstrs),
+ init_markers(Markers0),
+ add_marker(class_method, Markers0, Markers),
+ module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
+ PredName, TypesAndModes, MaybeDet, Purity, NewClassContext,
+ Markers, Context, Status, MaybePredIdProcId, !ModuleInfo, !IO)
+ ;
+ Method = pred_or_func_mode(VarSet, MaybePredOrFunc, PredName,
+ Modes, _WithInst, MaybeDet, _Cond, Context),
+ (
+ MaybePredOrFunc = yes(PredOrFunc),
+ Status = item_status(ImportStatus, _),
+ IsClassMethod = yes,
+ module_add_mode(VarSet, PredName, Modes, MaybeDet, ImportStatus,
+ Context, PredOrFunc, IsClassMethod, PredIdProcId, !ModuleInfo,
+ !IO),
+ MaybePredIdProcId = yes(PredIdProcId)
+ ;
+ MaybePredOrFunc = no,
+ % equiv_type.m should have either set the
+ % pred_or_func or removed the item from the list.
+ unexpected(this_file, "module_add_class_method: " ++
+ "no pred_or_func on mode declaration")
+ )
+ ).
+
+ % Insert an entry into the super class table for each super class of
+ % this class.
+ %
+:- pred update_superclass_table(class_id::in, list(tvar)::in, tvarset::in,
+ list(prog_constraint)::in, superclass_table::in, superclass_table::out)
+ is det.
+
+update_superclass_table(ClassId, Vars, VarSet, Constraints, !Supers) :-
+ list.foldl(update_superclass_table_2(ClassId, Vars, VarSet), Constraints,
+ !Supers).
+
+:- pred update_superclass_table_2(class_id::in, list(tvar)::in, tvarset::in,
+ prog_constraint::in, superclass_table::in, superclass_table::out) is det.
+
+update_superclass_table_2(ClassId, Vars, VarSet, Constraint, !Supers) :-
+ Constraint = constraint(SuperName, SuperTypes),
+ list__length(SuperTypes, SuperClassArity),
+ SuperClassId = class_id(SuperName, SuperClassArity),
+ SubClassDetails = subclass_details(SuperTypes, ClassId, Vars, VarSet),
+ multi_map__set(!.Supers, SuperClassId, SubClassDetails, !:Supers).
+
+ % Go through the list of class methods, looking for
+ % - functions without mode declarations: add a default mode
+ % - predicates without mode declarations: report an error
+ % - mode declarations with no determinism: report an error
+:- pred check_method_modes(list(class_method)::in,
+ list(maybe(pair(pred_id, proc_id)))::in,
+ list(maybe(pair(pred_id, proc_id)))::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+check_method_modes([], !PredProcIds, !ModuleInfo, !IO).
+check_method_modes([Method | Methods], !PredProcIds, !ModuleInfo, !IO) :-
+ (
+ Method = pred_or_func(_, _, _, PorF, QualName, TypesAndModes,
+ _WithType, _WithInst, _, _, _, _, _)
+ ->
+ (
+ QualName = qualified(ModuleName0, Name0),
+ ModuleName = ModuleName0,
+ Name = Name0
+ ;
+ QualName = unqualified(_),
+ % The class interface should be fully module qualified
+ % by prog_io.m at the time it is read in.
+ error("add_default_class_method_func_modes: unqualified func")
+ ),
+ list__length(TypesAndModes, PredArity),
+ module_info_get_predicate_table(!.ModuleInfo, PredTable),
+ (
+ predicate_table_search_pf_m_n_a(PredTable, is_fully_qualified,
+ PorF, ModuleName, Name, PredArity, [PredId])
+ ->
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
+ (
+ PorF = function,
+ maybe_add_default_func_mode(PredInfo0, PredInfo, MaybeProc),
+ (
+ MaybeProc = no
+ ;
+ MaybeProc = yes(ProcId),
+ NewPredProc = yes(PredId - ProcId),
+ !:PredProcIds = [NewPredProc | !.PredProcIds],
+ module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
+ )
+ ;
+ PorF = predicate,
+ pred_info_procedures(PredInfo0, Procs),
+ ( map__is_empty(Procs) ->
+ pred_method_with_no_modes_error(PredInfo0, !IO)
+ ;
+ true
+ )
+ )
+ ;
+ error("handle_methods_with_no_modes")
+ )
+ ;
+ true
+ ),
+ check_method_modes(Methods, !PredProcIds, !ModuleInfo, !IO).
+
+module_add_instance_defn(InstanceModuleName, Constraints, ClassName,
+ Types, Body0, VarSet, Status, Context, !ModuleInfo, !IO) :-
+ module_info_classes(!.ModuleInfo, Classes),
+ module_info_instances(!.ModuleInfo, Instances0),
+ list__length(Types, ClassArity),
+ ClassId = class_id(ClassName, ClassArity),
+ Body = expand_bang_state_var_args_in_instance_method_heads(Body0),
+ (
+ map__search(Classes, ClassId, _)
+ ->
+ map__init(Empty),
+ NewInstanceDefn = hlds_instance_defn(InstanceModuleName, Status,
+ Context, Constraints, Types, Body, no, VarSet, Empty),
+ map__lookup(Instances0, ClassId, InstanceDefns),
+ check_for_overlapping_instances(NewInstanceDefn, InstanceDefns,
+ ClassId, !IO),
+ map__det_update(Instances0, ClassId,
+ [NewInstanceDefn | InstanceDefns], Instances),
+ module_info_set_instances(Instances, !ModuleInfo)
+ ;
+ undefined_type_class_error(ClassName, ClassArity, Context,
+ "instance declaration", !IO)
+ ).
+
+:- pred check_for_overlapping_instances(hlds_instance_defn::in,
+ list(hlds_instance_defn)::in, class_id::in, io::di, io::uo) is det.
+
+check_for_overlapping_instances(NewInstanceDefn, InstanceDefns, ClassId,
+ !IO) :-
+ IsOverlapping = (pred((Context - OtherContext)::out) is nondet :-
+ NewInstanceDefn = hlds_instance_defn(_, _Status, Context,
+ _, Types, Body, _, VarSet, _),
+ Body \= abstract, % XXX
+ list__member(OtherInstanceDefn, InstanceDefns),
+ OtherInstanceDefn = hlds_instance_defn(_, _OtherStatus,
+ OtherContext, _, OtherTypes, OtherBody, _, OtherVarSet, _),
+ OtherBody \= abstract, % XXX
+ varset__merge(VarSet, OtherVarSet, OtherTypes, _NewVarSet,
+ NewOtherTypes),
+ type_list_subsumes(Types, NewOtherTypes, _)
+ ),
+ aggregate(IsOverlapping, report_overlapping_instance_declaration(ClassId),
+ !IO).
+
+:- pred report_overlapping_instance_declaration(class_id::in,
+ pair(prog_context)::in, io::di, io::uo) is det.
+
+report_overlapping_instance_declaration(class_id(ClassName, ClassArity),
+ Context - OtherContext, !IO) :-
+ io__set_exit_status(1, !IO),
+ Pieces1 = [words("Error: multiply defined (or overlapping)"),
+ words("instance declarations for class"),
+ sym_name_and_arity(ClassName / ClassArity),
+ suffix("."), nl],
+ Pieces2 = [words("Previous instance declaration was here.")],
+ write_error_pieces(Context, 0, Pieces1, !IO),
+ write_error_pieces(OtherContext, 0, Pieces2, !IO).
+
+do_produce_instance_method_clauses(InstanceProcDefn, PredOrFunc, PredArity,
+ ArgTypes, Markers, Context, Status, ClausesInfo, !ModuleInfo,
+ !QualInfo, !IO) :-
+ (
+ % Handle the `pred(<MethodName>/<Arity>) is <ImplName>' syntax.
+ InstanceProcDefn = name(InstancePredName),
+ % Add the body of the introduced pred.
+ % First the goal info, ...
+ goal_info_init(GoalInfo0),
+ goal_info_set_context(GoalInfo0, Context, GoalInfo1),
+ set__list_to_set(HeadVars, NonLocals),
+ goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo2),
+ ( check_marker(Markers, (impure)) ->
+ goal_info_add_feature(GoalInfo2, (impure), GoalInfo)
+ ; check_marker(Markers, (semipure)) ->
+ goal_info_add_feature(GoalInfo2, (semipure), GoalInfo)
+ ;
+ GoalInfo = GoalInfo2
+ ),
+ % ... and then the goal itself.
+ varset__init(VarSet0),
+ make_n_fresh_vars("HeadVar__", PredArity, HeadVars, VarSet0, VarSet),
+ construct_pred_or_func_call(invalid_pred_id, PredOrFunc,
+ InstancePredName, HeadVars, GoalInfo, IntroducedGoal, !QualInfo),
+ IntroducedClause = clause([], IntroducedGoal, mercury, Context),
+
+ map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
+ map__init(TVarNameMap),
+ rtti_varmaps_init(RttiVarMaps),
+ HasForeignClauses = no,
+ set_clause_list([IntroducedClause], ClausesRep),
+ ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
+ HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses)
+ ;
+ % Handle the arbitrary clauses syntax.
+ InstanceProcDefn = clauses(InstanceClauses),
+ clauses_info_init(PredArity, ClausesInfo0),
+ list__foldl4(
+ produce_instance_method_clause(PredOrFunc, Context, Status),
+ InstanceClauses, !ModuleInfo, !QualInfo,
+ ClausesInfo0, ClausesInfo, !IO)
+ ).
+
+:- pred produce_instance_method_clause(pred_or_func::in,
+ prog_context::in, import_status::in, item::in,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ clauses_info::in, clauses_info::out, io::di, io::uo) is det.
+
+produce_instance_method_clause(PredOrFunc, Context, Status, InstanceClause,
+ !ModuleInfo, !QualInfo, !ClausesInfo, !IO) :-
+ (
+ InstanceClause = clause(CVarSet, PredOrFunc, PredName,
+ HeadTerms0, Body)
+ ->
+ ( illegal_state_var_func_result(PredOrFunc, HeadTerms0, StateVar) ->
+ report_illegal_func_svar_result(Context, CVarSet, StateVar, !IO)
+ ;
+ HeadTerms = expand_bang_state_var_args(HeadTerms0),
+ PredArity = list__length(HeadTerms),
+ adjust_func_arity(PredOrFunc, Arity, PredArity),
+ % The tvarset argument is only used for explicit type
+ % qualifications, of which there are none in this
+ % clause, so it is set to a dummy value.
+ varset__init(TVarSet0),
+
+ ProcIds = [],
+ % means this clause applies to _every_ mode of the procedure
+ GoalType = none, % goal is not a promise
+ clauses_info_add_clause(ProcIds, CVarSet, TVarSet0, HeadTerms,
+ Body, Context, Status, PredOrFunc, Arity, GoalType, Goal,
+ VarSet, _TVarSet, !ClausesInfo, Warnings, !ModuleInfo,
+ !QualInfo, !IO),
+
+ % Warn about singleton variables.
+ maybe_warn_singletons(VarSet, PredOrFunc - PredName/Arity,
+ !.ModuleInfo, Goal, !IO),
+
+ % Warn about variables with overlapping scopes.
+ maybe_warn_overlap(Warnings, VarSet, PredOrFunc - PredName/Arity,
+ !IO)
+ )
+ ;
+ error("produce_clause: invalid instance item")
+ ).
+
+:- pred pred_method_with_no_modes_error(pred_info::in, io::di, io::uo) is det.
+
+pred_method_with_no_modes_error(PredInfo, !IO) :-
+ pred_info_context(PredInfo, Context),
+ Module = pred_info_module(PredInfo),
+ Name = pred_info_name(PredInfo),
+ Arity = pred_info_orig_arity(PredInfo),
+
+ Pieces = [words("Error: no mode declaration for type class method"),
+ words("predicate"),
+ sym_name_and_arity(qualified(Module, Name) / Arity), suffix(".")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- pred undefined_type_class_error(sym_name::in, int::in, prog_context::in,
+ string::in, io::di, io::uo) is det.
+
+undefined_type_class_error(ClassName, Arity, Context, Description, !IO) :-
+ Pieces = [words("Error:"), words(Description), words("for"),
+ sym_name_and_arity(ClassName / Arity),
+ words("without preceding typeclass declaration.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- func this_file = string.
+
+this_file = "add_class.m".
Index: compiler/add_clause.m
===================================================================
RCS file: compiler/add_clause.m
diff -N compiler/add_clause.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_clause.m 25 Jul 2005 08:27:26 -0000
@@ -0,0 +1,1039 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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 hlds__make_hlds__add_clause.
+:- interface.
+
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module hlds__make_hlds__state_var.
+:- import_module hlds__quantification.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module io.
+:- import_module list.
+:- import_module term.
+
+:- pred module_add_clause(prog_varset::in, pred_or_func::in, sym_name::in,
+ list(prog_term)::in, goal::in, import_status::in, prog_context::in,
+ goal_type::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+:- pred clauses_info_add_clause(list(proc_id)::in,
+ prog_varset::in, tvarset::in, list(prog_term)::in, goal::in,
+ prog_context::in, import_status::in, pred_or_func::in, arity::in,
+ goal_type::in, hlds_goal::out, prog_varset::out, tvarset::out,
+ clauses_info::in, clauses_info::out, list(quant_warning)::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+ % Convert goals from the prog_data `goal' structure into the HLDS
+ % `hlds_goal' structure. At the same time, convert it to super-homogeneous
+ % form by unravelling all the complex unifications, and annotate those
+ % unifications with a unify_context so that we can still give good error
+ % messages. And also at the same time, apply the given substitution to
+ % the goal, to rename it apart from the other clauses.
+ %
+:- pred transform_goal(goal::in, prog_substitution::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+:- pred parse_purity_annotation(term(T)::in, purity::out, term(T)::out) is det.
+
+:- pred qualify_lambda_mode_list(list(mode)::in, list(mode)::out,
+ prog_context::in, qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module check_hlds__clause_to_proc.
+:- import_module hlds__goal_util.
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_out.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__add_aditi.
+:- import_module hlds__make_hlds__add_pragma.
+:- import_module hlds__make_hlds__add_pred.
+:- import_module hlds__make_hlds__field_access.
+:- import_module hlds__make_hlds__make_hlds_error.
+:- import_module hlds__make_hlds__make_hlds_warn.
+:- import_module hlds__make_hlds__superhomogeneous.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__module_qual.
+:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_io_util.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_util.
+
+:- import_module bool.
+:- import_module int.
+:- import_module map.
+:- import_module require.
+:- import_module set.
+:- import_module std_util.
+:- import_module string.
+:- import_module term_io.
+:- import_module varset.
+
+module_add_clause(ClauseVarSet, PredOrFunc, PredName, Args0, Body, Status,
+ Context, GoalType, !ModuleInfo, !QualInfo, !IO) :-
+ ( illegal_state_var_func_result(PredOrFunc, Args0, SVar) ->
+ IllegalSVarResult = yes(SVar)
+ ;
+ IllegalSVarResult = no
+ ),
+ ArityAdjustment = ( if IllegalSVarResult = yes(_) then -1 else 0 ),
+ Args = expand_bang_state_var_args(Args0),
+ globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ (
+ VeryVerbose = yes,
+ io__write_string("% Processing clause for ", !IO),
+ write_pred_or_func(PredOrFunc, !IO),
+ io__write_string(" `", !IO),
+ list__length(Args, PredArity0),
+ PredArity = PredArity0 + ArityAdjustment,
+ adjust_func_arity(PredOrFunc, OrigArity, PredArity),
+ prog_out__write_sym_name_and_arity(PredName/OrigArity, !IO),
+ io__write_string("'...\n", !IO)
+ ;
+ VeryVerbose = no
+ ),
+
+ % Lookup the pred declaration in the predicate table.
+ % (If it's not there, call maybe_undefined_pred_error
+ % and insert an implicit declaration for the predicate.)
+ module_info_name(!.ModuleInfo, ModuleName),
+ list__length(Args, Arity0),
+ Arity = Arity0 + ArityAdjustment,
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ (
+ predicate_table_search_pf_sym_arity(PredicateTable0,
+ is_fully_qualified, PredOrFunc, PredName, Arity, [PredId0])
+ ->
+ PredId = PredId0,
+ ( GoalType = promise(_) ->
+ mdbcomp__prim_data__sym_name_to_string(PredName, NameString),
+ string__format("%s %s %s (%s).\n",
+ [s("Attempted to introduce a predicate"),
+ s("for a promise with an identical"),
+ s("name to an existing predicate"),
+ s(NameString)], String),
+ error(String)
+ ;
+ true
+ )
+ ;
+ % A promise will not have a corresponding pred declaration.
+ (
+ GoalType = promise(_)
+ ->
+ term__term_list_to_var_list(Args, HeadVars),
+ preds_add_implicit_for_assertion(HeadVars, !.ModuleInfo,
+ ModuleName, PredName, Arity, Status, Context, PredOrFunc,
+ PredId, PredicateTable0, PredicateTable1),
+ module_info_set_predicate_table(PredicateTable1, !ModuleInfo)
+ ;
+ preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName,
+ Arity, Status, no, Context, user(PredName), "clause", PredId,
+ !ModuleInfo, !IO)
+ )
+ ),
+ % Lookup the pred_info for this pred,
+ % add the clause to the clauses_info in the pred_info,
+ % if there are no modes add an `infer_modes' marker,
+ % and then save the pred_info.
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable2),
+ predicate_table_get_preds(PredicateTable2, Preds0),
+ map__lookup(Preds0, PredId, PredInfo0),
+ % opt_imported preds are initially tagged as imported and are
+ % tagged as opt_imported only if/when we see a clause for them
+ ( Status = opt_imported ->
+ pred_info_set_import_status(opt_imported, PredInfo0, PredInfo0a),
+ pred_info_get_markers(PredInfo0a, Markers0),
+ add_marker(calls_are_fully_qualified, Markers0, Markers1),
+ pred_info_set_markers(Markers1, PredInfo0a, PredInfo1)
+ ;
+ PredInfo1 = PredInfo0
+ ),
+ (
+ IllegalSVarResult = yes(StateVar)
+ ->
+ report_illegal_func_svar_result(Context, ClauseVarSet, StateVar, !IO)
+ ;
+ %
+ % User-supplied clauses for field access functions are
+ % not allowed -- the clauses are always generated by the
+ % compiler.
+ %
+ PredOrFunc = function,
+ adjust_func_arity(function, FuncArity, Arity),
+ is_field_access_function_name(!.ModuleInfo, PredName, FuncArity, _, _),
+
+ % Don't report errors for clauses for field access
+ % function clauses in `.opt' files.
+ Status \= opt_imported
+ ->
+ module_info_incr_errors(!ModuleInfo),
+ CallIdString0 = hlds_out__simple_call_id_to_string(
+ PredOrFunc - PredName/Arity),
+ string__append(CallIdString0, ".", CallIdString),
+ ErrorPieces0 = [
+ words("Error: clause for automatically generated"),
+ words("field access"),
+ fixed(CallIdString),
+ nl
+ ],
+ globals__io_lookup_bool_option(verbose_errors, Verbose, !IO),
+ (
+ Verbose = yes,
+ ErrorPieces1 = [
+ words("Clauses for field access functions"),
+ words("are automatically generated by the"),
+ words("compiler. To supply your own"),
+ words("definition for a field access"),
+ words("function, for example to check"),
+ words("the input to a field update,"),
+ words("give the field of the constructor a"),
+ words("different name.")
+ ],
+ list__append(ErrorPieces0, ErrorPieces1, ErrorPieces)
+ ;
+ Verbose = no,
+ ErrorPieces = ErrorPieces0
+ ),
+ error_util__write_error_pieces(Context, 0, ErrorPieces, !IO)
+ ;
+ % Ignore clauses for builtins. This makes bootstrapping
+ % easier when redefining builtins to use normal Mercury code.
+ pred_info_is_builtin(PredInfo1)
+ ->
+ prog_out__write_context(Context, !IO),
+ report_warning("Warning: clause for builtin.\n", !IO)
+ ;
+ pred_info_clauses_info(PredInfo1, Clauses0),
+ pred_info_typevarset(PredInfo1, TVarSet0),
+ maybe_add_default_func_mode(PredInfo1, PredInfo2, _),
+ select_applicable_modes(Args, ClauseVarSet, Status, Context,
+ PredId, PredInfo2, ArgTerms, ProcIdsForThisClause,
+ !ModuleInfo, !QualInfo, !IO),
+ clauses_info_add_clause(ProcIdsForThisClause, ClauseVarSet, TVarSet0,
+ ArgTerms, Body, Context, Status, PredOrFunc, Arity, GoalType, Goal,
+ VarSet, TVarSet, Clauses0, Clauses, Warnings, !ModuleInfo,
+ !QualInfo, !IO),
+ pred_info_set_clauses_info(Clauses, PredInfo2, PredInfo3),
+ ( GoalType = promise(PromiseType) ->
+ pred_info_set_goal_type(promise(PromiseType), PredInfo3, PredInfo4)
+ ;
+ pred_info_update_goal_type(clauses, PredInfo3, PredInfo4)
+ ),
+ pred_info_set_typevarset(TVarSet, PredInfo4, PredInfo5),
+ pred_info_arg_types(PredInfo5, _ArgTVarSet, ExistQVars, ArgTypes),
+ pred_info_set_arg_types(TVarSet, ExistQVars, ArgTypes,
+ PredInfo5, PredInfo6),
+
+ %
+ % check if there are still no modes for the predicate,
+ % and if so, set the `infer_modes' flag for that predicate
+ %
+ ProcIds = pred_info_all_procids(PredInfo6),
+ ( ProcIds = [] ->
+ pred_info_get_markers(PredInfo6, Markers6),
+ add_marker(infer_modes, Markers6, Markers),
+ pred_info_set_markers(Markers, PredInfo6, PredInfo)
+ ;
+ PredInfo = PredInfo6
+ ),
+ map__det_update(Preds0, PredId, PredInfo, Preds),
+ predicate_table_set_preds(Preds,
+ PredicateTable2, PredicateTable),
+ module_info_set_predicate_table(PredicateTable, !ModuleInfo),
+ ( Status \= opt_imported ->
+ % warn about singleton variables
+ maybe_warn_singletons(VarSet,
+ PredOrFunc - PredName/Arity, !.ModuleInfo,
+ Goal, !IO),
+ % warn about variables with overlapping scopes
+ maybe_warn_overlap(Warnings, VarSet,
+ PredOrFunc - PredName/Arity, !IO)
+ ;
+ true
+ )
+ ).
+
+ % Extract the mode annotations (if any) from the clause arguments,
+ % and determine which mode(s) this clause should apply to.
+ %
+:- pred select_applicable_modes(list(prog_term)::in, prog_varset::in,
+ import_status::in, prog_context::in, pred_id::in, pred_info::in,
+ list(prog_term)::out, list(proc_id)::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+select_applicable_modes(Args0, VarSet, Status, Context, PredId, PredInfo,
+ Args, ProcIds, !ModuleInfo, !QualInfo, !IO) :-
+ get_mode_annotations(Args0, Args, empty, ModeAnnotations),
+ (
+ ModeAnnotations = modes(ModeList0),
+
+ %
+ % The user specified some mode annotations on this clause.
+ % First module-qualify the mode annotations. The annotations
+ % on clauses from `.opt' files will already be fully module
+ % qualified.
+ %
+ ( Status = opt_imported ->
+ ModeList = ModeList0
+ ;
+ qual_info_get_mq_info(!.QualInfo, MQInfo0),
+ module_qual__qualify_clause_mode_list(ModeList0, ModeList, Context,
+ MQInfo0, MQInfo, !IO),
+ qual_info_set_mq_info(MQInfo, !QualInfo)
+ ),
+
+ %
+ % Now find the procedure which matches these mode annotations.
+ %
+ pred_info_procedures(PredInfo, Procs),
+ map__to_assoc_list(Procs, ExistingProcs),
+ (
+ get_procedure_matching_declmodes(ExistingProcs, ModeList,
+ !.ModuleInfo, ProcId)
+ ->
+ ProcIds = [ProcId]
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ undeclared_mode_error(ModeList, VarSet, PredId, PredInfo,
+ !.ModuleInfo, Context, !IO),
+ % apply the clause to all modes
+ % XXX would it be better to apply it to none?
+ ProcIds = pred_info_all_procids(PredInfo)
+ )
+ ;
+ ModeAnnotations = empty,
+ ( pred_info_pragma_goal_type(PredInfo) ->
+ % We are only allowed to mix foreign procs and
+ % mode specific clauses, so make this clause
+ % mode specific but apply to all modes.
+ ProcIds = pred_info_all_procids(PredInfo)
+ ;
+ % this means the clauses applies to all modes
+ ProcIds = []
+ )
+ ;
+ ModeAnnotations = none,
+ ( pred_info_pragma_goal_type(PredInfo) ->
+ % We are only allowed to mix foreign procs and
+ % mode specific clauses, so make this clause
+ % mode specific but apply to all modes.
+ ProcIds = pred_info_all_procids(PredInfo)
+ ;
+ % this means the clauses applies to all modes
+ ProcIds = []
+ )
+ ;
+ ModeAnnotations = mixed,
+ module_info_incr_errors(!ModuleInfo),
+ io__set_exit_status(1, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string("In clause for ", !IO),
+ hlds_out__write_pred_id(!.ModuleInfo, PredId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" syntax error: some but not all " ++
+ "arguments have mode annotations.\n", !IO),
+ % apply the clause to all modes
+ % XXX would it be better to apply it to none?
+ ProcIds = pred_info_all_procids(PredInfo)
+ ).
+
+ % Clauses can have mode annotations on them, to indicate that the
+ % clause should only be used for particular modes of a predicate.
+ % This type specifies the mode annotations on a clause.
+:- type mode_annotations
+ ---> empty % No arguments.
+
+ ; none % One or more arguments,
+ % each without any mode annotations.
+
+ ; modes(list(mode))
+ % One or more arguments, each with a mode annotation.
+
+ ; mixed. % Two or more arguments, including some with mode
+ % annotations and some without. (This is not allowed.)
+
+ % Extract the mode annotations (if any) from a list of arguments.
+ %
+:- pred get_mode_annotations(list(prog_term)::in, list(prog_term)::out,
+ mode_annotations::in, mode_annotations::out) is det.
+
+get_mode_annotations([], [], !Annotations).
+get_mode_annotations([Arg0 | Args0], [Arg | Args], !Annotations) :-
+ get_mode_annotation(Arg0, Arg, MaybeAnnotation),
+ add_annotation(MaybeAnnotation, !Annotations),
+ get_mode_annotations(Args0, Args, !Annotations).
+
+:- pred add_annotation(maybe(mode)::in,
+ mode_annotations::in, mode_annotations::out) is det.
+
+add_annotation(no, empty, none).
+add_annotation(yes(Mode), empty, modes([Mode])).
+add_annotation(no, modes(_ `with_type` list(mode)), mixed).
+add_annotation(yes(Mode), modes(Modes), modes(Modes ++ [Mode])).
+add_annotation(no, none, none).
+add_annotation(yes(_), none, mixed).
+add_annotation(_, mixed, mixed).
+
+ % Extract the mode annotations (if any) from a single argument.
+ %
+:- pred get_mode_annotation(prog_term::in, prog_term::out, maybe(mode)::out)
+ is det.
+
+get_mode_annotation(Arg0, Arg, MaybeAnnotation) :-
+ (
+ Arg0 = term__functor(term__atom("::"), [Arg1, ModeTerm], _),
+ convert_mode(allow_constrained_inst_var, term__coerce(ModeTerm), Mode)
+ ->
+ Arg = Arg1,
+ MaybeAnnotation = yes(Mode)
+ ;
+ Arg = Arg0,
+ MaybeAnnotation = no
+ ).
+
+clauses_info_add_clause(ModeIds0, CVarSet, TVarSet0, Args, Body, Context,
+ Status, PredOrFunc, Arity, GoalType, Goal, VarSet, TVarSet,
+ !ClausesInfo, Warnings, !ModuleInfo, !QualInfo, !IO) :-
+ !.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes0,
+ TVarNameMap0, InferredVarTypes, HeadVars, ClausesRep0,
+ RttiVarMaps, HasForeignClauses),
+ IsEmpty = clause_list_is_empty(ClausesRep0),
+ (
+ IsEmpty = yes,
+ % Create the mapping from type variable name, used to
+ % rename type variables occurring in explicit type
+ % qualifications. The version of this mapping stored
+ % in the clauses_info should only contain type variables
+ % which occur in the argument types of the predicate.
+ % Type variables which only occur in explicit type
+ % qualifications are local to the clause in which they appear.
+ varset__create_name_var_map(TVarSet0, TVarNameMap)
+ ;
+ IsEmpty = no,
+ TVarNameMap = TVarNameMap0
+ ),
+ update_qual_info(TVarNameMap, TVarSet0, ExplicitVarTypes0, Status,
+ !QualInfo),
+ varset__merge_subst(VarSet0, CVarSet, VarSet1, Subst),
+ add_clause_transform(Subst, HeadVars, Args, Body, Context, PredOrFunc,
+ Arity, GoalType, Goal0, VarSet1, VarSet, Warnings, !ModuleInfo,
+ !QualInfo, !IO),
+ qual_info_get_tvarset(!.QualInfo, TVarSet),
+ qual_info_get_found_syntax_error(!.QualInfo, FoundError),
+ qual_info_set_found_syntax_error(no, !QualInfo),
+ (
+ FoundError = yes,
+ % Don't insert clauses containing syntax errors into
+ % the clauses_info, because doing that would cause
+ % typecheck.m to report spurious type errors.
+ % Don't report singleton variable warnings if there
+ % were syntax errors.
+ true_goal(Goal)
+ ;
+ FoundError = no,
+ Goal = Goal0,
+
+ % If we have foreign clauses, we should only add this clause
+ % for modes *not* covered by the foreign clauses.
+ (
+ HasForeignClauses = yes,
+ get_clause_list_any_order(ClausesRep0, AnyOrderClauseList),
+ ForeignModeIds = list__condense(list__filter_map(
+ (func(C) = ProcIds is semidet :-
+ C = clause(ProcIds, _, ClauseLang, _),
+ not ClauseLang = mercury
+ ),
+ AnyOrderClauseList)),
+ ModeIds = list__delete_elems(ModeIds0, ForeignModeIds),
+ (
+ ModeIds = [],
+ ClausesRep = ClausesRep0
+ ;
+ ModeIds = [_ | _],
+ Clause = clause(ModeIds, Goal, mercury, Context),
+ add_clause(Clause, ClausesRep0, ClausesRep)
+ )
+ ;
+ HasForeignClauses = no,
+ Clause = clause(ModeIds0, Goal, mercury, Context),
+ add_clause(Clause, ClausesRep0, ClausesRep)
+ ),
+ qual_info_get_var_types(!.QualInfo, ExplicitVarTypes),
+ !:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
+ InferredVarTypes, HeadVars, ClausesRep, RttiVarMaps,
+ HasForeignClauses)
+ ).
+
+:- pred add_clause_transform(prog_substitution::in, list(prog_var)::in,
+ list(prog_term)::in, goal::in, prog_context::in, pred_or_func::in,
+ arity::in, goal_type::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out, list(quant_warning)::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+add_clause_transform(Subst, HeadVars, Args0, Body0, Context, PredOrFunc, Arity,
+ GoalType, Goal, !VarSet, Warnings, !ModuleInfo, !QualInfo, !IO) :-
+ some [!SInfo] (
+ prepare_for_head(!:SInfo),
+ term__apply_substitution_to_list(Args0, Subst, Args1),
+ substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !IO),
+ hlds_goal__true_goal(HeadGoal0),
+ ( GoalType = promise(_) ->
+ HeadGoal = HeadGoal0
+ ;
+ ArgContext = head(PredOrFunc, Arity),
+ insert_arg_unifications(HeadVars, Args, Context, ArgContext,
+ HeadGoal0, HeadGoal1, !VarSet, !ModuleInfo, !QualInfo, !SInfo,
+ !IO),
+ attach_features_to_all_goals([from_head], HeadGoal1, HeadGoal)
+ ),
+ prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
+ transform_goal(Body0, Subst, Body, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ finish_head_and_body(Context, FinalSVarMap, HeadGoal, Body, Goal0,
+ !.SInfo),
+ qual_info_get_var_types(!.QualInfo, VarTypes0),
+ implicitly_quantify_clause_body(HeadVars, Warnings, Goal0, Goal,
+ !VarSet, VarTypes0, VarTypes),
+ qual_info_set_var_types(VarTypes, !QualInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+transform_goal(Goal0 - Context, Subst, Goal1 - GoalInfo1, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ transform_goal_2(Goal0, Context, Subst, Goal1 - GoalInfo0,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_info_set_context(GoalInfo0, Context, GoalInfo1).
+
+:- pred transform_goal_2(goal_expr::in, prog_context::in,
+ prog_substitution::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+transform_goal_2(fail, _, _, disj([]) - GoalInfo, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ goal_info_init(GoalInfo),
+ prepare_for_next_conjunct(set__init, !VarSet, !SInfo).
+transform_goal_2(true, _, _, conj([]) - GoalInfo, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ goal_info_init(GoalInfo),
+ prepare_for_next_conjunct(set__init, !VarSet, !SInfo).
+transform_goal_2(all(Vars0, Goal0), Context, Subst, Goal, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ % Convert `all [Vars] Goal' into `not some [Vars] not Goal'.
+ TransformedGoal = not(some(Vars0, not(Goal0) - Context) - Context),
+ transform_goal_2(TransformedGoal, Context, Subst, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO).
+transform_goal_2(all_state_vars(StateVars, Goal0), Context, Subst,
+ Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ transform_goal_2(
+ not(some_state_vars(StateVars, not(Goal0) - Context) - Context),
+ Context, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+transform_goal_2(some(Vars0, Goal0), _, Subst,
+ scope(exist_quant(Vars), Goal) - GoalInfo,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ substitute_vars(Vars0, Subst, Vars),
+ transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ goal_info_init(GoalInfo).
+transform_goal_2(some_state_vars(StateVars0, Goal0), _, Subst,
+ scope(exist_quant(Vars), Goal) - GoalInfo,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ BeforeSInfo = !.SInfo,
+ substitute_vars(StateVars0, Subst, StateVars),
+ prepare_for_local_state_vars(StateVars, !VarSet, !SInfo),
+ transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ finish_local_state_vars(StateVars, Vars, BeforeSInfo, !SInfo),
+ goal_info_init(GoalInfo).
+transform_goal_2(promise_purity(Implicit, Purity, Goal0), _, Subst,
+ scope(promise_purity(Implicit, Purity), Goal) - GoalInfo,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ goal_info_init(GoalInfo).
+transform_goal_2(
+ promise_equivalent_solutions(Vars0, DotSVars0, ColonSVars0, Goal0),
+ Context, Subst,
+ scope(promise_equivalent_solutions(Vars), Goal) - GoalInfo,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ substitute_vars(Vars0, Subst, Vars1),
+ substitute_vars(DotSVars0, Subst, DotSVars1),
+ convert_dot_state_vars(Context, DotSVars1, DotSVars, !VarSet, !SInfo, !IO),
+ transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ goal_info_init(GoalInfo),
+ substitute_vars(ColonSVars0, Subst, ColonSVars1),
+ convert_dot_state_vars(Context, ColonSVars1, ColonSVars, !VarSet,
+ !SInfo, !IO),
+ Vars = Vars1 ++ DotSVars ++ ColonSVars.
+transform_goal_2(if_then_else(Vars0, StateVars0, Cond0, Then0, Else0), Context,
+ Subst, if_then_else(Vars, Cond, Then, Else) - GoalInfo,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ BeforeSInfo = !.SInfo,
+ substitute_vars(Vars0, Subst, Vars),
+ substitute_vars(StateVars0, Subst, StateVars),
+ prepare_for_if_then_else_goal(StateVars, !VarSet, !SInfo),
+ transform_goal(Cond0, Subst, Cond, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ finish_if_then_else_goal_condition(StateVars,
+ BeforeSInfo, !.SInfo, AfterCondSInfo, !:SInfo),
+ transform_goal(Then0, Subst, Then1, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ finish_if_then_else_goal_then_goal(StateVars, BeforeSInfo, !SInfo),
+ AfterThenSInfo = !.SInfo,
+ transform_goal(Else0, Subst, Else1, !VarSet, !ModuleInfo, !QualInfo,
+ BeforeSInfo, !:SInfo, !IO),
+ goal_info_init(Context, GoalInfo),
+ finish_if_then_else(Context, Then1, Then, Else1, Else,
+ BeforeSInfo, AfterCondSInfo, AfterThenSInfo, !SInfo, !VarSet).
+transform_goal_2(if_then(Vars0, StateVars, A0, B0), Context, Subst,
+ Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ transform_goal_2(
+ if_then_else(Vars0, StateVars, A0, B0, true - Context),
+ Context, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+transform_goal_2(not(A0), _, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO) :-
+ BeforeSInfo = !.SInfo,
+ transform_goal(A0, Subst, A, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_info_init(GoalInfo),
+ Goal = not(A) - GoalInfo,
+ finish_negation(BeforeSInfo, !SInfo).
+transform_goal_2((A0, B0), _, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO) :-
+ get_rev_conj(A0, Subst, [], R0, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ get_rev_conj(B0, Subst, R0, R, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ L = list__reverse(R),
+ goal_info_init(GoalInfo),
+ conj_list_to_goal(L, GoalInfo, Goal).
+transform_goal_2((A0 & B0), _, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO) :-
+ get_rev_par_conj(B0, Subst, [], R0, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ get_rev_par_conj(A0, Subst, R0, R, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ L = list__reverse(R),
+ goal_info_init(GoalInfo),
+ par_conj_list_to_goal(L, GoalInfo, Goal).
+transform_goal_2((A0 ; B0), Context, Subst, Goal, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ get_disj(B0, Subst, [], L0, !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
+ get_disj(A0, Subst, L0, L1, !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
+ finish_disjunction(Context, !.VarSet, L1, L, !:SInfo),
+ goal_info_init(Context, GoalInfo),
+ disj_list_to_goal(L, GoalInfo, Goal).
+transform_goal_2(implies(P, Q), Context, Subst, Goal, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ % `P => Q' is defined as `not (P, not Q)'
+ TransformedGoal = not( (P, not(Q) - Context) - Context ),
+ transform_goal_2(TransformedGoal, Context, Subst, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO).
+transform_goal_2(equivalent(P0, Q0), _, Subst, Goal, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ %
+ % `P <=> Q' is defined as `(P => Q), (Q => P)',
+ % but that transformation must not be done until
+ % after quantification analysis, lest the duplication of
+ % the goals concerned affect the implicit quantification
+ % of the variables inside them.
+ %
+ BeforeSInfo = !.SInfo,
+ goal_info_init(GoalInfo),
+ transform_goal(P0, Subst, P, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ transform_goal(Q0, Subst, Q, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ Goal = shorthand(bi_implication(P, Q)) - GoalInfo,
+ finish_equivalence(BeforeSInfo, !SInfo).
+transform_goal_2(call(Name, Args0, Purity), Context, Subst, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ Args1 = expand_bang_state_var_args(Args0),
+ (
+ Name = unqualified("\\="),
+ Args1 = [LHS, RHS]
+ ->
+ prepare_for_call(!SInfo),
+ % `LHS \= RHS' is defined as `not (LHS = RHS)'
+ transform_goal_2(not(unify(LHS, RHS, Purity) - Context), Context,
+ Subst, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ finish_call(!VarSet, !SInfo)
+ ;
+ % check for a DCG field access goal:
+ % get: Field =^ field
+ % set: ^ field := Field
+ ( Name = unqualified(Operator) ),
+ ( Operator = "=^"
+ ; Operator = ":="
+ )
+ ->
+ prepare_for_call(!SInfo),
+ term__apply_substitution_to_list(Args1, Subst, Args2),
+ transform_dcg_record_syntax(Operator, Args2, Context,
+ Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ finish_call(!VarSet, !SInfo)
+ ;
+ % check for an Aditi builtin
+ Purity = pure,
+ Name = unqualified(Name1),
+ ( Name1 = "aditi_insert"
+ ; Name1 = "aditi_delete"
+ ; Name1 = "aditi_bulk_insert"
+ ; Name1 = "aditi_bulk_delete"
+ ; Name1 = "aditi_bulk_modify"
+ )
+ ->
+ term__apply_substitution_to_list(Args1, Subst, Args2),
+ transform_aditi_builtin(Name1, Args2, Context, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ prepare_for_call(!SInfo),
+ term__apply_substitution_to_list(Args1, Subst, Args),
+ make_fresh_arg_vars(Args, HeadVars, !VarSet, !SInfo, !IO),
+ list__length(Args, Arity),
+ (
+ % check for a higher-order call,
+ % i.e. a call to either call/N or ''/N.
+ ( Name = unqualified("call")
+ ; Name = unqualified("")
+ ),
+ HeadVars = [PredVar | RealHeadVars]
+ ->
+ % initialize some fields to junk
+ Modes = [],
+ Det = erroneous,
+
+ GenericCall = higher_order(PredVar, Purity, predicate, Arity),
+ Call = generic_call(GenericCall, RealHeadVars, Modes, Det),
+
+ hlds_goal__generic_call_id(GenericCall, CallId)
+ ;
+ % initialize some fields to junk
+ PredId = invalid_pred_id,
+ ModeId = invalid_proc_id,
+
+ MaybeUnifyContext = no,
+ Call = call(PredId, ModeId, HeadVars, not_builtin,
+ MaybeUnifyContext, Name),
+ CallId = call(predicate - Name/Arity)
+ ),
+ goal_info_init(Context, GoalInfo0),
+ add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo),
+ Goal0 = Call - GoalInfo,
+
+ record_called_pred_or_func(predicate, Name, Arity, !QualInfo),
+ insert_arg_unifications(HeadVars, Args, Context, call(CallId),
+ Goal0, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ finish_call(!VarSet, !SInfo)
+ ).
+transform_goal_2(unify(A0, B0, Purity), Context, Subst, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ % It is an error for the left or right hand side of a
+ % unification to be !X (it may be !.X or !:X, however).
+ %
+ ( A0 = functor(atom("!"), [variable(StateVarA)], _) ->
+ report_svar_unify_error(Context, !.VarSet, StateVarA, !IO),
+ true_goal(Goal)
+ ; B0 = functor(atom("!"), [variable(StateVarB)], _) ->
+ report_svar_unify_error(Context, !.VarSet, StateVarB, !IO),
+ true_goal(Goal)
+ ;
+ prepare_for_call(!SInfo),
+ term__apply_substitution(A0, Subst, A),
+ term__apply_substitution(B0, Subst, B),
+ unravel_unification(A, B, Context, explicit, [], Purity, Goal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ finish_call(!VarSet, !SInfo)
+ ).
+
+:- pred convert_dot_state_vars(prog_context::in, prog_vars::in, prog_vars::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
+ io::di, io::uo) is det.
+
+convert_dot_state_vars(_Context, [], [], !VarSet, !SInfo, !IO).
+convert_dot_state_vars(Context, [Dot0 | Dots0], [Dot | Dots],
+ !VarSet, !SInfo, !IO) :-
+ dot(Context, Dot0, Dot, !VarSet, !SInfo, !IO),
+ convert_dot_state_vars(Context, Dots0, Dots, !VarSet, !SInfo, !IO).
+
+:- pred convert_colon_state_vars(prog_context::in,
+ prog_vars::in, prog_vars::out, prog_varset::in, prog_varset::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+convert_colon_state_vars(_Context, [], [], !VarSet, !SInfo, !IO).
+convert_colon_state_vars(Context, [Colon0 | Colons0], [Colon | Colons],
+ !VarSet, !SInfo, !IO) :-
+ colon(Context, Colon0, Colon, !VarSet, !SInfo, !IO),
+ convert_colon_state_vars(Context, Colons0, Colons, !VarSet, !SInfo, !IO).
+
+:- pred report_svar_unify_error(prog_context::in, prog_varset::in, svar::in,
+ io::di, io::uo) is det.
+
+report_svar_unify_error(Context, VarSet, StateVar, !IO) :-
+ Name = varset__lookup_name(VarSet, StateVar),
+ Pieces = [nl, words("Error:"), fixed("!" ++ Name),
+ words("cannot appear as a unification argument."), nl,
+ words("You probably meant"), fixed("!." ++ Name),
+ words("or"), fixed("!:" ++ Name), suffix(".")],
+ write_error_pieces(Context, 0, Pieces, !IO).
+
+:- inst dcg_record_syntax_op == bound("=^"; ":=").
+
+:- pred transform_dcg_record_syntax(string::in(dcg_record_syntax_op),
+ list(prog_term)::in, prog_context::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+transform_dcg_record_syntax(Operator, ArgTerms0, Context, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ goal_info_init(Context, GoalInfo),
+ (
+ ArgTerms0 = [LHSTerm, RHSTerm, TermInputTerm, TermOutputTerm],
+ (
+ Operator = "=^",
+ AccessType = get,
+ FieldNameTerm = RHSTerm,
+ FieldValueTerm = LHSTerm
+ ;
+ Operator = ":=",
+ AccessType = set,
+ LHSTerm = term__functor(term__atom("^"), [FieldNameTerm0], _),
+ FieldNameTerm = FieldNameTerm0,
+ FieldValueTerm = RHSTerm
+ )
+ ->
+ parse_field_list(FieldNameTerm, MaybeFieldNames),
+ (
+ MaybeFieldNames = ok(FieldNames),
+ ArgTerms = [FieldValueTerm, TermInputTerm, TermOutputTerm],
+ transform_dcg_record_syntax_2(AccessType, FieldNames, ArgTerms,
+ Context, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ MaybeFieldNames = error(Msg, ErrorTerm),
+ invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !IO),
+ qual_info_set_found_syntax_error(yes, !QualInfo),
+ io__set_exit_status(1, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string("In DCG field ", !IO),
+ (
+ AccessType = set,
+ io__write_string("update", !IO)
+ ;
+ AccessType = get,
+ io__write_string("extraction", !IO)
+ ),
+ io__write_string(" goal:\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" error: ", !IO),
+ io__write_string(Msg, !IO),
+ io__write_string(" at term `", !IO),
+ term_io__write_term(!.VarSet, ErrorTerm, !IO),
+ io__write_string("'.\n", !IO)
+ )
+ ;
+ invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !IO),
+ qual_info_set_found_syntax_error(yes, !QualInfo),
+ io__set_exit_status(1, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: expected " ++
+ "`Field =^ field1 ^ ... ^ fieldN'\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" or `^ field1 ^ ... ^ fieldN := Field'.\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" in DCG field access goal.\n", !IO)
+ ).
+
+:- pred transform_dcg_record_syntax_2(field_access_type::in, field_list::in,
+ list(prog_term)::in, prog_context::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+transform_dcg_record_syntax_2(AccessType, FieldNames, ArgTerms, Context, Goal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ make_fresh_arg_vars(ArgTerms, ArgVars, !VarSet, !SInfo, !IO),
+ ( ArgVars = [FieldValueVar, TermInputVar, TermOutputVar] ->
+ (
+ AccessType = set,
+ expand_set_field_function_call(Context, explicit, [],
+ FieldNames, FieldValueVar, TermInputVar,
+ TermOutputVar, !VarSet, Functor,
+ InnermostFunctor - InnermostSubContext, Goal0,
+ !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ FieldArgNumber = 2,
+ FieldArgContext = functor(InnermostFunctor, explicit,
+ InnermostSubContext),
+ InputTermArgNumber = 1,
+ InputTermArgContext = functor(Functor, explicit, []),
+ ( Functor = cons(FuncName0, FuncArity0) ->
+ FuncName = FuncName0,
+ FuncArity = FuncArity0
+ ;
+ error("transform_dcg_record_syntax_2")
+ ),
+ % DCG arguments should always be distinct variables,
+ % so this context should never be used.
+ OutputTermArgNumber = 3,
+ OutputTermArgContext = call(
+ call(function - FuncName/FuncArity)),
+
+ ArgContexts = [
+ FieldArgNumber - FieldArgContext,
+ InputTermArgNumber - InputTermArgContext,
+ OutputTermArgNumber - OutputTermArgContext
+ ],
+ insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms,
+ ArgContexts, Context, Goal0, Goal, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO)
+ ;
+ AccessType = get,
+ expand_dcg_field_extraction_goal(Context, explicit,
+ [], FieldNames, FieldValueVar, TermInputVar,
+ TermOutputVar, !VarSet, Functor,
+ InnermostFunctor - _InnerSubContext, Goal0,
+ !ModuleInfo, !QualInfo, !SInfo, !IO),
+ InputTermArgNumber = 1,
+ InputTermArgContext = functor(Functor, explicit, []),
+
+ ( InnermostFunctor = cons(FuncName0, FuncArity0) ->
+ FuncName = FuncName0,
+ FuncArity = FuncArity0
+ ;
+ error("transform_dcg_record_syntax_2")
+ ),
+ FieldArgNumber = 2,
+ FieldArgContext = call(call(function - FuncName/FuncArity)),
+
+ % DCG arguments should always be distinct variables,
+ % so this context should never be used.
+ OutputTermArgNumber = 1,
+ OutputTermArgContext = functor(Functor, explicit, []),
+ ArgContexts = [
+ FieldArgNumber - FieldArgContext,
+ InputTermArgNumber - InputTermArgContext,
+ OutputTermArgNumber - OutputTermArgContext
+ ],
+ insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms,
+ ArgContexts, Context, Goal0, Goal, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO)
+ )
+ ;
+ error("make_hlds__do_transform_dcg_record_syntax")
+ ).
+
+parse_purity_annotation(Term0, Purity, Term) :-
+ (
+ Term0 = term__functor(term__atom(PurityName), [Term1], _),
+ purity_name(Purity0, PurityName)
+ ->
+ Purity = Purity0,
+ Term = Term1
+ ;
+ Purity = (pure),
+ Term = Term0
+ ).
+
+qualify_lambda_mode_list(Modes0, Modes, Context, !QualInfo, !IO) :-
+ % The modes in `.opt' files are already fully module qualified.
+ qual_info_get_import_status(!.QualInfo, ImportStatus),
+ ( ImportStatus \= opt_imported ->
+ qual_info_get_mq_info(!.QualInfo, MQInfo0),
+ module_qual__qualify_lambda_mode_list(Modes0, Modes, Context,
+ MQInfo0, MQInfo1, !IO),
+ qual_info_set_mq_info(MQInfo1, !QualInfo)
+ ;
+ Modes = Modes0
+ ).
+
+ % get_rev_conj(Goal, Subst, RevConj0, RevConj) :
+ %
+ % Goal is a tree of conjuncts. Flatten it into a list (applying Subst),
+ % reverse it, append RevConj0, and return the result in RevConj.
+ %
+:- pred get_rev_conj(goal::in, prog_substitution::in, list(hlds_goal)::in,
+ list(hlds_goal)::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+get_rev_conj(Goal, Subst, RevConj0, RevConj, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO) :-
+ ( Goal = (A,B) - _Context ->
+ get_rev_conj(A, Subst, RevConj0, RevConj1,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ get_rev_conj(B, Subst, RevConj1, RevConj,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ transform_goal(Goal, Subst, Goal1, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ goal_to_conj_list(Goal1, ConjList),
+ RevConj = list__reverse(ConjList) ++ RevConj0
+ ).
+
+ % get_rev_par_conj(Goal, Subst, RevParConj0, RevParConj) :
+ %
+ % Goal is a tree of conjuncts. Flatten it into a list (applying Subst),
+ % reverse it, append RevParConj0, and return the result in RevParConj.
+ %
+:- pred get_rev_par_conj(goal::in, prog_substitution::in, list(hlds_goal)::in,
+ list(hlds_goal)::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+get_rev_par_conj(Goal, Subst, RevParConj0, RevParConj, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ ( Goal = (A & B) - _Context ->
+ get_rev_par_conj(A, Subst, RevParConj0, RevParConj1,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ get_rev_par_conj(B, Subst, RevParConj1, RevParConj,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ transform_goal(Goal, Subst, Goal1, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ goal_to_par_conj_list(Goal1, ParConjList),
+ RevParConj = list__reverse(ParConjList) ++ RevParConj0
+ ).
+
+ % get_disj(Goal, Subst, Disj0, Disj):
+ %
+ % Goal is a tree of disjuncts. Flatten it into a list (applying Subst),
+ % append Disj0, and return the result in Disj.
+ %
+:- pred get_disj(goal::in, prog_substitution::in, hlds_goal_svar_infos::in,
+ hlds_goal_svar_infos::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, io::di, io::uo) is det.
+
+get_disj(Goal, Subst, Disj0, Disj, !VarSet, !ModuleInfo, !QualInfo, SInfo,
+ !IO) :-
+ ( Goal = (A;B) - _Context ->
+ get_disj(B, Subst, Disj0, Disj1, !VarSet, !ModuleInfo, !QualInfo,
+ SInfo, !IO),
+ get_disj(A, Subst, Disj1, Disj, !VarSet, !ModuleInfo, !QualInfo,
+ SInfo, !IO)
+ ;
+ transform_goal(Goal, Subst, Goal1, !VarSet, !ModuleInfo, !QualInfo,
+ SInfo, SInfo1, !IO),
+ Disj = [{Goal1, SInfo1} | Disj0]
+ ).
Index: compiler/add_field.m
cvs diff: could not get info for `compiler/add_field.m': Operation not permitted
===================================================================
RCS file: compiler/add_field.m
diff -N compiler/add_field.m
cvs diff: extra operand
cvs diff: Try `diff --help' for more information.
Index: compiler/add_mode.m
===================================================================
RCS file: compiler/add_mode.m
diff -N compiler/add_mode.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_mode.m 25 Jul 2005 08:20:30 -0000
@@ -0,0 +1,221 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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.
+%-----------------------------------------------------------------------------%
+%
+% This submodule of make_hlds handles the declarations of new insts and modes.
+
+:- module hlds__make_hlds__add_mode.
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module bool.
+:- import_module io.
+:- import_module list.
+
+:- pred module_add_inst_defn(inst_varset::in, sym_name::in, list(inst_var)::in,
+ inst_defn::in, condition::in, prog_context::in, item_status::in,
+ module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
+
+:- pred module_add_mode_defn(inst_varset::in, sym_name::in, list(inst_var)::in,
+ mode_defn::in, condition::in, prog_context::in, item_status::in,
+ module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__make_hlds_error.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_mode.
+
+:- import_module map.
+:- import_module require.
+:- import_module std_util.
+:- import_module string.
+
+module_add_inst_defn(VarSet, Name, Args, InstDefn, Cond, Context,
+ item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !IO) :-
+ %
+ % Add the definition of this inst to the HLDS inst table.
+ %
+ module_info_insts(!.ModuleInfo, InstTable0),
+ inst_table_get_user_insts(InstTable0, Insts0),
+ insts_add(VarSet, Name, Args, InstDefn, Cond, Context, Status,
+ Insts0, Insts, !IO),
+ inst_table_set_user_insts(Insts, InstTable0, InstTable),
+ module_info_set_insts(InstTable, !ModuleInfo),
+ %
+ % check if the inst is infinitely recursive (at the top level)
+ %
+ Arity = list__length(Args),
+ InstId = Name - Arity,
+ TestArgs = list__duplicate(Arity, not_reached),
+ check_for_cyclic_inst(Insts, InstId, InstId, TestArgs, [], Context,
+ InvalidMode, !IO).
+
+:- pred insts_add(inst_varset::in, sym_name::in,
+ list(inst_var)::in, inst_defn::in, condition::in, prog_context::in,
+ import_status::in, user_inst_table::in, user_inst_table::out,
+ io::di, io::uo) is det.
+
+insts_add(_, _, _, abstract_inst, _, _, _, !Insts, !IO) :-
+ % XXX handle abstract insts
+ error("sorry, abstract insts not implemented").
+insts_add(VarSet, Name, Args, eqv_inst(Body), _Cond, Context, Status, !Insts,
+ !IO) :-
+ list__length(Args, Arity),
+ (
+ I = hlds_inst_defn(VarSet, Args, eqv_inst(Body), Context, Status),
+ user_inst_table_insert(Name - Arity, I, !Insts)
+ ->
+ true
+ ;
+ % If abstract insts are implemented, this will need to change
+ % to update the hlds_inst_defn to the non-abstract inst.
+
+ % XXX we should record each error using
+ % module_info_incr_errors
+ user_inst_table_get_inst_defns(!.Insts, InstDefns),
+ map__lookup(InstDefns, Name - Arity, OrigI),
+ OrigI = hlds_inst_defn(_, _, _, OrigContext, _),
+ multiple_def_error(Status, Name, Arity, "inst", Context, OrigContext,
+ _, !IO)
+ ).
+
+ % Check if the inst is infinitely recursive (at the top level).
+ %
+:- pred check_for_cyclic_inst(user_inst_table::in, inst_id::in, inst_id::in,
+ list(inst)::in, list(inst_id)::in, prog_context::in, bool::out,
+ io::di, io::uo) is det.
+
+check_for_cyclic_inst(UserInstTable, OrigInstId, InstId0, Args0, Expansions0,
+ Context, InvalidMode, !IO) :-
+ ( list__member(InstId0, Expansions0) ->
+ report_circular_equiv_error("inst", OrigInstId, InstId0, Expansions0,
+ Context, !IO),
+ InvalidMode = yes
+ ;
+ user_inst_table_get_inst_defns(UserInstTable, InstDefns),
+ (
+ map__search(InstDefns, InstId0, InstDefn),
+ InstDefn = hlds_inst_defn(_, Params, Body, _, _),
+ Body = eqv_inst(EqvInst0),
+ inst_substitute_arg_list(EqvInst0, Params, Args0, EqvInst),
+ EqvInst = defined_inst(user_inst(Name, Args))
+ ->
+ Arity = list__length(Args),
+ InstId = Name - Arity,
+ Expansions = [InstId0 | Expansions0],
+ check_for_cyclic_inst(UserInstTable, OrigInstId, InstId, Args,
+ Expansions, Context, InvalidMode, !IO)
+ ;
+ InvalidMode = no
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+module_add_mode_defn(VarSet, Name, Params, ModeDefn, Cond, Context,
+ item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !IO) :-
+ module_info_modes(!.ModuleInfo, Modes0),
+ modes_add(VarSet, Name, Params, ModeDefn, Cond, Context, Status,
+ Modes0, Modes, InvalidMode, !IO),
+ module_info_set_modes(Modes, !ModuleInfo).
+
+:- pred modes_add(inst_varset::in, sym_name::in, list(inst_var)::in,
+ mode_defn::in, condition::in, prog_context::in, import_status::in,
+ mode_table::in, mode_table::out, bool::out, io::di, io::uo) is det.
+
+modes_add(VarSet, Name, Args, eqv_mode(Body), _Cond, Context, Status,
+ !Modes, InvalidMode, !IO) :-
+ list__length(Args, Arity),
+ ModeId = Name - Arity,
+ (
+ I = hlds_mode_defn(VarSet, Args, eqv_mode(Body), Context, Status),
+ mode_table_insert(ModeId, I, !Modes)
+ ->
+ true
+ ;
+ mode_table_get_mode_defns(!.Modes, ModeDefns),
+ map__lookup(ModeDefns, ModeId, OrigI),
+ OrigI = hlds_mode_defn(_, _, _, OrigContext, _),
+ % XXX we should record each error using
+ % module_info_incr_errors
+ multiple_def_error(Status, Name, Arity, "mode", Context, OrigContext,
+ _, !IO)
+ ),
+ check_for_cyclic_mode(!.Modes, ModeId, ModeId, [], Context, InvalidMode,
+ !IO).
+
+ % Check if the mode is infinitely recursive at the top level.
+ %
+:- pred check_for_cyclic_mode(mode_table::in, mode_id::in, mode_id::in,
+ list(mode_id)::in, prog_context::in, bool::out, io::di, io::uo) is det.
+
+check_for_cyclic_mode(ModeTable, OrigModeId, ModeId0, Expansions0, Context,
+ InvalidMode, !IO) :-
+ ( list__member(ModeId0, Expansions0) ->
+ report_circular_equiv_error("mode", OrigModeId, ModeId0,
+ Expansions0, Context, !IO),
+ InvalidMode = yes
+ ;
+ mode_table_get_mode_defns(ModeTable, ModeDefns),
+ (
+ map__search(ModeDefns, ModeId0, ModeDefn),
+ ModeDefn = hlds_mode_defn(_, _, Body, _, _),
+ Body = eqv_mode(EqvMode),
+ EqvMode = user_defined_mode(Name, Args)
+ ->
+ Arity = list__length(Args),
+ ModeId = Name - Arity,
+ Expansions = [ModeId0 | Expansions0],
+ check_for_cyclic_mode(ModeTable, OrigModeId, ModeId, Expansions,
+ Context, InvalidMode, !IO)
+ ;
+ InvalidMode = no
+ )
+ ).
+
+:- type id == pair(sym_name, arity).
+
+:- pred report_circular_equiv_error(string::in, id::in, id::in, list(id)::in,
+ prog_context::in, io::di, io::uo) is det.
+
+report_circular_equiv_error(Kind, OrigId, Id, Expansions, Context, !IO) :-
+ ( Id = OrigId ->
+ %
+ % Report an error message of the form
+ % Error: circular equivalence <kind> foo/0.
+ % or
+ % Error: circular equivalence <kind>s foo/0 and bar/1.
+ % or
+ % Error: circular equivalence <kind>s foo/0, bar/1,
+ % and baz/2.
+ % where <kind> is either "inst" or "mode".
+ %
+ Kinds = (if Expansions = [_] then Kind else Kind ++ "s"),
+ Pieces0 = list__map(
+ (func(SymName - Arity) =
+ error_util__describe_sym_name_and_arity(
+ SymName / Arity)),
+ Expansions),
+ Pieces1 = error_util__list_to_pieces(Pieces0),
+ Pieces = append_punctuation([words("Error: circular equivalence"),
+ fixed(Kinds) | Pieces1], '.'),
+ error_util__write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO)
+ ;
+ % We have an inst `OrigId' which is not itself circular,
+ % but which is defined in terms of `Id' which is circular.
+ % Don't bother reporting it now -- it have already been
+ % reported when we processed the definition of Id.
+ true
+ ).
Index: compiler/add_pragma.m
===================================================================
RCS file: compiler/add_pragma.m
diff -N compiler/add_pragma.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_pragma.m 25 Jul 2005 04:12:41 -0000
@@ -0,0 +1,2042 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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 hlds__make_hlds__add_pragma.
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+:- import_module parse_tree__mercury_to_mercury.
+
+:- import_module assoc_list.
+:- import_module io.
+:- import_module list.
+:- import_module std_util.
+:- import_module term.
+
+:- pred add_pragma(pragma_type::in, prog_context::in, item_status::in,
+ item_status::out, module_info::in, module_info::out, io::di, io::uo)
+ is det.
+
+:- pred add_pragma_export(sym_name::in, pred_or_func::in, list(mode)::in,
+ string::in, prog_context::in, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+:- pred add_pragma_reserve_tag(sym_name::in, arity::in, import_status::in,
+ prog_context::in, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+:- pred add_pragma_type_spec(pragma_type::in(type_spec), term__context::in,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+:- pred add_pragma_termination2_info(pred_or_func::in, sym_name::in,
+ list(mode)::in, maybe(pragma_constr_arg_size_info)::in,
+ maybe(pragma_constr_arg_size_info)::in,
+ maybe(pragma_termination_info)::in, prog_context::in, module_info::in,
+ module_info::out, io::di, io::uo) is det.
+
+:- pred add_pragma_termination_info(pred_or_func::in, sym_name::in,
+ list(mode)::in, maybe(pragma_arg_size_info)::in,
+ maybe(pragma_termination_info)::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+ % module_add_pragma_import:
+ %
+ % Handles `pragma import' declarations, by figuring out which predicate
+ % the `pragma import' declaration applies to, and adding a clause
+ % for that predicate containing an appropriate HLDS `pragma_c_code'
+ % instruction.
+ %
+ % NB. Any changes here might also require similar changes to the
+ % handling of `pragma export' declarations, in export.m.
+ %
+:- pred module_add_pragma_import(sym_name::in, pred_or_func::in,
+ list(mode)::in, pragma_foreign_proc_attributes::in, string::in,
+ import_status::in, prog_context::in,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+:- pred module_add_pragma_foreign_proc(pragma_foreign_proc_attributes::in,
+ sym_name::in, pred_or_func::in, list(pragma_var)::in, prog_varset::in,
+ pragma_foreign_code_impl::in, import_status::in, prog_context::in,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+:- pred module_add_pragma_tabled(eval_method::in, sym_name::in, int::in,
+ maybe(pred_or_func)::in, maybe(list(mode))::in, import_status::in,
+ prog_context::in, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+ % module_add_pragma_fact_table(PredName, Arity, FileName,
+ % Status, Context, Module0, Module, !Info):
+ %
+ % Add a `pragma fact_table' declaration to the HLDS. This predicate calls
+ % the fact table compiler (fact_table_compile_facts) to create a separate
+ % `.o' file for the fact_table and then creates separate pieces of
+ % `pragma c_code' to access the table in each mode of the fact table
+ % predicate.
+ %
+:- pred module_add_pragma_fact_table(sym_name::in, arity::in, string::in,
+ import_status::in, prog_context::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+:- pred lookup_current_backend(backend::out, io::di, io::uo) is det.
+
+ % Find the procedure with declared argmodes which match the ones we want.
+ % If there was no mode declaration, then use the inferred argmodes.
+ %
+:- pred get_procedure_matching_declmodes(assoc_list(proc_id, proc_info)::in,
+ list(mode)::in, module_info::in, proc_id::out) is semidet.
+
+:- implementation.
+
+:- import_module backend_libs.
+:- import_module backend_libs__foreign.
+:- import_module check_hlds__mode_util.
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_out.
+:- import_module hlds__make_hlds__add_aditi.
+:- import_module hlds__make_hlds__add_pred.
+:- import_module hlds__make_hlds__make_hlds_error.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module hlds__make_hlds__make_hlds_warn.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module hlds__make_tags.
+:- import_module hlds__quantification.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module ll_backend.
+:- import_module ll_backend__fact_table.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__modules.
+:- import_module parse_tree__prog_foreign.
+:- import_module parse_tree__prog_io.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_type.
+:- import_module parse_tree__prog_util.
+:- import_module recompilation.
+:- import_module transform_hlds__term_constr_main.
+:- import_module transform_hlds__term_constr_util.
+:- import_module transform_hlds__term_util.
+
+:- import_module bag.
+:- import_module bool.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+:- import_module multi_map.
+:- import_module require.
+:- import_module set.
+:- import_module std_util.
+:- import_module string.
+:- import_module svmap.
+:- import_module varset.
+
+add_pragma(Pragma, Context, !Status, !ModuleInfo, !IO) :-
+ %
+ % check for invalid pragmas in the `interface' section
+ %
+ !.Status = item_status(ImportStatus, _),
+ pragma_allowed_in_interface(Pragma, Allowed),
+ (
+ Allowed = no,
+ check_not_exported(ImportStatus, Context, "`pragma' declaration", !IO)
+ ;
+ Allowed = yes
+ ),
+ (
+ % Ignore `pragma source_file' declarations - they're dealt
+ % with elsewhere.
+ Pragma = source_file(_)
+ ;
+ Pragma = foreign_code(Lang, Body_Code),
+ module_add_foreign_body_code(Lang, Body_Code, Context, !ModuleInfo)
+ ;
+ Pragma = foreign_decl(Lang, IsLocal, C_Header),
+ module_add_foreign_decl(Lang, IsLocal, C_Header, Context, !ModuleInfo)
+ ;
+ Pragma = foreign_import_module(Lang, Import),
+ module_add_foreign_import_module(Lang, Import, Context, !ModuleInfo)
+ ;
+ % Handle pragma foreign procs later on (when we process clauses).
+ Pragma = foreign_proc(_, _, _, _, _, _)
+ ;
+ % Handle pragma tabled decls later on (when we process clauses).
+ Pragma = tabled(_, _, _, _, _)
+ ;
+ Pragma = inline(Name, Arity),
+ add_pred_marker("inline", Name, Arity, ImportStatus, Context,
+ inline, [no_inline], !ModuleInfo, !IO)
+ ;
+ Pragma = no_inline(Name, Arity),
+ add_pred_marker("no_inline", Name, Arity, ImportStatus, Context,
+ no_inline, [inline], !ModuleInfo, !IO)
+ ;
+ Pragma = obsolete(Name, Arity),
+ add_pred_marker("obsolete", Name, Arity, ImportStatus,
+ Context, obsolete, [], !ModuleInfo, !IO)
+ ;
+ % Handle pragma import decls later on (when we process
+ % clauses and pragma c_code).
+ Pragma = import(_, _, _, _, _)
+ ;
+ % Handle pragma export decls later on, after default
+ % function modes have been added.
+ Pragma = export(_, _, _, _)
+ ;
+ % Used for inter-module unused argument elimination.
+ % This can only appear in .opt files.
+ Pragma = unused_args(PredOrFunc, SymName, Arity, ModeNum,
+ UnusedArgs),
+ ( ImportStatus \= opt_imported ->
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: illegal use of pragma `unused_args'.\n",
+ !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ add_pragma_unused_args(PredOrFunc, SymName, Arity, ModeNum,
+ UnusedArgs, Context, !ModuleInfo, !IO)
+ )
+ ;
+ Pragma = exceptions(PredOrFunc, SymName, Arity, ModeNum, ThrowStatus),
+ ( ImportStatus \= opt_imported ->
+ prog_out.write_context(Context, !IO),
+ io.write_string("Error: illegal use of pragma `exceptions'.\n",
+ !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ add_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum,
+ ThrowStatus, Context, !ModuleInfo, !IO)
+ )
+ ;
+ % Handle pragma type_spec decls later on (when we process clauses).
+ Pragma = type_spec(_, _, _, _, _, _, _, _)
+ ;
+ % Handle pragma fact_table decls later on (when we process clauses
+ % -- since these decls take the place of clauses).
+ Pragma = fact_table(_, _, _)
+ ;
+ % Handle pragma reserve_tag decls later on (when we process clauses
+ % -- they need to be handled after the type definitions
+ % have been added).
+ Pragma = reserve_tag(_, _)
+ ;
+ Pragma = aditi(PredName, Arity),
+ maybe_enable_aditi_compilation(!.Status, Context, !ModuleInfo, !IO),
+ add_pred_marker("aditi", PredName, Arity, ImportStatus, Context,
+ aditi, [], !ModuleInfo, !IO),
+ add_stratified_pred("aditi", PredName, Arity, Context, !ModuleInfo, !IO)
+ ;
+ Pragma = base_relation(PredName, Arity),
+ maybe_enable_aditi_compilation(!.Status, Context, !ModuleInfo, !IO),
+ add_pred_marker("aditi", PredName, Arity, ImportStatus, Context, aditi,
+ [], !ModuleInfo, !IO),
+ add_pred_marker("base_relation", PredName, Arity, ImportStatus,
+ Context, base_relation, [], !ModuleInfo, !IO),
+ module_mark_as_external(PredName, Arity, Context, !ModuleInfo, !IO)
+ ;
+ Pragma = aditi_index(PredName, Arity, Index),
+ add_base_relation_index(PredName, Arity, Index, ImportStatus,
+ Context, !ModuleInfo, !IO)
+ ;
+ Pragma = naive(PredName, Arity),
+ add_pred_marker("naive", PredName, Arity, ImportStatus,
+ Context, naive, [psn], !ModuleInfo, !IO)
+ ;
+ Pragma = psn(PredName, Arity),
+ add_pred_marker("psn", PredName, Arity, ImportStatus,
+ Context, psn, [naive], !ModuleInfo, !IO)
+ ;
+ Pragma = aditi_memo(Name, Arity),
+ add_pred_marker("aditi_memo", Name, Arity, ImportStatus,
+ Context, aditi_memo, [aditi_no_memo], !ModuleInfo, !IO)
+ ;
+ Pragma = aditi_no_memo(PredName, Arity),
+ add_pred_marker("aditi_no_memo", PredName, Arity, ImportStatus,
+ Context, aditi_no_memo, [aditi_memo], !ModuleInfo, !IO)
+ ;
+ Pragma = supp_magic(PredName, Arity),
+ add_pred_marker("supp_magic", PredName, Arity, ImportStatus,
+ Context, supp_magic, [context], !ModuleInfo, !IO)
+ ;
+ Pragma = context(PredName, Arity),
+ add_pred_marker("context", PredName, Arity, ImportStatus,
+ Context, context, [supp_magic], !ModuleInfo, !IO)
+ ;
+ Pragma = owner(PredName, Arity, Owner),
+ set_pred_owner(PredName, Arity, Owner, ImportStatus,
+ Context, !ModuleInfo, !IO)
+ ;
+ Pragma = promise_pure(Name, Arity),
+ add_pred_marker("promise_pure", Name, Arity, ImportStatus,
+ Context, promised_pure, [], !ModuleInfo, !IO)
+ ;
+ Pragma = promise_semipure(Name, Arity),
+ add_pred_marker("promise_semipure", Name, Arity, ImportStatus,
+ Context, promised_semipure, [], !ModuleInfo, !IO)
+ ;
+ % Handle pragma termination_info decls later on, in pass 3 --
+ % we need to add function default modes before handling
+ % these pragmas
+ Pragma = termination_info(_, _, _, _, _)
+ ;
+ % As for termination_info pragmas
+ Pragma = termination2_info(_, _, _, _, _, _)
+ ;
+ Pragma = terminates(Name, Arity),
+ add_pred_marker("terminates", Name, Arity, ImportStatus, Context,
+ terminates, [check_termination, does_not_terminate], !ModuleInfo,
+ !IO)
+ ;
+ Pragma = does_not_terminate(Name, Arity),
+ add_pred_marker("does_not_terminate", Name, Arity, ImportStatus,
+ Context, does_not_terminate, [check_termination, terminates],
+ !ModuleInfo, !IO)
+ ;
+ Pragma = check_termination(Name, Arity),
+ add_pred_marker("check_termination", Name, Arity, ImportStatus,
+ Context, check_termination, [terminates, does_not_terminate],
+ !ModuleInfo, !IO)
+ ;
+ Pragma = mode_check_clauses(Name, Arity),
+ add_pred_marker("mode_check_clauses", Name, Arity, ImportStatus,
+ Context, mode_check_clauses, [], !ModuleInfo, !IO),
+
+ % Allowing the predicate to be inlined could lead to code generator
+ % aborts. This is because the caller that inlines this predicate may
+ % then push other code into the disjunction or switch's branches,
+ % which would invalidate the instmap_deltas that the mode_check_clauses
+ % feature prevents the recomputation of.
+ add_pred_marker("mode_check_clauses", Name, Arity, ImportStatus,
+ Context, no_inline, [inline], !ModuleInfo, !IO)
+ ).
+
+add_pragma_export(Name, PredOrFunc, Modes, C_Function, Context, !ModuleInfo,
+ !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, PredTable),
+ list__length(Modes, Arity),
+ (
+ predicate_table_search_pf_sym_arity(PredTable,
+ may_be_partially_qualified, PredOrFunc, Name, Arity, [PredId])
+ ->
+ predicate_table_get_preds(PredTable, Preds),
+ map__lookup(Preds, PredId, PredInfo),
+ pred_info_procedures(PredInfo, Procs),
+ map__to_assoc_list(Procs, ExistingProcs),
+ (
+ get_procedure_matching_declmodes(ExistingProcs, Modes,
+ !.ModuleInfo, ProcId)
+ ->
+ map__lookup(Procs, ProcId, ProcInfo),
+ proc_info_declared_determinism(ProcInfo, MaybeDet),
+ % We cannot catch those multi or nondet procedures that
+ % don't have a determinism declaration until after
+ % determinism analysis.
+ (
+ MaybeDet = yes(Det),
+ ( Det = nondet ; Det = multidet )
+ ->
+ Pieces = [words("Error: "),
+ fixed("`:- pragma export' declaration"),
+ words("for a procedure that has"),
+ words("a declared determinism of"),
+ fixed(hlds_out.determinism_to_string(Det) ++ ".")
+ ],
+ error_util.write_error_pieces(Context, 0, Pieces, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ module_info_get_pragma_exported_procs(!.ModuleInfo,
+ PragmaExportedProcs0),
+ NewExportedProc = pragma_exported_proc(PredId, ProcId,
+ C_Function, Context),
+ PragmaExportedProcs = [NewExportedProc | PragmaExportedProcs0],
+ module_info_set_pragma_exported_procs(PragmaExportedProcs,
+ !ModuleInfo)
+ )
+ ;
+ undefined_mode_error(Name, Arity, Context,
+ "`:- pragma export' declaration", !IO),
+ module_info_incr_errors(!ModuleInfo)
+ )
+ ;
+ undefined_pred_or_func_error(Name, Arity, Context,
+ "`:- pragma export' declaration", !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
+ !IO) :-
+ TypeCtor = TypeName - TypeArity,
+ module_info_types(!.ModuleInfo, Types0),
+ TypeStr = error_util__describe_sym_name_and_arity(
+ TypeName / TypeArity),
+ ErrorPieces1 = [
+ words("In"),
+ fixed("`pragma reserve_tag'"),
+ words("declaration for"),
+ fixed(TypeStr ++ ":")
+ ],
+ ( map__search(Types0, TypeCtor, TypeDefn0) ->
+ hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
+ hlds_data__get_type_defn_status(TypeDefn0, TypeStatus),
+ (
+ not (
+ TypeStatus = PragmaStatus
+ ;
+ TypeStatus = abstract_exported,
+ ( PragmaStatus = local
+ ; PragmaStatus = exported_to_submodules
+ )
+ )
+ ->
+ error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
+ ErrorPieces2 = [
+ words("error: `reserve_tag' declaration must"),
+ words("have the same visibility as the"),
+ words("type definition.")
+ ],
+ error_util__write_error_pieces_not_first_line(Context, 0,
+ ErrorPieces2, !IO),
+ io__set_exit_status(1, !IO),
+ module_info_incr_errors(!ModuleInfo)
+
+ ;
+ TypeBody0 = du_type(Body, _CtorTags0, _IsEnum0,
+ MaybeUserEqComp, ReservedTag0, IsForeign)
+ ->
+ (
+ ReservedTag0 = yes,
+ % make doubly sure that we don't get any
+ % spurious warnings with intermodule
+ % optimization...
+ TypeStatus \= opt_imported
+ ->
+ error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
+ ErrorPieces2 = [
+ words("warning: multiple"),
+ fixed("`pragma reserved_tag'"),
+ words("declarations for the same type.")
+ ],
+ error_util__write_error_pieces_not_first_line(Context, 0,
+ ErrorPieces2, !IO)
+ ;
+ true
+ ),
+ %
+ % We passed all the semantic checks.
+ % Mark the type has having a reserved tag,
+ % and recompute the constructor tags.
+ %
+ ReservedTag = yes,
+ module_info_globals(!.ModuleInfo, Globals),
+ assign_constructor_tags(Body, TypeCtor, ReservedTag, Globals,
+ CtorTags, IsEnum),
+ TypeBody = du_type(Body, CtorTags, IsEnum, MaybeUserEqComp,
+ ReservedTag, IsForeign),
+ hlds_data__set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
+ map__set(Types0, TypeCtor, TypeDefn, Types),
+ module_info_set_types(Types, !ModuleInfo)
+ ;
+ error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
+ ErrorPieces2 = [
+ words("error:"),
+ fixed(TypeStr),
+ words("is not a discriminated union type.")
+ ],
+ error_util__write_error_pieces_not_first_line(Context, 0,
+ ErrorPieces2, !IO),
+ io__set_exit_status(1, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ )
+ ;
+ error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
+ ErrorPieces2 = [
+ words("error: undefined type"),
+ fixed(TypeStr ++ ".")
+ ],
+ error_util__write_error_pieces_not_first_line(Context, 0, ErrorPieces2,
+ !IO),
+ io__set_exit_status(1, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred add_pragma_unused_args(pred_or_func::in, sym_name::in, arity::in,
+ mode_num::in, list(int)::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+add_pragma_unused_args(PredOrFunc, SymName, Arity, ModeNum, UnusedArgs,
+ Context, !ModuleInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, Preds),
+ (
+ predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
+ PredOrFunc, SymName, Arity, [PredId])
+ ->
+ module_info_unused_arg_info(!.ModuleInfo, UnusedArgInfo0),
+ % convert the mode number to a proc_id
+ proc_id_to_int(ProcId, ModeNum),
+ map__set(UnusedArgInfo0, proc(PredId, ProcId), UnusedArgs,
+ UnusedArgInfo),
+ module_info_set_unused_arg_info(UnusedArgInfo, !ModuleInfo)
+ ;
+ prog_out__write_context(Context, !IO),
+ io__write_string("Internal compiler error: " ++
+ "unknown predicate in `pragma unused_args'.\n", !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred add_pragma_exceptions(pred_or_func::in, sym_name::in, arity::in,
+ mode_num::in, exception_status::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+add_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum, ThrowStatus,
+ _Context, !ModuleInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, Preds),
+ (
+ predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
+ PredOrFunc, SymName, Arity, [PredId])
+ ->
+ module_info_exception_info(!.ModuleInfo, ExceptionsInfo0),
+ % convert the mode number to a proc_id
+ proc_id_to_int(ProcId, ModeNum),
+ map__set(ExceptionsInfo0, proc(PredId, ProcId), ThrowStatus,
+ ExceptionsInfo),
+ module_info_set_exception_info(ExceptionsInfo, !ModuleInfo)
+ ;
+ % XXX We'll just ignore this for the time being -
+ % it causes errors with transitive-intermodule optimization.
+ %prog_out__write_context(Context, !IO),
+ %io__write_string("Internal compiler error: " ++
+ % "unknown predicate in `pragma exceptions'.\n", !IO),
+ %module_info_incr_errors(!ModuleInfo)
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
+
+add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Pragma = type_spec(SymName, _, Arity, MaybePredOrFunc, _, _, _, _),
+ module_info_get_predicate_table(!.ModuleInfo, Preds),
+ (
+ (
+ MaybePredOrFunc = yes(PredOrFunc),
+ adjust_func_arity(PredOrFunc, Arity, PredArity),
+ predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
+ PredOrFunc, SymName, PredArity, PredIds)
+ ;
+ MaybePredOrFunc = no,
+ predicate_table_search_sym_arity(Preds, is_fully_qualified,
+ SymName, Arity, PredIds)
+ ),
+ PredIds \= []
+ ->
+ list__foldl3(add_pragma_type_spec_2(Pragma, Context), PredIds,
+ !ModuleInfo, !QualInfo, !IO)
+ ;
+ undefined_pred_or_func_error(SymName, Arity, Context,
+ "`:- pragma type_spec' declaration", !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ).
+
+:- pred add_pragma_type_spec_2(pragma_type::in(type_spec), prog_context::in,
+ pred_id::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+add_pragma_type_spec_2(Pragma0, Context, PredId, !ModuleInfo, !QualInfo,
+ !IO) :-
+ Pragma0 = type_spec(SymName, SpecName, Arity, _, MaybeModes, Subst,
+ TVarSet0, ExpandedItems),
+ module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
+ handle_pragma_type_spec_subst(Context, Subst, PredInfo0,
+ TVarSet0, TVarSet, Types, ExistQVars, ClassContext, SubstOk,
+ !ModuleInfo, !IO),
+ (
+ SubstOk = yes(RenamedSubst),
+ pred_info_procedures(PredInfo0, Procs0),
+ handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes,
+ ProcIds, Procs0, Procs, ModesOk, !ModuleInfo, !IO),
+ globals__io_lookup_bool_option(user_guided_type_specialization,
+ DoTypeSpec, !IO),
+ globals__io_lookup_bool_option(smart_recompilation, Smart, !IO),
+ (
+ ModesOk = yes,
+ % Even if we aren't doing type specialization, we need
+ % to create the interface procedures for local
+ % predicates to check the type-class correctness of
+ % the requested specializations.
+ %
+ % If we're doing smart recompilation we need to record
+ % the pragmas even if we aren't doing type
+ % specialization to avoid problems with differing
+ % output for the recompilation tests in debugging
+ % grades.
+ %
+ ( DoTypeSpec = yes
+ ; \+ pred_info_is_imported(PredInfo0)
+ ; Smart = yes
+ )
+ ->
+ %
+ % Build a clause to call the old predicate with the
+ % specified types to force the specialization.
+ % For imported predicates this forces the creation
+ % of the proper interface.
+ %
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
+ adjust_func_arity(PredOrFunc, Arity, PredArity),
+ varset__init(ArgVarSet0),
+ make_n_fresh_vars("HeadVar__", PredArity, Args,
+ ArgVarSet0, ArgVarSet),
+ % XXX We could use explicit type qualifications here
+ % for the argument types, but explicit type
+ % qualification doesn't work correctly with type
+ % inference due to a bug somewhere in typecheck.m
+ % -- the explicitly declared types are not kept in
+ % sync with the predicate's tvarset after the first
+ % pass of type checking.
+ % map__from_corresponding_lists(Args, Types, VarTypes0)
+ map__init(VarTypes0),
+ goal_info_init(GoalInfo0),
+ set__list_to_set(Args, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1),
+ goal_info_set_context(GoalInfo1, Context, GoalInfo),
+
+ %
+ % We don't record the called predicate as used -- it
+ % is only used if there is some other call. This call
+ % is only used to make higher_order.m generate
+ % the interface for the type specialized procedure, and
+ % will be removed by higher_order.m after that is done.
+ %
+ do_construct_pred_or_func_call(PredId, PredOrFunc,
+ SymName, Args, GoalInfo, Goal),
+ Clause = clause(ProcIds, Goal, mercury, Context),
+ map__init(TVarNameMap),
+ rtti_varmaps_init(RttiVarMaps),
+ HasForeignClauses = no,
+ set_clause_list([Clause], ClausesRep),
+ Clauses = clauses_info(ArgVarSet, VarTypes0, TVarNameMap,
+ VarTypes0, Args, ClausesRep, RttiVarMaps, HasForeignClauses),
+ pred_info_get_markers(PredInfo0, Markers0),
+ add_marker(calls_are_fully_qualified, Markers0, Markers),
+ map__init(Proofs),
+ map__init(ConstraintMap),
+
+ ( pred_info_is_imported(PredInfo0) ->
+ Status = opt_imported
+ ;
+ pred_info_import_status(PredInfo0, Status)
+ ),
+
+ ModuleName = pred_info_module(PredInfo0),
+ pred_info_get_aditi_owner(PredInfo0, Owner),
+ pred_info_get_origin(PredInfo0, OrigOrigin),
+ SubstDesc = list__map(subst_desc, Subst),
+ Origin = transformed(type_specialization(SubstDesc),
+ OrigOrigin, PredId),
+ pred_info_init(ModuleName, SpecName, PredArity, PredOrFunc,
+ Context, Origin, Status, none, Markers, Types, TVarSet,
+ ExistQVars, ClassContext, Proofs, ConstraintMap, Owner,
+ Clauses, NewPredInfo0),
+ pred_info_set_procedures(Procs, NewPredInfo0, NewPredInfo),
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
+ predicate_table_insert(NewPredInfo, NewPredId,
+ PredTable0, PredTable),
+ module_info_set_predicate_table(PredTable,
+ !ModuleInfo),
+
+ %
+ % Record the type specialisation in the module_info.
+ %
+ module_info_type_spec_info(!.ModuleInfo, TypeSpecInfo0),
+ TypeSpecInfo0 = type_spec_info(ProcsToSpec0,
+ ForceVersions0, SpecMap0, PragmaMap0),
+ list__map((pred(ProcId::in, PredProcId::out) is det :-
+ PredProcId = proc(PredId, ProcId)
+ ), ProcIds, PredProcIds),
+ set__insert_list(ProcsToSpec0, PredProcIds,
+ ProcsToSpec),
+ set__insert(ForceVersions0, NewPredId, ForceVersions),
+
+ ( Status = opt_imported ->
+ % For imported predicates dead_proc_elim.m
+ % needs to know that if the original predicate
+ % is used, the predicate to force the
+ % production of the specialised interface is
+ % also used.
+ multi_map__set(SpecMap0, PredId, NewPredId, SpecMap)
+ ;
+ SpecMap = SpecMap0
+ ),
+ Pragma = type_spec(SymName, SpecName, Arity, yes(PredOrFunc),
+ MaybeModes, map__to_assoc_list(RenamedSubst), TVarSet,
+ ExpandedItems),
+ multi_map__set(PragmaMap0, PredId, Pragma, PragmaMap),
+ TypeSpecInfo = type_spec_info(ProcsToSpec, ForceVersions, SpecMap,
+ PragmaMap),
+ module_info_set_type_spec_info(TypeSpecInfo,
+ !ModuleInfo),
+
+ status_is_imported(Status, IsImported),
+ (
+ IsImported = yes,
+ ItemType = pred_or_func_to_item_type(PredOrFunc),
+ apply_to_recompilation_info(
+ recompilation__record_expanded_items(
+ item_id(ItemType, SymName - Arity), ExpandedItems),
+ !QualInfo)
+ ;
+ IsImported = no
+ )
+ ;
+ true
+ )
+ ;
+ SubstOk = no
+ ).
+
+:- func subst_desc(pair(tvar, type)) = pair(int, type).
+
+subst_desc(TVar - Type) = var_to_int(TVar) - Type.
+
+ % Check that the type substitution for a `:- pragma type_spec'
+ % declaration is valid.
+ % A type substitution is invalid if:
+ % - it substitutes unknown type variables
+ % - it substitutes existentially quantified type variables
+ % Type substitutions are also invalid if the replacement types are
+ % not ground, however this is a (hopefully temporary) limitation
+ % of the current implementation, so it only results in a warning.
+:- pred handle_pragma_type_spec_subst(prog_context::in,
+ assoc_list(tvar, type)::in, pred_info::in, tvarset::in, tvarset::out,
+ list(type)::out, existq_tvars::out, prog_constraints::out,
+ maybe(tsubst)::out, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+handle_pragma_type_spec_subst(Context, Subst, PredInfo0, TVarSet0, TVarSet,
+ Types, ExistQVars, ClassContext, SubstOk, !ModuleInfo, !IO) :-
+ assoc_list__keys(Subst, VarsToSub),
+ (
+ Subst = []
+ ->
+ error("handle_pragma_type_spec_subst: empty substitution")
+ ;
+ find_duplicate_list_elements(VarsToSub, MultiSubstVars0),
+ MultiSubstVars0 \= []
+ ->
+ list__sort_and_remove_dups(MultiSubstVars0, MultiSubstVars),
+ report_multiple_subst_vars(PredInfo0, Context, TVarSet0,
+ MultiSubstVars, !IO),
+ module_info_incr_errors(!ModuleInfo),
+ io__set_exit_status(1, !IO),
+ ExistQVars = [],
+ Types = [],
+ ClassContext = constraints([], []),
+ varset__init(TVarSet),
+ SubstOk = no
+ ;
+ pred_info_typevarset(PredInfo0, CalledTVarSet),
+ varset__create_name_var_map(CalledTVarSet, NameVarIndex0),
+ list__filter((pred(Var::in) is semidet :-
+ varset__lookup_name(TVarSet0, Var, VarName),
+ \+ map__contains(NameVarIndex0, VarName)
+ ), VarsToSub, UnknownVarsToSub),
+ (
+ UnknownVarsToSub = [],
+ % Check that the substitution is not recursive.
+ set__list_to_set(VarsToSub, VarsToSubSet),
+
+ assoc_list__values(Subst, SubstTypes0),
+ term__vars_list(SubstTypes0, TVarsInSubstTypes0),
+ set__list_to_set(TVarsInSubstTypes0,
+ TVarsInSubstTypes),
+
+ set__intersect(TVarsInSubstTypes, VarsToSubSet, RecSubstTVars0),
+ set__to_sorted_list(RecSubstTVars0, RecSubstTVars),
+
+ ( RecSubstTVars = [] ->
+ map__init(TVarRenaming0),
+ list__append(VarsToSub, TVarsInSubstTypes0, VarsToReplace),
+
+ get_new_tvars(VarsToReplace, TVarSet0, CalledTVarSet, TVarSet,
+ NameVarIndex0, _, TVarRenaming0, TVarRenaming),
+
+ % Check that none of the existentially
+ % quantified variables were substituted.
+ map__apply_to_list(VarsToSub, TVarRenaming, RenamedVarsToSub),
+ pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
+ list__filter((pred(RenamedVar::in) is semidet :-
+ list__member(RenamedVar, ExistQVars)
+ ), RenamedVarsToSub, SubExistQVars),
+ (
+ SubExistQVars = [],
+ map__init(TypeSubst0),
+ term__apply_variable_renaming_to_list(SubstTypes0,
+ TVarRenaming, SubstTypes),
+ assoc_list__from_corresponding_lists(RenamedVarsToSub,
+ SubstTypes, SubAL),
+ list__foldl(map_set_from_pair, SubAL,
+ TypeSubst0, TypeSubst),
+
+ % Apply the substitution.
+ pred_info_arg_types(PredInfo0, Types0),
+ pred_info_get_class_context(PredInfo0, ClassContext0),
+ term__apply_rec_substitution_to_list(Types0, TypeSubst,
+ Types),
+ apply_rec_subst_to_prog_constraints(TypeSubst,
+ ClassContext0, ClassContext),
+ SubstOk = yes(TypeSubst)
+ ;
+ SubExistQVars = [_ | _],
+ report_subst_existq_tvars(PredInfo0, Context,
+ SubExistQVars, !IO),
+ io__set_exit_status(1, !IO),
+ module_info_incr_errors(!ModuleInfo),
+ Types = [],
+ ClassContext = constraints([], []),
+ SubstOk = no
+ )
+ ;
+ report_recursive_subst(PredInfo0, Context, TVarSet0,
+ RecSubstTVars, !IO),
+ io__set_exit_status(1, !IO),
+ module_info_incr_errors(!ModuleInfo),
+ ExistQVars = [],
+ Types = [],
+ ClassContext = constraints([], []),
+ varset__init(TVarSet),
+ SubstOk = no
+ )
+ ;
+ UnknownVarsToSub = [_ | _],
+ report_unknown_vars_to_subst(PredInfo0, Context, TVarSet0,
+ UnknownVarsToSub, !IO),
+ module_info_incr_errors(!ModuleInfo),
+ io__set_exit_status(1, !IO),
+ ExistQVars = [],
+ Types = [],
+ ClassContext = constraints([], []),
+ varset__init(TVarSet),
+ SubstOk = no
+ )
+ ).
+
+:- pred map_set_from_pair(pair(K, V)::in, map(K, V)::in, map(K, V)::out)
+ is det.
+
+map_set_from_pair(K - V, !Map) :-
+ svmap__set(K, V, !Map).
+
+:- pred find_duplicate_list_elements(list(T)::in, list(T)::out) is det.
+
+find_duplicate_list_elements([], []).
+find_duplicate_list_elements([H | T], Vars) :-
+ find_duplicate_list_elements(T, Vars0),
+ ( list__member(H, T) ->
+ Vars = [H | Vars0]
+ ;
+ Vars = Vars0
+ ).
+
+:- pred report_subst_existq_tvars(pred_info::in, prog_context::in,
+ list(tvar)::in, io::di, io::uo) is det.
+
+report_subst_existq_tvars(PredInfo0, Context, SubExistQVars, !IO) :-
+ report_pragma_type_spec(PredInfo0, Context, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" error: the substitution includes the existentially\n",
+ !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" quantified type ", !IO),
+ pred_info_typevarset(PredInfo0, TVarSet),
+ report_variables(SubExistQVars, TVarSet, !IO),
+ io__write_string(".\n", !IO).
+
+:- pred report_recursive_subst(pred_info::in, prog_context::in, tvarset::in,
+ list(tvar)::in, io::di, io::uo) is det.
+
+report_recursive_subst(PredInfo0, Context, TVarSet, RecursiveVars, !IO) :-
+ report_pragma_type_spec(PredInfo0, Context, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" error: ", !IO),
+ report_variables(RecursiveVars, TVarSet, !IO),
+ ( RecursiveVars = [_] ->
+ io__write_string(" occurs\n", !IO)
+ ;
+ io__write_string(" occur\n", !IO)
+ ),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" on both sides of the substitution.\n", !IO).
+
+:- pred report_multiple_subst_vars(pred_info::in, prog_context::in,
+ tvarset::in, list(tvar)::in, io::di, io::uo) is det.
+
+report_multiple_subst_vars(PredInfo0, Context, TVarSet, MultiSubstVars, !IO) :-
+ report_pragma_type_spec(PredInfo0, Context, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" error: ", !IO),
+ report_variables(MultiSubstVars, TVarSet, !IO),
+ ( MultiSubstVars = [_] ->
+ io__write_string(" has ", !IO)
+ ;
+ io__write_string(" have ", !IO)
+ ),
+ io__write_string("multiple replacement types.\n", !IO).
+
+:- pred report_unknown_vars_to_subst(pred_info::in, prog_context::in,
+ tvarset::in, list(tvar)::in, io::di, io::uo) is det.
+
+report_unknown_vars_to_subst(PredInfo0, Context, TVarSet, UnknownVars, !IO) :-
+ report_pragma_type_spec(PredInfo0, Context, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" error: ", !IO),
+ report_variables(UnknownVars, TVarSet, !IO),
+ ( UnknownVars = [_] ->
+ io__write_string(" does not ", !IO)
+ ;
+ io__write_string(" do not ", !IO)
+ ),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
+ (
+ PredOrFunc = predicate,
+ Decl = "`:- pred'"
+ ;
+ PredOrFunc = function,
+ Decl = "`:- func'"
+ ),
+ io__write_string("occur in the ", !IO),
+ io__write_string(Decl, !IO),
+ io__write_string(" declaration.\n", !IO).
+
+:- pred report_pragma_type_spec(pred_info::in, term__context::in,
+ io::di, io::uo) is det.
+
+report_pragma_type_spec(PredInfo0, Context, !IO) :-
+ Module = pred_info_module(PredInfo0),
+ Name = pred_info_name(PredInfo0),
+ Arity = pred_info_orig_arity(PredInfo0),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
+ prog_out__write_context(Context, !IO),
+ io__write_string("In `:- pragma type_spec' declaration for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc,
+ qualified(Module, Name)/Arity, !IO),
+ io__write_string(":\n", !IO).
+
+:- pred report_variables(list(tvar)::in, tvarset::in, io::di, io::uo) is det.
+
+report_variables(SubExistQVars, VarSet, !IO) :-
+ ( SubExistQVars = [_] ->
+ io__write_string("variable `", !IO)
+ ;
+ io__write_string("variables `", !IO)
+ ),
+ mercury_output_vars(SubExistQVars, VarSet, no, !IO),
+ io__write_string("'", !IO).
+
+ % Check that the mode list for a `:- pragma type_spec' declaration
+ % specifies a known procedure.
+:- pred handle_pragma_type_spec_modes(sym_name::in, arity::in,
+ prog_context::in, maybe(list(mode))::in, list(proc_id)::out,
+ proc_table::in, proc_table::out, bool::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes, ProcIds,
+ !Procs, ModesOk, !ModuleInfo, !IO) :-
+ (
+ MaybeModes = yes(Modes),
+ map__to_assoc_list(!.Procs, ExistingProcs),
+ (
+ get_procedure_matching_argmodes(ExistingProcs, Modes,
+ !.ModuleInfo, ProcId)
+ ->
+ map__lookup(!.Procs, ProcId, ProcInfo),
+ map__det_insert(map__init, ProcId, ProcInfo, !:Procs),
+ ProcIds = [ProcId],
+ ModesOk = yes
+ ;
+ ProcIds = [],
+ module_info_incr_errors(!ModuleInfo),
+ undefined_mode_error(SymName, Arity, Context,
+ "`:- pragma type_spec' declaration", !IO),
+ ModesOk = no
+ )
+ ;
+ MaybeModes = no,
+ map__keys(!.Procs, ProcIds),
+ ModesOk = yes
+ ).
+
+%-----------------------------------------------------------------------------%
+
+add_pragma_termination2_info(PredOrFunc, SymName, ModeList,
+ MaybePragmaSuccessArgSizeInfo, MaybePragmaFailureArgSizeInfo,
+ MaybePragmaTerminationInfo, Context, !ModuleInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, Preds),
+ list.length(ModeList, Arity),
+ (
+ predicate_table_search_pf_sym_arity(Preds,
+ is_fully_qualified, PredOrFunc, SymName, Arity, PredIds),
+ PredIds = [_ | _]
+ ->
+ ( PredIds = [PredId] ->
+ module_info_preds(!.ModuleInfo, PredTable0),
+ map.lookup(PredTable0, PredId, PredInfo0),
+ pred_info_procedures(PredInfo0, ProcTable0),
+ map.to_assoc_list(ProcTable0, ProcList),
+ (
+ get_procedure_matching_declmodes(ProcList,
+ ModeList, !.ModuleInfo, ProcId)
+ ->
+ map.lookup(ProcTable0, ProcId, ProcInfo0),
+ add_context_to_constr_termination_info(
+ MaybePragmaTerminationInfo, Context,
+ MaybeTerminationInfo),
+
+ some [!TermInfo] (
+ proc_info_get_termination2_info(ProcInfo0, !:TermInfo),
+
+ !:TermInfo = !.TermInfo ^ import_success :=
+ MaybePragmaSuccessArgSizeInfo,
+ !:TermInfo = !.TermInfo ^ import_failure :=
+ MaybePragmaFailureArgSizeInfo,
+ !:TermInfo = !.TermInfo ^ term_status :=
+ MaybeTerminationInfo,
+
+ proc_info_set_termination2_info(!.TermInfo,
+ ProcInfo0, ProcInfo)
+ ),
+ map__det_update(ProcTable0, ProcId, ProcInfo,
+ ProcTable),
+ pred_info_set_procedures(ProcTable, PredInfo0,
+ PredInfo),
+ map__det_update(PredTable0, PredId, PredInfo,
+ PredTable),
+ module_info_set_preds(PredTable, !ModuleInfo)
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io.write_string(
+ "Error: `:- pragma termination2_info' " ++
+ "declaration for undeclared mode of ", !IO),
+ hlds_out.write_simple_call_id(PredOrFunc,
+ SymName/Arity, !IO),
+ io.write_string(".\n", !IO)
+ )
+ ;
+ prog_out.write_context(Context, !IO),
+ io.write_string("Error: ambiguous predicate name ", !IO),
+ hlds_out.write_simple_call_id(PredOrFunc, SymName/Arity, !IO),
+ io.nl(!IO),
+ prog_out.write_context(Context, !IO),
+ io.write_string(" in `pragma termination2_info'.\n", !IO),
+ module_info_incr_errors(!ModuleInfo)
+ )
+ ;
+ % XXX This happens in `.trans_opt' files sometimes --
+ % so just ignore it
+ true
+ % undefined_pred_or_func_error(
+ % SymName, Arity, Context,
+ % "`:- pragma termination2_info' declaration", !IO),
+ % module_info_incr_errors(!ModuleInfo)
+ ).
+
+%------------------------------------------------------------------------------%
+
+add_pragma_termination_info(PredOrFunc, SymName, ModeList,
+ MaybePragmaArgSizeInfo, MaybePragmaTerminationInfo,
+ Context, !ModuleInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, Preds),
+ list__length(ModeList, Arity),
+ (
+ predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
+ PredOrFunc, SymName, Arity, PredIds),
+ PredIds = [_ | _]
+ ->
+ ( PredIds = [PredId] ->
+ module_info_preds(!.ModuleInfo, PredTable0),
+ map__lookup(PredTable0, PredId, PredInfo0),
+ pred_info_procedures(PredInfo0, ProcTable0),
+ map__to_assoc_list(ProcTable0, ProcList),
+ (
+ get_procedure_matching_declmodes(ProcList, ModeList,
+ !.ModuleInfo, ProcId)
+ ->
+ add_context_to_arg_size_info(MaybePragmaArgSizeInfo,
+ Context, MaybeArgSizeInfo),
+ add_context_to_termination_info(MaybePragmaTerminationInfo,
+ Context, MaybeTerminationInfo),
+ map__lookup(ProcTable0, ProcId, ProcInfo0),
+ proc_info_set_maybe_arg_size_info(MaybeArgSizeInfo,
+ ProcInfo0, ProcInfo1),
+ proc_info_set_maybe_termination_info(MaybeTerminationInfo,
+ ProcInfo1, ProcInfo),
+ map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
+ pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
+ map__det_update(PredTable0, PredId, PredInfo, PredTable),
+ module_info_set_preds(PredTable, !ModuleInfo)
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma termination_info' ", !IO),
+ io__write_string("declaration for undeclared mode of ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, SymName/Arity, !IO),
+ io__write_string(".\n", !IO)
+ )
+ ;
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: ambiguous predicate name ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, SymName/Arity, !IO),
+ io__nl(!IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" in `pragma termination_info'.\n", !IO),
+ module_info_incr_errors(!ModuleInfo)
+ )
+ ;
+ % XXX This happens in `.trans_opt' files sometimes --
+ % so just ignore it
+ true
+ % undefined_pred_or_func_error(SymName, Arity, Context,
+ % "`:- pragma termination_info' declaration",
+ % !IO),
+ % module_info_incr_errors(!ModuleInfo)
+ ).
+
+module_add_pragma_import(PredName, PredOrFunc, Modes, Attributes, C_Function,
+ Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ module_info_name(!.ModuleInfo, ModuleName),
+ list__length(Modes, Arity),
+
+ globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ (
+ VeryVerbose = yes,
+ io__write_string("% Processing `:- pragma import' for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string("...\n", !IO)
+ ;
+ VeryVerbose = no
+ ),
+
+ % Lookup the pred declaration in the predicate table. (If it's not
+ % there, print an error message and insert a dummy declaration
+ % for the predicate.)
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ (
+ predicate_table_search_pf_sym_arity(PredicateTable0,
+ is_fully_qualified, PredOrFunc, PredName,
+ Arity, [PredId0])
+ ->
+ PredId = PredId0
+ ;
+ preds_add_implicit_report_error(ModuleName, PredOrFunc,
+ PredName, Arity, Status, no, Context, user(PredName),
+ "`:- pragma import' declaration", PredId, !ModuleInfo, !IO)
+ ),
+ % Lookup the pred_info for this pred, and check that it is valid.
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable2),
+ predicate_table_get_preds(PredicateTable2, Preds0),
+ map__lookup(Preds0, PredId, PredInfo0),
+ % Opt_imported preds are initially tagged as imported and are tagged as
+ % opt_imported only if/when we see a clause (including a `pragma import'
+ % clause) for them.
+ ( Status = opt_imported ->
+ pred_info_set_import_status(opt_imported, PredInfo0, PredInfo1)
+ ;
+ PredInfo1 = PredInfo0
+ ),
+ ( pred_info_is_imported(PredInfo1) ->
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma import' ", !IO),
+ io__write_string("declaration for imported ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string(".\n", !IO)
+ ; pred_info_clause_goal_type(PredInfo1) ->
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma import' declaration ", !IO),
+ io__write_string("for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string("\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" with preceding clauses.\n", !IO)
+ ;
+ pred_info_update_goal_type(pragmas, PredInfo1, PredInfo2),
+ % Add the pragma declaration to the proc_info for this procedure.
+ pred_info_procedures(PredInfo2, Procs),
+ map__to_assoc_list(Procs, ExistingProcs),
+ (
+ get_procedure_matching_argmodes(ExistingProcs, Modes,
+ !.ModuleInfo, ProcId)
+ ->
+ pred_add_pragma_import(PredId, ProcId, Attributes, C_Function,
+ Context, PredInfo2, PredInfo, !ModuleInfo, !QualInfo, !IO),
+ map__det_update(Preds0, PredId, PredInfo, Preds),
+ predicate_table_set_preds(Preds,
+ PredicateTable2, PredicateTable),
+ module_info_set_predicate_table(PredicateTable, !ModuleInfo)
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma import' ", !IO),
+ io__write_string("declaration for undeclared mode ", !IO),
+ io__write_string("of ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string(".\n", !IO)
+ )
+ ).
+
+ % Pred_add_pragma_import is a subroutine of module_add_pragma_import
+ % which adds the c_code for a `pragma import' declaration to a pred_info.
+ %
+:- pred pred_add_pragma_import(pred_id::in, proc_id::in,
+ pragma_foreign_proc_attributes::in, string::in, prog_context::in,
+ pred_info::in, pred_info::out, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+pred_add_pragma_import(PredId, ProcId, Attributes, C_Function, Context,
+ !PredInfo, !ModuleInfo, !QualInfo, !IO) :-
+ pred_info_procedures(!.PredInfo, Procs),
+ map__lookup(Procs, ProcId, ProcInfo),
+ foreign__make_pragma_import(!.PredInfo, ProcInfo, C_Function, Context,
+ PragmaImpl, VarSet, PragmaVars, ArgTypes, Arity, PredOrFunc,
+ !ModuleInfo, !IO),
+
+ % Lookup some information we need from the pred_info and proc_info.
+ PredName = pred_info_name(!.PredInfo),
+ PredModule = pred_info_module(!.PredInfo),
+ pred_info_clauses_info(!.PredInfo, Clauses0),
+ pred_info_get_purity(!.PredInfo, Purity),
+
+ % Add the code for this `pragma import' to the clauses_info.
+ clauses_info_add_pragma_foreign_proc(Purity, Attributes, PredId, ProcId,
+ VarSet, PragmaVars, ArgTypes, PragmaImpl, Context, PredOrFunc,
+ qualified(PredModule, PredName), Arity, Clauses0, Clauses,
+ !ModuleInfo, !IO),
+
+ % Store the clauses_info etc. back into the pred_info.
+ pred_info_set_clauses_info(Clauses, !PredInfo).
+
+%-----------------------------------------------------------------------------%
+
+module_add_pragma_foreign_proc(Attributes0, PredName, PredOrFunc, PVars, VarSet,
+ PragmaImpl, Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ %
+ % Begin by replacing any maybe_thread_safe foreign_proc attributes
+ % with the actual thread safety attributes which we get from the
+ % `--maybe-thread-safe' option.
+ %
+ globals__io_get_globals(Globals, !IO),
+ globals__get_maybe_thread_safe(Globals, MaybeThreadSafe),
+ ThreadSafe = Attributes0 ^ thread_safe,
+ ( ThreadSafe = maybe_thread_safe ->
+ (
+ MaybeThreadSafe = yes,
+ set_thread_safe(thread_safe, Attributes0, Attributes)
+ ;
+ MaybeThreadSafe = no,
+ set_thread_safe(not_thread_safe, Attributes0, Attributes)
+ )
+ ;
+ Attributes = Attributes0
+ ),
+ module_info_name(!.ModuleInfo, ModuleName),
+ PragmaForeignLanguage = foreign_language(Attributes),
+ list__length(PVars, Arity),
+ % print out a progress message
+ globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ (
+ VeryVerbose = yes,
+ io__write_string("% Processing `:- pragma foreign_proc' for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string("...\n", !IO)
+ ;
+ VeryVerbose = no
+ ),
+
+ globals__io_get_backend_foreign_languages(BackendForeignLangs, !IO),
+
+ % Lookup the pred declaration in the predicate table.
+ % (If it's not there, print an error message and insert
+ % a dummy declaration for the predicate.)
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
+ (
+ predicate_table_search_pf_sym_arity(PredTable0, is_fully_qualified,
+ PredOrFunc, PredName, Arity, [PredId0])
+ ->
+ PredId = PredId0
+ ;
+ preds_add_implicit_report_error(ModuleName, PredOrFunc,
+ PredName, Arity, Status, no, Context, user(PredName),
+ "`:- pragma foreign_proc' declaration",
+ PredId, !ModuleInfo, !IO)
+ ),
+
+ % Lookup the pred_info for this pred, add the pragma to the proc_info
+ % in the proc_table in the pred_info, and save the pred_info.
+ module_info_get_predicate_table(!.ModuleInfo, PredTable1),
+ predicate_table_get_preds(PredTable1, Preds0),
+ some [!PredInfo] (
+ map__lookup(Preds0, PredId, !:PredInfo),
+ PredInfo0 = !.PredInfo,
+
+ % opt_imported preds are initially tagged as imported and are
+ % tagged as opt_imported only if/when we see a clause (including
+ % a `pragma c_code' clause) for them
+ ( Status = opt_imported ->
+ pred_info_set_import_status(opt_imported, !PredInfo)
+ ;
+ true
+ ),
+ (
+ % If this procedure was previously defined as clauses only
+ % then we need to turn all the non mode-specific clauses
+ % into mode-specific clauses.
+ pred_info_clause_goal_type(!.PredInfo)
+ ->
+ pred_info_clauses_info(!.PredInfo, CInfo0),
+ clauses_info_clauses_only(CInfo0, ClauseList0),
+ ClauseList = list__map(
+ (func(C) = Res :-
+ AllProcIds = pred_info_all_procids(!.PredInfo),
+ ( C = clause([], Goal, mercury, Ctxt) ->
+ Res = clause(AllProcIds, Goal, mercury, Ctxt)
+ ;
+ Res = C
+ )
+ ), ClauseList0),
+ clauses_info_set_clauses(ClauseList, CInfo0, CInfo),
+ pred_info_set_clauses_info(CInfo, !PredInfo)
+ ;
+ true
+ ),
+ lookup_current_backend(CurrentBackend, !IO),
+ (
+ ExtraAttrs = extra_attributes(Attributes),
+ is_applicable_for_current_backend(CurrentBackend, ExtraAttrs) = no
+ ->
+ % Ignore this foreign_proc.
+ true
+ ;
+ pred_info_is_imported(!.PredInfo)
+ ->
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma foreign_proc' " ++
+ "(or `pragma c_code')\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string("declaration for imported ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string(".\n", !IO)
+ ;
+ % Don't add clauses for foreign languages other
+ % than the ones we can generate code for.
+ not list__member(PragmaForeignLanguage, BackendForeignLangs)
+ ->
+ pred_info_update_goal_type(pragmas, PredInfo0, !:PredInfo),
+ module_info_set_pred_info(PredId, !.PredInfo, !ModuleInfo)
+ ;
+ % add the pragma declaration to the proc_info for this procedure
+ pred_info_procedures(!.PredInfo, Procs),
+ map__to_assoc_list(Procs, ExistingProcs),
+ pragma_get_modes(PVars, Modes),
+ (
+ get_procedure_matching_argmodes(ExistingProcs, Modes,
+ !.ModuleInfo, ProcId)
+ ->
+ pred_info_clauses_info(!.PredInfo, Clauses0),
+ pred_info_arg_types(!.PredInfo, ArgTypes),
+ pred_info_get_purity(!.PredInfo, Purity),
+ clauses_info_add_pragma_foreign_proc(Purity, Attributes,
+ PredId, ProcId, VarSet, PVars, ArgTypes, PragmaImpl,
+ Context, PredOrFunc, PredName, Arity, Clauses0, Clauses,
+ !ModuleInfo, !IO),
+ pred_info_set_clauses_info(Clauses, !PredInfo),
+ pred_info_update_goal_type(pragmas, !PredInfo),
+ map__det_update(Preds0, PredId, !.PredInfo, Preds),
+ predicate_table_set_preds(Preds, PredTable1, PredTable),
+ module_info_set_predicate_table(PredTable, !ModuleInfo),
+ pragma_get_var_infos(PVars, ArgInfo),
+ maybe_warn_pragma_singletons(PragmaImpl, PragmaForeignLanguage,
+ ArgInfo, Context, PredOrFunc - PredName/Arity,
+ !.ModuleInfo, !IO)
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma foreign_proc' ", !IO),
+ io__write_string("declaration for undeclared mode ", !IO),
+ io__write_string("of ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity,
+ !IO),
+ io__write_string(".\n", !IO)
+ )
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+module_add_pragma_tabled(EvalMethod, PredName, Arity, MaybePredOrFunc,
+ MaybeModes, Status, Context, !ModuleInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ EvalMethodS = eval_method_to_string(EvalMethod),
+
+ % Find out if we are tabling a predicate or a function
+ (
+ MaybePredOrFunc = yes(PredOrFunc0),
+ PredOrFunc = PredOrFunc0,
+
+ % Lookup the pred declaration in the predicate table.
+ % (If it's not there, print an error message and insert
+ % a dummy declaration for the predicate.)
+ (
+ predicate_table_search_pf_sym_arity(PredicateTable0,
+ is_fully_qualified, PredOrFunc,
+ PredName, Arity, PredIds0)
+ ->
+ PredIds = PredIds0
+ ;
+ module_info_name(!.ModuleInfo, ModuleName),
+ string__format("`:- pragma %s' declaration",
+ [s(EvalMethodS)], Message1),
+
+ preds_add_implicit_report_error(ModuleName, PredOrFunc,
+ PredName, Arity, Status, no, Context,
+ user(PredName), Message1, PredId, !ModuleInfo,
+ !IO),
+ PredIds = [PredId]
+ )
+ ;
+ MaybePredOrFunc = no,
+ (
+ predicate_table_search_sym_arity(PredicateTable0,
+ is_fully_qualified, PredName,
+ Arity, PredIds0)
+ ->
+ PredIds = PredIds0
+ ;
+ module_info_name(!.ModuleInfo, ModuleName),
+ string__format("`:- pragma %s' declaration",
+ [s(EvalMethodS)], Message1),
+
+ preds_add_implicit_report_error(ModuleName,
+ predicate, PredName, Arity, Status, no,
+ Context, user(PredName), Message1, PredId,
+ !ModuleInfo, !IO),
+ PredIds = [PredId]
+ )
+ ),
+ list__foldl2(module_add_pragma_tabled_2(EvalMethod, PredName,
+ Arity, MaybePredOrFunc, MaybeModes, Context),
+ PredIds, !ModuleInfo, !IO).
+
+:- pred module_add_pragma_tabled_2(eval_method::in, sym_name::in, int::in,
+ maybe(pred_or_func)::in, maybe(list(mode))::in, prog_context::in,
+ pred_id::in, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+module_add_pragma_tabled_2(EvalMethod0, PredName, Arity0, MaybePredOrFunc,
+ MaybeModes, Context, PredId, !ModuleInfo, !IO) :-
+
+ ( EvalMethod0 = eval_minimal(_) ->
+ globals__io_lookup_bool_option(use_minimal_model_own_stacks,
+ OwnStacks, !IO),
+ (
+ OwnStacks = yes,
+ EvalMethod = eval_minimal(own_stacks)
+ ;
+ OwnStacks = no,
+ EvalMethod = eval_minimal(stack_copy)
+ )
+ ;
+ EvalMethod = EvalMethod0
+ ),
+
+ % Lookup the pred_info for this pred,
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable),
+ predicate_table_get_preds(PredicateTable, Preds),
+ map__lookup(Preds, PredId, PredInfo0),
+
+ % Find out if we are tabling a predicate or a function
+ (
+ MaybePredOrFunc = yes(PredOrFunc0),
+ PredOrFunc = PredOrFunc0
+ ;
+ MaybePredOrFunc = no,
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo0)
+ ),
+ adjust_func_arity(PredOrFunc, Arity0, Arity),
+
+ % print out a progress message
+ EvalMethodS = eval_method_to_string(EvalMethod),
+ globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ ( VeryVerbose = yes ->
+ io__write_string("% Processing `:- pragma ", !IO),
+ io__write_string(EvalMethodS, !IO),
+ io__write_string("' for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string("...\n", !IO)
+ ;
+ true
+ ),
+
+ % Issue a warning if this predicate/function has a pragma inline
+ % declaration. Tabled procedures cannot be inlined.
+ pred_info_get_markers(PredInfo0, Markers),
+ globals.io_lookup_bool_option(warn_table_with_inline, WarnInline, !IO),
+ ( check_marker(Markers, inline), WarnInline = yes ->
+ PredNameStr = hlds_out.simple_call_id_to_string(PredOrFunc,
+ PredName/Arity),
+ TablePragmaStr = string.format("`:- pragma %s'",
+ [s(EvalMethodS)]),
+ InlineWarning = [
+ words("Warning: "), fixed(PredNameStr),
+ words("has a"), nl, fixed(TablePragmaStr),
+ words("declaration but also has a"),
+ fixed("`:- pragma inline'"),
+ words("declaration."), nl,
+ words("This inline pragma will be ignored"),
+ words("since tabled predicates cannot be inlined."), nl,
+ words("You can use the"),
+ fixed("`--no-warn-table-with-inline'"),
+ words("option to suppress this warning.")
+ ],
+ error_util.report_warning(Context, 0, InlineWarning, !IO)
+ ;
+ true
+ ),
+ ( pred_info_is_imported(PredInfo0) ->
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma ", !IO),
+ io__write_string(EvalMethodS, !IO),
+ io__write_string("' declaration for imported ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
+ io__write_string(".\n", !IO)
+ ;
+ % do we have to make sure the tabled preds are stratified?
+ ( eval_method_needs_stratification(EvalMethod) = yes ->
+ module_info_stratified_preds(!.ModuleInfo, StratPredIds0),
+ set__insert(StratPredIds0, PredId, StratPredIds),
+ module_info_set_stratified_preds(StratPredIds, !ModuleInfo)
+ ;
+ true
+ ),
+
+ % add the eval model to the proc_info for this procedure
+ pred_info_procedures(PredInfo0, Procs0),
+ map__to_assoc_list(Procs0, ExistingProcs),
+ (
+ MaybeModes = yes(Modes),
+ (
+ get_procedure_matching_argmodes(ExistingProcs,
+ Modes, !.ModuleInfo, ProcId)
+ ->
+ map__lookup(Procs0, ProcId, ProcInfo0),
+ proc_info_set_eval_method(EvalMethod, ProcInfo0, ProcInfo),
+ map__det_update(Procs0, ProcId, ProcInfo, Procs),
+ pred_info_set_procedures(Procs, PredInfo0, PredInfo),
+ module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma ", !IO),
+ io__write_string(EvalMethodS, !IO),
+ io__write_string("' declaration for " ++
+ "undeclared mode of ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity,
+ !IO),
+ io__write_string(".\n", !IO)
+ )
+ ;
+ MaybeModes = no,
+ (
+ ExistingProcs = [],
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma ", !IO),
+ io__write_string(EvalMethodS, !IO),
+ io__write_string("' declaration for\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" ", !IO),
+ hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity,
+ !IO),
+ io__write_string(" with no declared modes.\n", !IO)
+ ;
+ ExistingProcs = [_ | _],
+ set_eval_method_list(ExistingProcs, Context, PredOrFunc,
+ PredName/Arity, EvalMethod, Procs0, Procs, !ModuleInfo,
+ !IO),
+ pred_info_set_procedures(Procs, PredInfo0, PredInfo),
+ module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
+ )
+ )
+ ).
+
+:- pred set_eval_method_list(assoc_list(proc_id, proc_info)::in,
+ prog_context::in, pred_or_func::in, sym_name_and_arity::in,
+ eval_method::in, proc_table::in, proc_table::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+set_eval_method_list([], _, _, _, _, !Procs, !ModuleInfo, !IO).
+set_eval_method_list([ProcId - ProcInfo0 | Rest], Context, PredOrFunc,
+ PredNameAndArity, EvalMethod, !Procs, !ModuleInfo, !IO) :-
+ proc_info_eval_method(ProcInfo0, OldEvalMethod),
+ % NOTE: We don't bother detecting multiple tabling pragmas
+ % of the same type here.
+ (
+ OldEvalMethod \= eval_normal,
+ OldEvalMethod \= EvalMethod
+ ->
+ % If there are conflicting tabling pragmas then
+ % emit an error message and do not bother changing
+ % the evaluation method.
+ OldEvalMethodStr = eval_method_to_string(OldEvalMethod),
+ EvalMethodStr = eval_method_to_string(EvalMethod),
+ Name = hlds_out.simple_call_id_to_string(PredOrFunc, PredNameAndArity),
+ ErrorMsg = [words("Error:"), fixed(Name), words("has both"),
+ fixed(OldEvalMethodStr), words("and"), fixed(EvalMethodStr),
+ words("pragmas specified."),
+ words("Only one kind of tabling pragma may be applied to it.")
+ ],
+ module_info_incr_errors(!ModuleInfo),
+ error_util.write_error_pieces(Context, 0, ErrorMsg, !IO)
+ ;
+ proc_info_set_eval_method(EvalMethod, ProcInfo0, ProcInfo),
+ map__det_update(!.Procs, ProcId, ProcInfo, !:Procs)
+ ),
+ set_eval_method_list(Rest, Context, PredOrFunc, PredNameAndArity,
+ EvalMethod, !Procs, !ModuleInfo, !IO).
+ % Extract the modes from the list of pragma_vars.
+ %
+:- pred pragma_get_modes(list(pragma_var)::in, list(mode)::out) is det.
+
+pragma_get_modes([], []).
+pragma_get_modes([PragmaVar | Vars], [Mode | Modes]) :-
+ PragmaVar = pragma_var(_Var, _Name, Mode),
+ pragma_get_modes(Vars, Modes).
+
+%-----------------------------------------------------------------------------%
+
+ % Extract the vars from the list of pragma_vars.
+ %
+:- pred pragma_get_vars(list(pragma_var)::in, list(prog_var)::out) is det.
+
+pragma_get_vars([], []).
+pragma_get_vars([PragmaVar | PragmaVars], [Var | Vars]) :-
+ PragmaVar = pragma_var(Var, _Name, _Mode),
+ pragma_get_vars(PragmaVars, Vars).
+
+%---------------------------------------------------------------------------%
+
+ % Extract the names from the list of pragma_vars.
+ %
+:- pred pragma_get_var_infos(list(pragma_var)::in,
+ list(maybe(pair(string, mode)))::out) is det.
+
+pragma_get_var_infos([], []).
+pragma_get_var_infos([PragmaVar | PragmaVars], [yes(Name - Mode) | Info]) :-
+ PragmaVar = pragma_var(_Var, Name, Mode),
+ pragma_get_var_infos(PragmaVars, Info).
+
+module_add_pragma_fact_table(Pred, Arity, FileName, Status, Context,
+ !ModuleInfo, !QualInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable),
+ (
+ predicate_table_search_sym_arity(PredicateTable, is_fully_qualified,
+ Pred, Arity, PredIDs0),
+ PredIDs0 = [PredID | PredIDs1]
+ ->
+ (
+ PredIDs1 = [], % only one predicate found
+ module_info_pred_info(!.ModuleInfo, PredID, PredInfo0),
+
+ % Compile the fact table into a separate .o file.
+ fact_table_compile_facts(Pred, Arity, FileName,
+ PredInfo0, PredInfo, Context, !.ModuleInfo,
+ C_HeaderCode, PrimaryProcID, !IO),
+
+ module_info_set_pred_info(PredID, PredInfo, !ModuleInfo),
+ pred_info_procedures(PredInfo, ProcTable),
+ pred_info_arg_types(PredInfo, ArgTypes),
+ ProcIDs = pred_info_procids(PredInfo),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+ adjust_func_arity(PredOrFunc, Arity, NumArgs),
+
+ % Create foreign_decls to declare extern variables.
+ module_add_foreign_decl(c, foreign_decl_is_local,
+ C_HeaderCode, Context, !ModuleInfo),
+
+ module_add_fact_table_file(FileName, !ModuleInfo),
+
+ io__get_exit_status(ExitStatus, !IO),
+ ( ExitStatus = 1 ->
+ true
+ ;
+ % Create foreign_procs to access the table in each mode.
+ module_add_fact_table_procedures(ProcIDs,
+ PrimaryProcID, ProcTable, Pred,
+ PredOrFunc, NumArgs, ArgTypes, Status,
+ Context, !ModuleInfo, !QualInfo, !IO)
+ )
+ ;
+ PredIDs1 = [_ | _], % >1 predicate found
+ io__set_exit_status(1, !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string("In pragma fact_table for `", !IO),
+ prog_out__write_sym_name_and_arity(Pred/Arity, !IO),
+ io__write_string("':\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" error: " ++
+ "ambiguous predicate/function name.\n", !IO)
+ )
+ ;
+ undefined_pred_or_func_error(Pred, Arity, Context,
+ "`:- pragma fact_table' declaration", !IO)
+ ).
+
+ % Add a `pragma c_code' for each mode of the fact table lookup to the
+ % HLDS.
+ % `pragma fact_table's are represented in the HLDS by a
+ % `pragma c_code' for each mode of the predicate.
+ %
+:- pred module_add_fact_table_procedures(list(proc_id)::in, proc_id::in,
+ proc_table::in, sym_name::in, pred_or_func::in, arity::in,
+ list(type)::in, import_status::in, prog_context::in,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+module_add_fact_table_procedures([],_,_,_,_,_,_,_,_, !ModuleInfo, !QualInfo,
+ !IO).
+module_add_fact_table_procedures([ProcID | ProcIDs], PrimaryProcID, ProcTable,
+ SymName, PredOrFunc, Arity, ArgTypes, Status, Context,
+ !ModuleInfo, !QualInfo, !IO) :-
+ module_add_fact_table_proc(ProcID, PrimaryProcID, ProcTable, SymName,
+ PredOrFunc, Arity, ArgTypes, Status, Context,
+ !ModuleInfo, !QualInfo, !IO),
+ module_add_fact_table_procedures(ProcIDs, PrimaryProcID, ProcTable,
+ SymName, PredOrFunc, Arity, ArgTypes, Status, Context,
+ !ModuleInfo, !QualInfo, !IO).
+
+:- pred module_add_fact_table_proc(proc_id::in, proc_id::in, proc_table::in,
+ sym_name::in, pred_or_func::in, arity::in, list(type)::in,
+ import_status::in, prog_context::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+module_add_fact_table_proc(ProcID, PrimaryProcID, ProcTable, SymName,
+ PredOrFunc, Arity, ArgTypes, Status, Context, !ModuleInfo, !QualInfo,
+ !IO) :-
+ map__lookup(ProcTable, ProcID, ProcInfo),
+ varset__init(VarSet0),
+ varset__new_vars(VarSet0, Arity, Vars, VarSet),
+ proc_info_argmodes(ProcInfo, Modes),
+ fact_table_pragma_vars(Vars, Modes, VarSet, PragmaVars),
+ fact_table_generate_c_code(SymName, PragmaVars, ProcID, PrimaryProcID,
+ ProcInfo, ArgTypes, !.ModuleInfo, C_ProcCode, C_ExtraCode, !IO),
+
+ % XXX this should be modified to use nondet pragma c_code.
+ Attrs0 = default_attributes(c),
+ set_may_call_mercury(will_not_call_mercury, Attrs0, Attrs1),
+ set_thread_safe(thread_safe, Attrs1, Attrs2),
+ % fact tables procedures should be considered pure
+ set_purity(pure, Attrs2, Attrs),
+ module_add_pragma_foreign_proc(Attrs, SymName, PredOrFunc, PragmaVars,
+ VarSet, ordinary(C_ProcCode, no), Status, Context,
+ !ModuleInfo, !QualInfo, !IO),
+ ( C_ExtraCode = "" ->
+ true
+ ;
+ module_add_foreign_body_code(c, C_ExtraCode, Context, !ModuleInfo)
+ ),
+ %
+ % The C code for fact tables includes C labels;
+ % we cannot inline this code, because if we try,
+ % the result may be duplicate labels in the generated code.
+ % So we must disable inlining for fact_table procedures.
+ %
+ add_pred_marker("fact_table", SymName, Arity, Status, Context,
+ no_inline, [], !ModuleInfo, !IO).
+
+ % Create a list(pragma_var) that looks like the ones that are created
+ % for foreign_proc in prog_io.m.
+ % This is required by module_add_pragma_c_code to add the C code for
+ % the procedure to the HLDS.
+ %
+:- pred fact_table_pragma_vars(list(prog_var)::in, list(mode)::in,
+ prog_varset::in, list(pragma_var)::out) is det.
+
+fact_table_pragma_vars(Vars0, Modes0, VarSet, PragmaVars0) :-
+ (
+ Vars0 = [Var | VarsTail],
+ Modes0 = [Mode | ModesTail]
+ ->
+ varset__lookup_name(VarSet, Var, Name),
+ PragmaVar = pragma_var(Var, Name, Mode),
+ fact_table_pragma_vars(VarsTail, ModesTail, VarSet, PragmaVarsTail),
+ PragmaVars0 = [PragmaVar | PragmaVarsTail]
+ ;
+ PragmaVars0 = []
+ ).
+
+ % Add the pragma_foreign_proc goal to the clauses_info for this procedure.
+ % To do so, we must also insert unifications between the variables in the
+ % pragma foreign_proc declaration and the head vars of the pred. Also
+ % return the hlds_goal.
+ %
+:- pred clauses_info_add_pragma_foreign_proc(purity::in,
+ pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
+ prog_varset::in, list(pragma_var)::in, list(type)::in,
+ pragma_foreign_code_impl::in, prog_context::in, pred_or_func::in,
+ sym_name::in, arity::in, clauses_info::in, clauses_info::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+clauses_info_add_pragma_foreign_proc(Purity, Attributes0, PredId, ProcId,
+ PVarSet, PVars, OrigArgTypes, PragmaImpl0, Context, PredOrFunc,
+ PredName, Arity, !ClausesInfo, !ModuleInfo, !IO) :-
+
+ !.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes, TVarNameMap,
+ InferredVarTypes, HeadVars, ClauseRep, RttiVarMaps,
+ _HasForeignClauses),
+ get_clause_list(ClauseRep, ClauseList),
+
+ % Find all the existing clauses for this mode, and
+ % extract their implementation language and clause number
+ % (that is, their index in the list).
+ globals__io_get_globals(Globals, !IO),
+ globals__io_get_target(Target, !IO),
+ NewLang = foreign_language(Attributes0),
+ list__foldl2(decide_action(Globals, Target, NewLang, ProcId), ClauseList,
+ add, FinalAction, 1, _),
+
+ globals__io_get_backend_foreign_languages(BackendForeignLanguages, !IO),
+ pragma_get_vars(PVars, Args0),
+ pragma_get_var_infos(PVars, ArgInfo),
+
+ %
+ % If the foreign language not one of the backend languages, we will
+ % have to generate an interface to it in a backend language.
+ %
+ foreign__extrude_pragma_implementation(BackendForeignLanguages,
+ PVars, PredName, PredOrFunc, Context, !ModuleInfo,
+ Attributes0, Attributes, PragmaImpl0, PragmaImpl),
+
+ %
+ % Check for arguments occurring multiple times.
+ %
+ bag__init(ArgBag0),
+ bag__insert_list(ArgBag0, Args0, ArgBag),
+ bag__to_assoc_list(ArgBag, ArgBagAL0),
+ list__filter(
+ (pred(Arg::in) is semidet :-
+ Arg = _ - Occurrences,
+ Occurrences > 1
+ ), ArgBagAL0, ArgBagAL),
+ assoc_list__keys(ArgBagAL, MultipleArgs),
+
+ (
+ MultipleArgs = [_ | _],
+ prog_out__write_context(Context, !IO),
+ io__write_string("In `:- pragma foreign_proc' declaration for ", !IO),
+ adjust_func_arity(PredOrFunc, OrigArity, Arity),
+ hlds_out__write_simple_call_id(PredOrFunc - PredName/OrigArity, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" error: ", !IO),
+ (
+ MultipleArgs = [MultipleArg],
+ io__write_string("variable `", !IO),
+ mercury_output_var(MultipleArg, PVarSet, no, !IO),
+ io__write_string("' occurs multiple times\n", !IO)
+ ;
+ MultipleArgs = [_, _ | _],
+ io__write_string("variables `", !IO),
+ mercury_output_vars(MultipleArgs, PVarSet, no, !IO),
+ io__write_string("' occur multiple times\n", !IO)
+ ),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" in the argument list.\n", !IO),
+ io__set_exit_status(1, !IO)
+ ;
+ MultipleArgs = [],
+ % build the pragma_c_code
+ goal_info_init(GoalInfo0),
+ goal_info_set_context(GoalInfo0, Context, GoalInfo1),
+ % Put the purity in the goal_info in case this foreign code is inlined.
+ add_goal_info_purity_feature(GoalInfo1, Purity, GoalInfo),
+ make_foreign_args(HeadVars, ArgInfo, OrigArgTypes,
+ ForeignArgs),
+ HldsGoal0 = foreign_proc(Attributes, PredId, ProcId,
+ ForeignArgs, [], PragmaImpl) - GoalInfo,
+ map__init(EmptyVarTypes),
+ implicitly_quantify_clause_body(HeadVars, _Warnings,
+ HldsGoal0, HldsGoal, VarSet0, VarSet, EmptyVarTypes, _),
+ NewClause = clause([ProcId], HldsGoal, foreign_language(NewLang),
+ Context),
+ (
+ FinalAction = ignore,
+ NewClauseList = ClauseList
+ ;
+ FinalAction = add,
+ NewClauseList = [NewClause | ClauseList]
+ ;
+ FinalAction = replace(N),
+ list__replace_nth_det(ClauseList, N, NewClause, NewClauseList)
+ ;
+ FinalAction = split_add(N, Clause),
+ list__replace_nth_det(ClauseList, N, Clause, NewClauseListTail),
+ NewClauseList = [NewClause | NewClauseListTail]
+ ),
+ HasForeignClauses = yes,
+ set_clause_list(NewClauseList, NewClauseRep),
+ !:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
+ InferredVarTypes, HeadVars, NewClauseRep, RttiVarMaps,
+ HasForeignClauses)
+ ).
+
+:- func is_applicable_for_current_backend(backend,
+ list(pragma_foreign_proc_extra_attribute)) = bool.
+
+is_applicable_for_current_backend(_CurrentBackend, []) = yes.
+is_applicable_for_current_backend(CurrentBackend, [Attr | Attrs]) = Result :-
+ (
+ Attr = max_stack_size(_),
+ Result = is_applicable_for_current_backend(CurrentBackend, Attrs)
+ ;
+ Attr = backend(Backend),
+ ( Backend = CurrentBackend ->
+ Result = is_applicable_for_current_backend(CurrentBackend, Attrs)
+ ;
+ Result = no
+ )
+ ).
+
+lookup_current_backend(CurrentBackend, !IO) :-
+ globals__io_lookup_bool_option(highlevel_code, HighLevel, !IO),
+ (
+ HighLevel = yes,
+ CurrentBackend = high_level_backend
+ ;
+ HighLevel= no,
+ CurrentBackend = low_level_backend
+ ).
+
+ % As we traverse the clauses, at each one decide which action to perform.
+ %
+ % If there are no clauses, we will simply add this clause.
+ %
+ % If there are matching foreign_proc clauses for this proc_id,
+ % we will either replace them or ignore the new clause
+ % (depending on the preference of the two foreign languages).
+ %
+ % If there is a matching Mercury clause for this proc_id, we will either
+ % - replace it if there is only one matching mode in its proc_id list.
+ % - remove the matching proc_id from its proc_id list, and add this
+ % clause as a new clause for this mode.
+
+:- type foreign_proc_action
+ ---> ignore
+ ; add
+ ; split_add(int, clause)
+ ; replace(int).
+
+:- pred decide_action(globals::in, compilation_target::in,
+ foreign_language::in, proc_id::in, clause::in,
+ foreign_proc_action::in, foreign_proc_action::out,
+ int::in, int::out) is det.
+
+decide_action(Globals, Target, NewLang, ProcId, Clause, !Action, !ClauseNum) :-
+ Clause = clause(ProcIds, Body, ClauseLang, Context),
+ (
+ ClauseLang = mercury,
+ ( ProcIds = [ProcId] ->
+ !:Action = replace(!.ClauseNum)
+ ; list__delete_first(ProcIds, ProcId, MercuryProcIds) ->
+ NewMercuryClause = clause(MercuryProcIds, Body, ClauseLang,
+ Context),
+ !:Action = split_add(!.ClauseNum, NewMercuryClause)
+ ;
+ true
+ )
+ ;
+ ClauseLang = foreign_language(OldLang),
+ ( list__member(ProcId, ProcIds) ->
+ (
+ yes = prefer_foreign_language(Globals, Target,
+ OldLang, NewLang)
+ ->
+ % This language is preferred to the old
+ % language, so we should replace it
+ !:Action = replace(!.ClauseNum)
+ ;
+ % Just ignore it.
+ !:Action = ignore
+ )
+ ;
+ true
+ )
+ ),
+ !:ClauseNum = !.ClauseNum + 1.
+
+ % Find the procedure with argmodes which match the ones we want.
+ %
+:- pred get_procedure_matching_argmodes(assoc_list(proc_id, proc_info)::in,
+ list(mode)::in, module_info::in, proc_id::out) is semidet.
+
+get_procedure_matching_argmodes(Procs, Modes0, ModuleInfo, ProcId) :-
+ list__map(constrain_inst_vars_in_mode, Modes0, Modes),
+ get_procedure_matching_argmodes_2(Procs, Modes, ModuleInfo, ProcId).
+
+:- pred get_procedure_matching_argmodes_2(assoc_list(proc_id, proc_info)::in,
+ list(mode)::in, module_info::in, proc_id::out) is semidet.
+
+get_procedure_matching_argmodes_2([P | Procs], Modes, ModuleInfo, OurProcId) :-
+ P = ProcId - ProcInfo,
+ proc_info_argmodes(ProcInfo, ArgModes),
+ ( mode_list_matches(Modes, ArgModes, ModuleInfo) ->
+ OurProcId = ProcId
+ ;
+ get_procedure_matching_argmodes_2(Procs, Modes, ModuleInfo, OurProcId)
+ ).
+
+get_procedure_matching_declmodes(Procs, Modes0, ModuleInfo, ProcId) :-
+ list__map(constrain_inst_vars_in_mode, Modes0, Modes),
+ get_procedure_matching_declmodes_2(Procs, Modes, ModuleInfo, ProcId).
+
+:- pred get_procedure_matching_declmodes_2(assoc_list(proc_id, proc_info)::in,
+ list(mode)::in, module_info::in, proc_id::out) is semidet.
+
+get_procedure_matching_declmodes_2([P | Procs], Modes, ModuleInfo,
+ OurProcId) :-
+ P = ProcId - ProcInfo,
+ proc_info_declared_argmodes(ProcInfo, ArgModes),
+ ( mode_list_matches(Modes, ArgModes, ModuleInfo) ->
+ OurProcId = ProcId
+ ;
+ get_procedure_matching_declmodes_2(Procs, Modes, ModuleInfo, OurProcId)
+ ).
+
+:- pred mode_list_matches(list(mode)::in, list(mode)::in, module_info::in)
+ is semidet.
+
+mode_list_matches([], [], _).
+mode_list_matches([Mode1 | Modes1], [Mode2 | Modes2], ModuleInfo) :-
+ % Use mode_get_insts_semidet instead of mode_get_insts to avoid
+ % aborting if there are undefined modes.
+ mode_get_insts_semidet(ModuleInfo, Mode1, Inst1, Inst2),
+ mode_get_insts_semidet(ModuleInfo, Mode2, Inst1, Inst2),
+ mode_list_matches(Modes1, Modes2, ModuleInfo).
Index: compiler/add_pred.m
===================================================================
RCS file: compiler/add_pred.m
diff -N compiler/add_pred.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_pred.m 25 Jul 2005 08:19:37 -0000
@@ -0,0 +1,498 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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.
+%-----------------------------------------------------------------------------%
+%
+% This submodule of make_hlds handles the type and mode declarations
+% for predicates.
+
+:- module hlds__make_hlds__add_pred.
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module mdbcomp__prim_data.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module parse_tree__prog_data.
+
+:- import_module bool.
+:- import_module io.
+:- import_module list.
+:- import_module std_util.
+
+:- pred module_add_pred_or_func(tvarset::in, inst_varset::in, existq_tvars::in,
+ pred_or_func::in, sym_name::in, list(type_and_mode)::in,
+ maybe(determinism)::in, purity::in,
+ prog_constraints::in, pred_markers::in, prog_context::in,
+ item_status::in, maybe(pair(pred_id, proc_id))::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+:- pred do_add_new_proc(inst_varset::in, arity::in, list(mode)::in,
+ maybe(list(mode))::in, maybe(list(is_live))::in,
+ maybe(determinism)::in, prog_context::in, is_address_taken::in,
+ pred_info::in, pred_info::out, proc_id::out) is det.
+
+ % Add a mode declaration for a predicate.
+ %
+:- pred module_add_mode(inst_varset::in, sym_name::in, list(mode)::in,
+ maybe(determinism)::in, import_status::in, prog_context::in,
+ pred_or_func::in, bool::in, pair(pred_id, proc_id)::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+ % Whenever there is a clause or mode declaration for an undeclared
+ % predicate, we add an implicit declaration
+ % :- pred p(T1, T2, ..., Tn).
+ % for that predicate; the real types will be inferred by
+ % type inference.
+ %
+:- pred preds_add_implicit_report_error(module_name::in, pred_or_func::in,
+ sym_name::in, arity::in, import_status::in, bool::in, prog_context::in,
+ pred_origin::in, string::in, pred_id::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+:- pred preds_add_implicit_for_assertion(prog_vars::in, module_info::in,
+ module_name::in, sym_name::in, arity::in, import_status::in,
+ prog_context::in, pred_or_func::in, pred_id::out,
+ predicate_table::in, predicate_table::out) is det.
+
+:- implementation.
+
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_out.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__make_hlds_error.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_util.
+
+:- import_module map.
+:- import_module require.
+:- import_module set.
+:- import_module term.
+:- import_module varset.
+
+module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars,
+ PredOrFunc, PredName, TypesAndModes, MaybeDet, Purity,
+ ClassContext, Markers, Context, item_status(Status, NeedQual),
+ MaybePredProcId, !ModuleInfo, !IO) :-
+ split_types_and_modes(TypesAndModes, Types, MaybeModes0),
+ add_new_pred(TypeVarSet, ExistQVars, PredName, Types, Purity, ClassContext,
+ Markers, Context, Status, NeedQual, PredOrFunc, !ModuleInfo, !IO),
+ (
+ PredOrFunc = predicate,
+ MaybeModes0 = yes(Modes0),
+
+ % For predicates with no arguments, if the determinism is not declared
+ % a mode is not added. The determinism can be specified by a separate
+ % mode declaration.
+ Modes0 = [],
+ MaybeDet = no
+ ->
+ MaybeModes = no
+ ;
+ % Assume that a function with no modes but with a determinism
+ % declared has the default modes.
+ PredOrFunc = function,
+ MaybeModes0 = no,
+ MaybeDet = yes(_)
+ ->
+ list__length(Types, Arity),
+ adjust_func_arity(function, FuncArity, Arity),
+ in_mode(InMode),
+ list__duplicate(FuncArity, InMode, InModes),
+ out_mode(OutMode),
+ list__append(InModes, [OutMode], ArgModes),
+ MaybeModes = yes(ArgModes)
+ ;
+ MaybeModes = MaybeModes0
+ ),
+ (
+ MaybeModes = yes(Modes),
+ ( check_marker(Markers, class_method) ->
+ IsClassMethod = yes
+ ;
+ IsClassMethod = no
+ ),
+ module_add_mode(InstVarSet, PredName, Modes, MaybeDet, Status, Context,
+ PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !IO),
+ MaybePredProcId = yes(PredProcId)
+ ;
+ MaybeModes = no,
+ MaybePredProcId = no
+ ).
+
+ % NB. Predicates are also added in lambda.m, which converts
+ % lambda expressions into separate predicates, so any changes may need
+ % to be reflected there too.
+ %
+:- pred add_new_pred(tvarset::in, existq_tvars::in, sym_name::in,
+ list(type)::in, purity::in, prog_constraints::in,
+ pred_markers::in, prog_context::in, import_status::in,
+ need_qualifier::in, pred_or_func::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+add_new_pred(TVarSet, ExistQVars, PredName, Types, Purity, ClassContext,
+ Markers0, Context, ItemStatus, NeedQual, PredOrFunc, !ModuleInfo,
+ !IO) :-
+ % Only preds with opt_imported clauses are tagged as opt_imported, so
+ % that the compiler doesn't look for clauses for other preds read in
+ % from optimization interfaces.
+ ( ItemStatus = opt_imported ->
+ Status = imported(interface)
+ ;
+ Status = ItemStatus
+ ),
+ module_info_name(!.ModuleInfo, ModuleName),
+ list__length(Types, Arity),
+ (
+ PredName = unqualified(_PName),
+ module_info_incr_errors(!ModuleInfo),
+ unqualified_pred_error(PredName, Arity, Context, !IO)
+ % All predicate names passed into this predicate should have
+ % been qualified by prog_io.m, when they were first read.
+ ;
+ PredName = qualified(MNameOfPred, PName),
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
+ clauses_info_init(Arity, ClausesInfo),
+ map__init(Proofs),
+ map__init(ConstraintMap),
+ purity_to_markers(Purity, PurityMarkers),
+ markers_to_marker_list(PurityMarkers, MarkersList),
+ list__foldl(add_marker, MarkersList, Markers0, Markers),
+ globals__io_lookup_string_option(aditi_user, Owner, !IO),
+ pred_info_init(ModuleName, PredName, Arity, PredOrFunc, Context,
+ user(PredName), Status, none, Markers, Types, TVarSet, ExistQVars,
+ ClassContext, Proofs, ConstraintMap, Owner, ClausesInfo,
+ PredInfo0),
+ (
+ predicate_table_search_pf_m_n_a(PredTable0,
+ is_fully_qualified, PredOrFunc, MNameOfPred,
+ PName, Arity, [OrigPred|_])
+ ->
+ module_info_pred_info(!.ModuleInfo, OrigPred, OrigPredInfo),
+ pred_info_context(OrigPredInfo, OrigContext),
+ DeclString = pred_or_func_to_str(PredOrFunc),
+ adjust_func_arity(PredOrFunc, OrigArity, Arity),
+ multiple_def_error(ItemStatus, PredName, OrigArity, DeclString,
+ Context, OrigContext, FoundError, !IO),
+ (
+ FoundError = yes,
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ FoundError = no
+ )
+ ;
+ module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
+ predicate_table_insert(PredInfo0, NeedQual, PQInfo, PredId,
+ PredTable0, PredTable1),
+ ( pred_info_is_builtin(PredInfo0) ->
+ add_builtin(PredId, Types, PredInfo0, PredInfo),
+ predicate_table_get_preds(PredTable1, Preds1),
+ map__det_update(Preds1, PredId, PredInfo, Preds),
+ predicate_table_set_preds(Preds, PredTable1, PredTable)
+ ;
+ PredTable = PredTable1
+ ),
+ module_info_set_predicate_table(PredTable, !ModuleInfo)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred add_builtin(pred_id::in, list(type)::in, pred_info::in, pred_info::out)
+ is det.
+
+ % For a builtin predicate, say foo/2, we add a clause
+ %
+ % foo(H1, H2) :- foo(H1, H2).
+ %
+ % This does not generate an infinite loop!
+ % Instead, the compiler will generate the usual builtin inline code
+ % for foo/2 in the body. The reason for generating this
+ % forwarding code stub is so that things work correctly if
+ % you take the address of the predicate.
+ %
+add_builtin(PredId, Types, !PredInfo) :-
+ %
+ % lookup some useful info: Module, Name, Context, HeadVars
+ %
+ Module = pred_info_module(!.PredInfo),
+ Name = pred_info_name(!.PredInfo),
+ pred_info_context(!.PredInfo, Context),
+ pred_info_clauses_info(!.PredInfo, ClausesInfo0),
+ clauses_info_varset(ClausesInfo0, VarSet),
+ clauses_info_headvars(ClausesInfo0, HeadVars),
+
+ %
+ % construct the pseudo-recursive call to Module:Name(HeadVars)
+ %
+ SymName = qualified(Module, Name),
+ ModeId = invalid_proc_id, % mode checking will figure it out
+ MaybeUnifyContext = no,
+ Call = call(PredId, ModeId, HeadVars, inline_builtin, MaybeUnifyContext,
+ SymName),
+
+ %
+ % construct a clause containing that pseudo-recursive call
+ %
+ goal_info_init(Context, GoalInfo0),
+ set__list_to_set(HeadVars, NonLocals),
+ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+ Goal = Call - GoalInfo,
+ Clause = clause([], Goal, mercury, Context),
+
+ %
+ % put the clause we just built into the pred_info,
+ % annotateed with the appropriate types
+ %
+ map__from_corresponding_lists(HeadVars, Types, VarTypes),
+ map__init(TVarNameMap),
+ rtti_varmaps_init(RttiVarMaps),
+ HasForeignClauses = no,
+ set_clause_list([Clause], ClausesRep),
+ ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
+ HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses),
+ pred_info_set_clauses_info(ClausesInfo, !PredInfo),
+
+ %
+ % It's pointless but harmless to inline these clauses.
+ % The main purpose of the `no_inline' marker is to stop
+ % constraint propagation creating real infinite loops in
+ % the generated code when processing calls to these
+ % predicates. The code generator will still generate
+ % inline code for calls to these predicates.
+ %
+ pred_info_get_markers(!.PredInfo, Markers0),
+ add_marker(no_inline, Markers0, Markers),
+ pred_info_set_markers(Markers, !PredInfo).
+
+%-----------------------------------------------------------------------------%
+
+do_add_new_proc(InstVarSet, Arity, ArgModes, MaybeDeclaredArgModes,
+ MaybeArgLives, MaybeDet, Context, IsAddressTaken, PredInfo0, PredInfo,
+ ModeId) :-
+ pred_info_procedures(PredInfo0, Procs0),
+ pred_info_arg_types(PredInfo0, ArgTypes),
+ next_mode_id(Procs0, ModeId),
+ proc_info_init(Context, Arity, ArgTypes, MaybeDeclaredArgModes,
+ ArgModes, MaybeArgLives, MaybeDet, IsAddressTaken, NewProc0),
+ proc_info_set_inst_varset(InstVarSet, NewProc0, NewProc),
+ map__det_insert(Procs0, ModeId, NewProc, Procs),
+ pred_info_set_procedures(Procs, PredInfo0, PredInfo).
+
+%-----------------------------------------------------------------------------%
+
+ % We should store the mode varset and the mode condition in the HLDS
+ % - at the moment we just ignore those two arguments.
+ %
+module_add_mode(InstVarSet, PredName, Modes, MaybeDet, Status, MContext,
+ PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !IO) :-
+ % Lookup the pred or func declaration in the predicate table.
+ % If it's not there (or if it is ambiguous), optionally print a
+ % warning message and insert an implicit definition for the
+ % predicate; it is presumed to be local, and its type
+ % will be inferred automatically.
+
+ module_info_name(!.ModuleInfo, ModuleName0),
+ sym_name_get_module_name(PredName, ModuleName0, ModuleName),
+ list__length(Modes, Arity),
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ (
+ predicate_table_search_pf_sym_arity(PredicateTable0,
+ is_fully_qualified, PredOrFunc, PredName, Arity, [PredId0])
+ ->
+ PredId = PredId0
+ ;
+ preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName,
+ Arity, Status, IsClassMethod, MContext, user(PredName),
+ "mode declaration", PredId, !ModuleInfo, !IO)
+ ),
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable1),
+ predicate_table_get_preds(PredicateTable1, Preds0),
+ map__lookup(Preds0, PredId, PredInfo0),
+
+ module_do_add_mode(InstVarSet, Arity, Modes, MaybeDet, IsClassMethod,
+ MContext, PredInfo0, PredInfo, ProcId, !IO),
+ map__det_update(Preds0, PredId, PredInfo, Preds),
+ predicate_table_set_preds(Preds, PredicateTable1, PredicateTable),
+ module_info_set_predicate_table(PredicateTable, !ModuleInfo),
+ PredProcId = PredId - ProcId.
+
+:- pred module_do_add_mode(inst_varset::in, arity::in, list(mode)::in,
+ maybe(determinism)::in, bool::in, prog_context::in,
+ pred_info::in, pred_info::out, proc_id::out, io::di, io::uo) is det.
+
+module_do_add_mode(InstVarSet, Arity, Modes, MaybeDet, IsClassMethod, MContext,
+ !PredInfo, ProcId, !IO) :-
+ % check that the determinism was specified
+ (
+ MaybeDet = no,
+ pred_info_import_status(!.PredInfo, ImportStatus),
+ PredOrFunc = pred_info_is_pred_or_func(!.PredInfo),
+ PredModule = pred_info_module(!.PredInfo),
+ PredName = pred_info_name(!.PredInfo),
+ PredSymName = qualified(PredModule, PredName),
+ ( IsClassMethod = yes ->
+ unspecified_det_for_method(PredSymName, Arity, PredOrFunc,
+ MContext, !IO)
+ ; status_is_exported(ImportStatus, yes) ->
+ unspecified_det_for_exported(PredSymName, Arity, PredOrFunc,
+ MContext, !IO)
+ ;
+ globals__io_lookup_bool_option(infer_det, InferDet, !IO),
+ (
+ InferDet = no,
+ unspecified_det_for_local(PredSymName, Arity, PredOrFunc,
+ MContext, !IO)
+ ;
+ InferDet = yes
+ )
+ )
+ ;
+ MaybeDet = yes(_)
+ ),
+ % Add the mode declaration to the pred_info for this procedure.
+ ArgLives = no,
+ do_add_new_proc(InstVarSet, Arity, Modes, yes(Modes), ArgLives,
+ MaybeDet, MContext, address_is_not_taken, !PredInfo, ProcId).
+
+preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName, Arity,
+ Status, IsClassMethod, Context, Origin, Description, PredId,
+ !ModuleInfo, !IO) :-
+ maybe_undefined_pred_error(PredName, Arity, PredOrFunc, Status,
+ IsClassMethod, Context, Description, !IO),
+ (
+ PredOrFunc = function,
+ adjust_func_arity(function, FuncArity, Arity),
+ maybe_check_field_access_function(PredName, FuncArity, Status, Context,
+ !.ModuleInfo, !IO)
+ ;
+ PredOrFunc = predicate
+ ),
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ preds_add_implicit(!.ModuleInfo, ModuleName, PredName, Arity, Status,
+ Context, Origin, PredOrFunc, PredId, PredicateTable0, PredicateTable),
+ module_info_set_predicate_table(PredicateTable, !ModuleInfo).
+
+:- pred preds_add_implicit(module_info::in, module_name::in, sym_name::in,
+ arity::in, import_status::in, prog_context::in, pred_origin::in,
+ pred_or_func::in, pred_id::out,
+ predicate_table::in, predicate_table::out) is det.
+
+preds_add_implicit(ModuleInfo, ModuleName, PredName, Arity, Status, Context,
+ Origin, PredOrFunc, PredId, !PredicateTable) :-
+ clauses_info_init(Arity, ClausesInfo),
+ preds_add_implicit_2(ClausesInfo, ModuleInfo, ModuleName, PredName,
+ Arity, Status, Context, Origin, PredOrFunc, PredId, !PredicateTable).
+
+preds_add_implicit_for_assertion(HeadVars, ModuleInfo, ModuleName, PredName,
+ Arity, Status, Context, PredOrFunc, PredId, !PredicateTable) :-
+ clauses_info_init_for_assertion(HeadVars, ClausesInfo),
+ term__context_file(Context, FileName),
+ term__context_line(Context, LineNum),
+ preds_add_implicit_2(ClausesInfo, ModuleInfo, ModuleName, PredName,
+ Arity, Status, Context, assertion(FileName, LineNum),
+ PredOrFunc, PredId, !PredicateTable).
+
+:- pred preds_add_implicit_2(clauses_info::in, module_info::in,
+ module_name::in, sym_name::in, arity::in, import_status::in,
+ prog_context::in, pred_origin::in, pred_or_func::in, pred_id::out,
+ predicate_table::in, predicate_table::out) is det.
+
+preds_add_implicit_2(ClausesInfo, ModuleInfo, ModuleName, PredName, Arity,
+ Status, Context, Origin, PredOrFunc, PredId, !PredicateTable) :-
+ varset__init(TVarSet0),
+ make_n_fresh_vars("T", Arity, TypeVars, TVarSet0, TVarSet),
+ term__var_list_to_term_list(TypeVars, Types),
+ map__init(Proofs),
+ map__init(ConstraintMap),
+ % The class context is empty since this is an implicit
+ % definition. Inference will fill it in.
+ ClassContext = constraints([], []),
+ % We assume none of the arguments are existentially typed.
+ % Existential types must be declared, they won't be inferred.
+ ExistQVars = [],
+ init_markers(Markers0),
+ module_info_globals(ModuleInfo, Globals),
+ globals__lookup_string_option(Globals, aditi_user, Owner),
+ pred_info_init(ModuleName, PredName, Arity, PredOrFunc, Context,
+ Origin, Status, none, Markers0, Types, TVarSet, ExistQVars,
+ ClassContext, Proofs, ConstraintMap, Owner, ClausesInfo, PredInfo0),
+ add_marker(infer_type, Markers0, Markers),
+ pred_info_set_markers(Markers, PredInfo0, PredInfo),
+ (
+ \+ predicate_table_search_pf_sym_arity(!.PredicateTable,
+ is_fully_qualified, PredOrFunc, PredName, Arity, _)
+ ->
+ module_info_get_partial_qualifier_info(ModuleInfo, MQInfo),
+ predicate_table_insert(PredInfo, may_be_unqualified, MQInfo, PredId,
+ !PredicateTable)
+ ;
+ error("preds_add_implicit")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred unspecified_det_for_local(sym_name::in, arity::in, pred_or_func::in,
+ prog_context::in, io::di, io::uo) is det.
+
+unspecified_det_for_local(Name, Arity, PredOrFunc, Context, !IO) :-
+ Pieces = [words("Error: no determinism declaration for local"),
+ words(simple_call_id_to_string(PredOrFunc, Name, Arity)),
+ suffix(".")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ record_warning(!IO),
+ globals__io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
+ (
+ VerboseErrors = yes,
+ VerbosePieces = [words("(This is an error because"),
+ words("you specified the `--no-infer-det' options."),
+ words("Use the `--infer-det' option if you want the compiler"),
+ words("to automatically infer the determinism"),
+ words("of local predicates.)")],
+ write_error_pieces(Context, 0, VerbosePieces, !IO)
+ ;
+ VerboseErrors = no
+ ).
+
+:- pred unspecified_det_for_method(sym_name::in, arity::in, pred_or_func::in,
+ prog_context::in, io::di, io::uo) is det.
+
+unspecified_det_for_method(Name, Arity, PredOrFunc, Context, !IO) :-
+ Pieces = [words("Error: no determinism declaration"),
+ words("for type class method"),
+ pred_or_func(PredOrFunc),
+ sym_name_and_arity(Name / Arity),
+ suffix(".")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- pred unspecified_det_for_exported(sym_name::in, arity::in, pred_or_func::in,
+ prog_context::in, io::di, io::uo) is det.
+
+unspecified_det_for_exported(Name, Arity, PredOrFunc, Context, !IO) :-
+ Pieces = [words("Error: no determinism declaration for exported"),
+ pred_or_func(PredOrFunc),
+ sym_name_and_arity(Name / Arity),
+ suffix(".")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- pred unqualified_pred_error(sym_name::in, int::in, prog_context::in,
+ io::di, io::uo) is det.
+
+unqualified_pred_error(PredName, Arity, Context, !IO) :-
+ Pieces = [words("Internal error: the unqualified predicate name"),
+ sym_name_and_arity(PredName / Arity),
+ words("should have been qualified by prog_io.m.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+%-----------------------------------------------------------------------------%
Index: compiler/add_solver.m
===================================================================
RCS file: compiler/add_solver.m
diff -N compiler/add_solver.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_solver.m 21 Jul 2005 13:35:33 -0000
@@ -0,0 +1,266 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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 hlds__make_hlds__add_solver.
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module io.
+:- import_module list.
+
+ % A solver type t defined with
+ %
+ % :- solver type st
+ % where representation is rt, % type
+ % initialisation is ip, % pred
+ % ground is gi, % inst
+ % any is ai, ... % inst
+ %
+ % causes the following to be introduced:
+ %
+ % :- impure func 'representation of ground st'(st::in) =
+ % (rt::out(gi)) is det.
+ % :- impure func 'representation of any st'(st::in(any)) =
+ % (rt::out(ai)) is det.
+ %
+ % :- impure func 'representation to ground st'(rt::in(gi)) =
+ % (st::out) is det.
+ % :- impure func 'representation to any st'(rt::in(ai)) =
+ % (st::out(any)) is det.
+ %
+:- pred add_solver_type_decl_items(tvarset::in, sym_name::in,
+ list(type_param)::in, solver_type_details::in, prog_context::in,
+ item_status::in, item_status::out, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+:- pred add_solver_type_clause_items(sym_name::in, list(type_param)::in,
+ solver_type_details::in, import_status::in, import_status::out,
+ prog_context::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module hlds__make_hlds__add_pred.
+:- import_module libs__globals.
+:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_util.
+
+:- import_module bool.
+:- import_module require.
+:- import_module string.
+:- import_module std_util.
+:- import_module varset.
+
+add_solver_type_decl_items(TVarSet, TypeSymName, TypeParams,
+ SolverTypeDetails, Context, !Status, !ModuleInfo, !IO) :-
+
+ SolverType = sym_name_and_args_to_term(TypeSymName, TypeParams,
+ Context),
+ Arity = length(TypeParams),
+
+ RepnType = SolverTypeDetails ^ representation_type,
+ AnyInst = SolverTypeDetails ^ any_inst,
+ GroundInst = SolverTypeDetails ^ ground_inst,
+
+ InAnyMode = in_mode(AnyInst),
+ InGroundMode = in_mode(GroundInst),
+
+ OutAnyMode = out_mode(AnyInst),
+ OutGroundMode = out_mode(GroundInst),
+
+ InstVarSet = varset__init,
+ ExistQTVars = [],
+
+ init_markers(NoMarkers),
+
+ % Insert the conversion function declarations.
+
+ % The `:- impure
+ % func 'representation of ground st'(st::in(gi)) =
+ % (rt::out) is det' declaration.
+ %
+ ToGroundRepnSymName = solver_to_ground_repn_symname(TypeSymName, Arity),
+ ToGroundRepnArgTypes =
+ [type_and_mode(SolverType, in_mode ),
+ type_and_mode(RepnType, OutGroundMode)],
+ module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
+ ToGroundRepnSymName, ToGroundRepnArgTypes, yes(det),
+ (impure), constraints([], []), NoMarkers, Context, !.Status, _,
+ !ModuleInfo, !IO),
+
+ % The `:- impure
+ % func 'representation of any st'(st::in(ai)) =
+ % (rt::out(any)) is det' declaration.
+ %
+ ToAnyRepnSymName = solver_to_any_repn_symname(TypeSymName, Arity),
+ ToAnyRepnArgTypes =
+ [type_and_mode(SolverType, in_any_mode ),
+ type_and_mode(RepnType, OutAnyMode)],
+ module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
+ ToAnyRepnSymName, ToAnyRepnArgTypes, yes(det),
+ (impure), constraints([], []), NoMarkers, Context, !.Status, _,
+ !ModuleInfo, !IO),
+
+ % The `:- impure
+ % func 'representation to ground st'(rt::in(gi)) =
+ % (st::out) is det' declaration.
+ %
+ FromGroundRepnSymName = repn_to_ground_solver_symname(TypeSymName, Arity),
+ FromGroundRepnArgTypes =
+ [type_and_mode(RepnType, InGroundMode ),
+ type_and_mode(SolverType, out_mode )],
+ module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
+ FromGroundRepnSymName, FromGroundRepnArgTypes, yes(det),
+ (impure), constraints([], []), NoMarkers, Context, !.Status, _,
+ !ModuleInfo, !IO),
+
+ % The `:- impure
+ % func 'representation to any st'(rt::in(ai)) =
+ % (st::out(any)) is det' declaration.
+ %
+ FromAnyRepnSymName = repn_to_any_solver_symname(TypeSymName, Arity),
+ FromAnyRepnArgTypes =
+ [type_and_mode(RepnType, InAnyMode ),
+ type_and_mode(SolverType, out_any_mode)],
+ module_add_pred_or_func(TVarSet, InstVarSet, ExistQTVars, function,
+ FromAnyRepnSymName, FromAnyRepnArgTypes, yes(det),
+ (impure), constraints([], []), NoMarkers, Context, !.Status, _,
+ !ModuleInfo, !IO).
+
+%-----------------------------------------------------------------------------%
+
+ % Obtain the solver type conversion function sym_names from
+ % the solver type sym_name.
+ %
+:- func solver_to_ground_repn_symname(sym_name, arity) = sym_name.
+solver_to_ground_repn_symname(SymName, Arity) =
+ solver_conversion_fn_symname("representation of ground ", SymName, Arity).
+
+:- func solver_to_any_repn_symname(sym_name, arity) = sym_name.
+solver_to_any_repn_symname(SymName, Arity) =
+ solver_conversion_fn_symname("representation of any ", SymName, Arity).
+
+:- func repn_to_ground_solver_symname(sym_name, arity) = sym_name.
+repn_to_ground_solver_symname(SymName, Arity) =
+ solver_conversion_fn_symname("representation to ground ", SymName, Arity).
+
+:- func repn_to_any_solver_symname(sym_name, arity) = sym_name.
+repn_to_any_solver_symname(SymName, Arity) =
+ solver_conversion_fn_symname("representation to any ", SymName, Arity).
+
+:- func solver_conversion_fn_symname(string, sym_name, arity) = sym_name.
+solver_conversion_fn_symname(Prefix, unqualified(Name), Arity) =
+ unqualified(Prefix ++ Name ++ "/" ++ int_to_string(Arity)).
+solver_conversion_fn_symname(Prefix, qualified(ModuleNames, Name), Arity) =
+ qualified(ModuleNames, Prefix ++ Name ++ "/" ++ int_to_string(Arity)).
+
+add_solver_type_clause_items(TypeSymName, TypeParams, SolverTypeDetails,
+ !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Arity = length(TypeParams),
+
+ AnyInst = SolverTypeDetails ^ any_inst,
+ GroundInst = SolverTypeDetails ^ ground_inst,
+
+ InAnyMode = in_mode(AnyInst),
+ InGroundMode = in_mode(GroundInst),
+
+ OutAnyMode = out_mode(AnyInst),
+ OutGroundMode = out_mode(GroundInst),
+
+ VarSet0 = varset__init,
+ varset__new_var(VarSet0, X, VarSet1),
+ varset__new_var(VarSet1, Y, VarSet),
+
+ Attrs0 = default_attributes(c),
+ some [!Attrs] (
+ !:Attrs = Attrs0,
+ set_may_call_mercury(will_not_call_mercury, !Attrs),
+ set_thread_safe(thread_safe, !Attrs),
+ set_terminates(terminates, !Attrs),
+ Attrs = !.Attrs
+ ),
+
+ Impl = ordinary("Y = X;", yes(Context)),
+
+ % The `func(in) = out(<i_ground>) is det' mode.
+ %
+ ToGroundRepnSymName = solver_to_ground_repn_symname(TypeSymName, Arity),
+ ToGroundRepnArgs = [ pragma_var(X, "X", in_mode ),
+ pragma_var(Y, "Y", OutGroundMode) ],
+ ToGroundRepnForeignProc =
+ foreign_proc(
+ Attrs,
+ ToGroundRepnSymName,
+ function,
+ ToGroundRepnArgs,
+ VarSet,
+ Impl
+ ),
+ ToGroundRepnItem = pragma(ToGroundRepnForeignProc),
+ add_item_clause(ToGroundRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO),
+
+ % The `func(in(any)) = out(<i_any>) is det' mode.
+ %
+ ToAnyRepnSymName = solver_to_any_repn_symname(TypeSymName, Arity),
+ ToAnyRepnArgs = [ pragma_var(X, "X", in_any_mode),
+ pragma_var(Y, "Y", OutAnyMode ) ],
+ ToAnyRepnForeignProc =
+ foreign_proc(
+ Attrs,
+ ToAnyRepnSymName,
+ function,
+ ToAnyRepnArgs,
+ VarSet,
+ Impl
+ ),
+ ToAnyRepnItem = pragma(ToAnyRepnForeignProc),
+ add_item_clause(ToAnyRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO),
+
+ % The `func(in(<i_ground>)) = out is det' mode.
+ %
+ FromGroundRepnSymName = repn_to_ground_solver_symname(TypeSymName, Arity),
+ FromGroundRepnArgs = [ pragma_var(X, "X", InGroundMode),
+ pragma_var(Y, "Y", out_mode) ],
+ FromGroundRepnForeignProc =
+ foreign_proc(
+ Attrs,
+ FromGroundRepnSymName,
+ function,
+ FromGroundRepnArgs,
+ VarSet,
+ Impl
+ ),
+ FromGroundRepnItem = pragma(FromGroundRepnForeignProc),
+ add_item_clause(FromGroundRepnItem, !Status, Context, !ModuleInfo,
+ !QualInfo, !IO),
+
+ % The `func(in(<i_any>)) = out(any) is det' mode.
+ %
+ FromAnyRepnSymName = repn_to_any_solver_symname(TypeSymName, Arity),
+ FromAnyRepnArgs = [ pragma_var(X, "X", InAnyMode ),
+ pragma_var(Y, "Y", out_any_mode) ],
+ FromAnyRepnForeignProc =
+ foreign_proc(
+ Attrs,
+ FromAnyRepnSymName,
+ function,
+ FromAnyRepnArgs,
+ VarSet,
+ Impl
+ ),
+ FromAnyRepnItem = pragma(FromAnyRepnForeignProc),
+ add_item_clause(FromAnyRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
+ !IO).
Index: compiler/add_special_pred.m
===================================================================
RCS file: compiler/add_special_pred.m
diff -N compiler/add_special_pred.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_special_pred.m 25 Jul 2005 08:41:05 -0000
@@ -0,0 +1,423 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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.
+%-----------------------------------------------------------------------------%
+%
+% This submodule of make_hlds handles the creation of unify, compare and
+% (if needed) index and init predicates for the types defined or imported
+% by the module being compiled.
+
+:- module hlds__make_hlds__add_special_pred.
+:- interface.
+
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+ % do_add_special_pred_for_real(SpecialPredId, TVarSet, Type, TypeCtor,
+ % TypeBody, TypeContext, TypeStatus, !ModuleInfo).
+ %
+ % Add declarations and clauses for a special predicate.
+ % This is used by unify_proc.m to add a unification predicate
+ % for an imported type for which special predicates are being
+ % generated only when a unification procedure is requested
+ % during mode analysis.
+ %
+:- pred do_add_special_pred_for_real(special_pred_id::in, tvarset::in,
+ (type)::in, type_ctor::in, hlds_type_body::in, prog_context::in,
+ import_status::in, module_info::in, module_info::out) is det.
+
+ % do_add_special_pred_decl_for_real(SpecialPredId, TVarSet,
+ % Type, TypeCtor, TypeContext, TypeStatus, !ModuleInfo).
+ %
+ % Add declarations for a special predicate.
+ % This is used by higher_order.m when specializing an in-in
+ % unification for an imported type for which unification procedures
+ % are generated lazily.
+ %
+:- pred do_add_special_pred_decl_for_real(special_pred_id::in,
+ tvarset::in, (type)::in, type_ctor::in, prog_context::in,
+ import_status::in, module_info::in, module_info::out) is det.
+
+:- pred add_special_preds(tvarset::in, (type)::in, type_ctor::in,
+ hlds_type_body::in, prog_context::in, import_status::in,
+ module_info::in, module_info::out) is det.
+
+:- implementation.
+
+:- import_module check_hlds__type_util.
+:- import_module check_hlds__unify_proc.
+:- import_module hlds__make_hlds__add_pred.
+:- import_module hlds__special_pred.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__prog_type.
+:- import_module parse_tree__prog_util.
+
+:- import_module bool.
+:- import_module int.
+:- import_module list.
+:- import_module map.
+:- import_module require.
+:- import_module std_util.
+:- import_module string.
+:- import_module varset.
+
+ % The only place that the index predicate for a type can ever
+ % be called from is the compare predicate for that type.
+ % The only types whose compare predicates call the type's index
+ % predicate are discriminated union types which
+ %
+ % - do not have user-defined equality (any compiler-generated compare
+ % predicates for types with user-defined equality generate a runtime
+ % abort),
+ %
+ % - are not enums (comparison predicates for enums just do an integer
+ % comparison), and
+ %
+ % - have more than one constructor (for types with only one
+ % constructor, the comparison predicate just deconstructs the
+ % arguments and compares them).
+ %
+ % The compare predicate for an equivalence type never calls the index
+ % predicate for that type; it calls the compare predicate of the
+ % expanded type instead.
+ %
+ % When we see an abstract type declaration, we do not declare an index
+ % predicate for that type, since the actual type definition may later
+ % turn out not to require one. If the type does turn out to need
+ % an index predicate, its declaration will be generated together with
+ % its implementation.
+ %
+ % We also do not declare index predicates for types with hand defined
+ % RTTI, since such types do not have index predicates.
+ %
+ % What we do here for uu types does not matter much, since such types
+ % are not yet supported.
+ %
+ % Note: this predicate should include index in the list of special
+ % predicates to be defined only for the kinds of types which do not
+ % lead unify_proc__generate_index_clauses to abort.
+ %
+add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
+ !ModuleInfo) :-
+ (
+ special_pred_is_generated_lazily(!.ModuleInfo, TypeCtor, Body, Status)
+ ->
+ true
+ ;
+ can_generate_special_pred_clauses_for_type(!.ModuleInfo, TypeCtor,
+ Body)
+ ->
+ add_special_pred(unify, TVarSet, Type, TypeCtor, Body, Context,
+ Status, !ModuleInfo),
+ status_defined_in_this_module(Status, ThisModule),
+ (
+ ThisModule = yes,
+ (
+ Ctors = Body ^ du_type_ctors,
+ Body ^ du_type_is_enum = no,
+ Body ^ du_type_usereq = no,
+ module_info_globals(!.ModuleInfo, Globals),
+ globals__lookup_int_option(Globals, compare_specialization,
+ CompareSpec),
+ list__length(Ctors, CtorCount),
+ CtorCount > CompareSpec
+ ->
+ SpecialPredIds = [index, compare]
+ ;
+ SpecialPredIds = [compare]
+ ),
+ add_special_pred_list(SpecialPredIds, TVarSet, Type, TypeCtor,
+ Body, Context, Status, !ModuleInfo)
+ ;
+ ThisModule = no,
+ % Never add clauses for comparison predicates
+ % for imported types -- they will never be used.
+ module_info_get_special_pred_map(!.ModuleInfo, SpecialPreds),
+ ( map__contains(SpecialPreds, compare - TypeCtor) ->
+ true
+ ;
+ add_special_pred_decl(compare, TVarSet, Type, TypeCtor, Body,
+ Context, Status, !ModuleInfo)
+ )
+ ),
+ (
+ type_util__type_body_is_solver_type(!.ModuleInfo, Body)
+ ->
+ add_special_pred(initialise, TVarSet, Type, TypeCtor, Body,
+ Context, Status, !ModuleInfo)
+ ;
+ true
+ )
+ ;
+ ( type_util__type_body_is_solver_type(!.ModuleInfo, Body) ->
+ SpecialPredIds = [unify, compare, initialise]
+ ;
+ SpecialPredIds = [unify, compare]
+ ),
+ add_special_pred_decl_list(SpecialPredIds, TVarSet, Type,
+ TypeCtor, Body, Context, Status, !ModuleInfo)
+ ).
+
+:- pred add_special_pred_list(list(special_pred_id)::in, tvarset::in,
+ (type)::in, type_ctor::in, hlds_type_body::in, prog_context::in,
+ import_status::in, module_info::in, module_info::out) is det.
+
+add_special_pred_list([], _, _, _, _, _, _, !ModuleInfo).
+add_special_pred_list([SpecialPredId | SpecialPredIds], TVarSet, Type,
+ TypeCtor, Body, Context, Status, !ModuleInfo) :-
+ add_special_pred(SpecialPredId, TVarSet, Type,
+ TypeCtor, Body, Context, Status, !ModuleInfo),
+ add_special_pred_list(SpecialPredIds, TVarSet, Type,
+ TypeCtor, Body, Context, Status, !ModuleInfo).
+
+:- pred add_special_pred(special_pred_id::in, tvarset::in, (type)::in,
+ type_ctor::in, hlds_type_body::in, prog_context::in, import_status::in,
+ module_info::in, module_info::out) is det.
+
+add_special_pred(SpecialPredId, TVarSet, Type, TypeCtor, TypeBody, Context,
+ Status0, !ModuleInfo) :-
+ module_info_globals(!.ModuleInfo, Globals),
+ globals__lookup_bool_option(Globals, special_preds, GenSpecialPreds),
+ (
+ GenSpecialPreds = yes,
+ do_add_special_pred_for_real(SpecialPredId, TVarSet,
+ Type, TypeCtor, TypeBody, Context, Status0, !ModuleInfo)
+ ;
+ GenSpecialPreds = no,
+ (
+ SpecialPredId = unify,
+ add_special_pred_unify_status(TypeBody, Status0, Status),
+ do_add_special_pred_for_real(SpecialPredId, TVarSet,
+ Type, TypeCtor, TypeBody, Context, Status, !ModuleInfo)
+ ;
+ SpecialPredId = index
+ ;
+ SpecialPredId = compare,
+ ( TypeBody ^ du_type_usereq = yes(_) ->
+ % The compiler generated comparison
+ % procedure prints an error message,
+ % since comparisons of types with
+ % user-defined equality are not
+ % allowed. We get the runtime system
+ % invoke this procedure instead of
+ % printing the error message itself,
+ % because it is easier to generate
+ % a good error message in Mercury code
+ % than in C code.
+ do_add_special_pred_for_real(SpecialPredId, TVarSet, Type,
+ TypeCtor, TypeBody, Context, Status0, !ModuleInfo)
+ ;
+ true
+ )
+ ;
+ SpecialPredId = initialise,
+ ( type_is_solver_type(!.ModuleInfo, Type) ->
+ do_add_special_pred_for_real(SpecialPredId, TVarSet, Type,
+ TypeCtor, TypeBody, Context, Status0, !ModuleInfo)
+ ;
+ error("make_hlds.add_special_pred: " ++
+ "attempt to add initialise pred for non-solver type")
+ )
+ )
+ ).
+
+do_add_special_pred_for_real(SpecialPredId, TVarSet, Type0, TypeCtor,
+ TypeBody, Context, Status0, !ModuleInfo) :-
+ Type = adjust_types_with_special_preds_in_private_builtin(Type0),
+ adjust_special_pred_status(SpecialPredId, Status0, Status),
+ module_info_get_special_pred_map(!.ModuleInfo, SpecialPredMap0),
+ ( map__contains(SpecialPredMap0, SpecialPredId - TypeCtor) ->
+ true
+ ;
+ do_add_special_pred_decl_for_real(SpecialPredId, TVarSet,
+ Type, TypeCtor, Context, Status, !ModuleInfo)
+ ),
+ module_info_get_special_pred_map(!.ModuleInfo, SpecialPredMap1),
+ map__lookup(SpecialPredMap1, SpecialPredId - TypeCtor, PredId),
+ module_info_preds(!.ModuleInfo, Preds0),
+ map__lookup(Preds0, PredId, PredInfo0),
+ % if the type was imported, then the special preds for that
+ % type should be imported too
+ (
+ ( Status = imported(_)
+ ; Status = pseudo_imported
+ )
+ ->
+ pred_info_set_import_status(Status, PredInfo0, PredInfo1)
+ ;
+ TypeBody ^ du_type_usereq = yes(_),
+ pred_info_import_status(PredInfo0, OldStatus),
+ OldStatus = pseudo_imported,
+ status_is_imported(Status, no)
+ ->
+ % We can only get here with --no-special-preds if the old
+ % status is from an abstract declaration of the type.
+ % Since the compiler did not then know that the type definition
+ % will specify a user-defined equality predicate, it set up
+ % the status as pseudo_imported in order to prevent the
+ % generation of code for mode 0 of the unify predicate
+ % for the type. However, for types with user-defined equality,
+ % we *do* want to generate code for mode 0 of unify,
+ % so we fix the status.
+ pred_info_set_import_status(Status, PredInfo0, PredInfo1)
+ ;
+ PredInfo1 = PredInfo0
+ ),
+ unify_proc__generate_clause_info(SpecialPredId, Type, TypeBody,
+ Context, !.ModuleInfo, ClausesInfo),
+ pred_info_set_clauses_info(ClausesInfo, PredInfo1, PredInfo2),
+ pred_info_get_markers(PredInfo2, Markers2),
+ add_marker(calls_are_fully_qualified, Markers2, Markers),
+ pred_info_set_markers(Markers, PredInfo2, PredInfo3),
+ pred_info_set_origin(special_pred(SpecialPredId - TypeCtor),
+ PredInfo3, PredInfo),
+ map__det_update(Preds0, PredId, PredInfo, Preds),
+ module_info_set_preds(Preds, !ModuleInfo).
+
+ % These types need to have the builtin qualifier removed
+ % so that their special predicates type check.
+ %
+:- func adjust_types_with_special_preds_in_private_builtin(type) = (type).
+
+adjust_types_with_special_preds_in_private_builtin(Type) = NormalizedType :-
+ ( type_to_ctor_and_args(Type, TypeCtor, []) ->
+ ( is_builtin_types_special_preds_defined_in_mercury(TypeCtor, Name) ->
+ construct_type(unqualified(Name) - 0, [], NormalizedType)
+ ;
+ NormalizedType = Type
+ )
+ ;
+ NormalizedType = Type
+ ).
+
+:- pred add_special_pred_decl_list(list(special_pred_id)::in, tvarset::in,
+ (type)::in, type_ctor::in, hlds_type_body::in, prog_context::in,
+ import_status::in, module_info::in, module_info::out) is det.
+
+add_special_pred_decl_list([], _, _, _, _, _, _, !ModuleInfo).
+add_special_pred_decl_list([SpecialPredId | SpecialPredIds], TVarSet, Type,
+ TypeCtor, TypeBody, Context, Status, !ModuleInfo) :-
+ add_special_pred_decl(SpecialPredId, TVarSet, Type,
+ TypeCtor, TypeBody, Context, Status, !ModuleInfo),
+ add_special_pred_decl_list(SpecialPredIds, TVarSet, Type,
+ TypeCtor, TypeBody, Context, Status, !ModuleInfo).
+
+:- pred add_special_pred_decl(special_pred_id::in, tvarset::in, (type)::in,
+ type_ctor::in, hlds_type_body::in, prog_context::in, import_status::in,
+ module_info::in, module_info::out) is det.
+
+add_special_pred_decl(SpecialPredId, TVarSet, Type, TypeCtor, TypeBody,
+ Context, Status0, !ModuleInfo) :-
+ module_info_globals(!.ModuleInfo, Globals),
+ globals__lookup_bool_option(Globals, special_preds, GenSpecialPreds),
+ ( GenSpecialPreds = yes ->
+ do_add_special_pred_decl_for_real(SpecialPredId,
+ TVarSet, Type, TypeCtor, Context, Status0, !ModuleInfo)
+ ; SpecialPredId = unify ->
+ add_special_pred_unify_status(TypeBody, Status0, Status),
+ do_add_special_pred_decl_for_real(SpecialPredId, TVarSet,
+ Type, TypeCtor, Context, Status, !ModuleInfo)
+ ;
+ true
+ ).
+
+do_add_special_pred_decl_for_real(SpecialPredId, TVarSet, Type, TypeCtor,
+ Context, Status0, !ModuleInfo) :-
+ module_info_name(!.ModuleInfo, ModuleName),
+ special_pred_interface(SpecialPredId, Type, ArgTypes, ArgModes, Det),
+ Name = special_pred_name(SpecialPredId, TypeCtor),
+ ( SpecialPredId = initialise ->
+ TypeCtor = TypeSymName - _TypeArity,
+ sym_name_get_module_name(TypeSymName, ModuleName, TypeModuleName),
+ PredName = qualified(TypeModuleName, Name)
+ ;
+ PredName = unqualified(Name)
+ ),
+ special_pred_name_arity(SpecialPredId, _, Arity),
+ clauses_info_init(Arity, ClausesInfo0),
+ Origin = special_pred(SpecialPredId - TypeCtor),
+ adjust_special_pred_status(SpecialPredId, Status0, Status),
+ map__init(Proofs),
+ map__init(ConstraintMap),
+ init_markers(Markers),
+ % XXX If/when we have "comparable" or "unifiable" typeclasses,
+ % XXX this context might not be empty
+ ClassContext = constraints([], []),
+ ExistQVars = [],
+ module_info_globals(!.ModuleInfo, Globals),
+ globals__lookup_string_option(Globals, aditi_user, Owner),
+ pred_info_init(ModuleName, PredName, Arity, predicate, Context,
+ Origin, Status, none, Markers, ArgTypes, TVarSet, ExistQVars,
+ ClassContext, Proofs, ConstraintMap, Owner, ClausesInfo0, PredInfo0),
+ ArgLives = no,
+ varset__init(InstVarSet),
+ % Should not be any inst vars here so it's ok to use a
+ % fresh inst_varset.
+ do_add_new_proc(InstVarSet, Arity, ArgModes, yes(ArgModes), ArgLives,
+ yes(Det), Context, address_is_not_taken, PredInfo0, PredInfo, _),
+
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ predicate_table_insert(PredInfo, PredId, PredicateTable0, PredicateTable),
+ module_info_set_predicate_table(PredicateTable, !ModuleInfo),
+ module_info_get_special_pred_map(!.ModuleInfo, SpecialPredMap0),
+ map__set(SpecialPredMap0, SpecialPredId - TypeCtor, PredId,
+ SpecialPredMap),
+ module_info_set_special_pred_map(SpecialPredMap, !ModuleInfo).
+
+:- pred add_special_pred_unify_status(hlds_type_body::in, import_status::in,
+ import_status::out) is det.
+
+add_special_pred_unify_status(TypeBody, Status0, Status) :-
+ ( TypeBody ^ du_type_usereq = yes(_) ->
+ % If the type has user-defined equality,
+ % then we create a real unify predicate
+ % for it, whose body calls the user-specified
+ % predicate. The compiler's usual type checking
+ % algorithm will handle any necessary
+ % disambiguation from predicates with the same
+ % name but different argument types, and the
+ % usual mode checking algorithm will select
+ % the right mode of the chosen predicate.
+ Status = Status0
+ ;
+ Status = pseudo_imported
+ ).
+
+:- pred adjust_special_pred_status(special_pred_id::in,
+ import_status::in, import_status::out) is det.
+
+adjust_special_pred_status(SpecialPredId, !Status) :-
+ (
+ ( !.Status = opt_imported
+ ; !.Status = abstract_imported
+ )
+ ->
+ !:Status = imported(interface)
+ ;
+ !.Status = abstract_exported
+ ->
+ !:Status = exported
+ ;
+ true
+ ),
+
+ % Unification predicates are special - they are
+ % "pseudo"-imported/exported (only mode 0 is imported/exported).
+ ( SpecialPredId = unify ->
+ ( !.Status = imported(_) ->
+ !:Status = pseudo_imported
+ ; !.Status = exported ->
+ !:Status = pseudo_exported
+ ;
+ true
+ )
+ ;
+ true
+ ).
Index: compiler/add_type.m
===================================================================
RCS file: compiler/add_type.m
diff -N compiler/add_type.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/add_type.m 25 Jul 2005 08:20:08 -0000
@@ -0,0 +1,796 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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.
+%-----------------------------------------------------------------------------%
+%
+% This submodule of make_hlds handles the declarations of new types.
+
+:- module hlds__make_hlds__add_type.
+:- interface.
+
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__hlds_module.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module bool.
+:- import_module io.
+:- import_module list.
+
+ % We allow more than one "definition" for a given type so
+ % long all of them except one are actually just declarations,
+ % e.g. `:- type t.', which is parsed as an type definition for
+ % t which defines t as an abstract_type.
+ %
+:- pred module_add_type_defn(tvarset::in, sym_name::in, list(type_param)::in,
+ type_defn::in, condition::in, prog_context::in, item_status::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+ % Add the constructors and special preds for a type to the HLDS.
+ %
+:- pred process_type_defn(type_ctor::in, hlds_type_defn::in,
+ bool::in, bool::out, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+:- pred make_status_abstract(import_status::in, import_status::out) is det.
+
+:- pred combine_status(import_status::in, import_status::in,
+ import_status::out) is det.
+
+:- implementation.
+
+:- import_module backend_libs.
+:- import_module backend_libs__foreign.
+:- import_module check_hlds__type_util.
+:- import_module hlds__make_hlds__add_special_pred.
+:- import_module hlds__make_hlds__make_hlds_error.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module hlds__make_tags.
+:- import_module hlds__hlds_code_util.
+:- import_module hlds__hlds_out.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__module_qual.
+:- import_module parse_tree__prog_type.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_util.
+
+:- import_module assoc_list.
+:- import_module int.
+:- import_module map.
+:- import_module multi_map.
+:- import_module require.
+:- import_module std_util.
+:- import_module string.
+:- import_module term.
+
+module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
+ item_status(Status0, NeedQual), !ModuleInfo, !IO) :-
+ globals__io_get_globals(Globals, !IO),
+ list__length(Args, Arity),
+ TypeCtor = Name - Arity,
+ convert_type_defn(TypeDefn, TypeCtor, Globals, Body0),
+ module_info_types(!.ModuleInfo, Types0),
+ (
+ (
+ Body0 = abstract_type(_)
+ ;
+ Body0 = du_type(_, _, _, _, _, _),
+ string__suffix(term__context_file(Context), ".int2")
+ % If the type definition comes from a .int2 file then
+ % we need to treat it as abstract. The constructors
+ % may only be used by the mode system for comparing
+ % `bound' insts to `ground'.
+ )
+ ->
+ make_status_abstract(Status0, Status1)
+ ;
+ Status1 = Status0
+ ),
+ (
+ % the type is exported if *any* occurrence is exported,
+ % even a previous abstract occurrence
+ map__search(Types0, TypeCtor, OldDefn0)
+ ->
+ hlds_data__get_type_defn_status(OldDefn0, OldStatus),
+ combine_status(Status1, OldStatus, Status),
+ hlds_data__get_type_defn_body(OldDefn0, OldBody0),
+ combine_is_solver_type(OldBody0, OldBody, Body0, Body),
+ ( is_solver_type_is_inconsistent(OldBody, Body) ->
+ % The existing definition has an is_solver_type
+ % annotation which is different to the current
+ % definition.
+ module_info_incr_errors(!ModuleInfo),
+ Pieces0 = [words("In definition of type"),
+ fixed(describe_sym_name_and_arity(Name / Arity) ++ ":"), nl,
+ words("error: all definitions of a type must"),
+ words("have consistent `solver'"),
+ words("annotations")],
+ error_util__write_error_pieces(Context, 0, Pieces0,
+ !IO),
+ MaybeOldDefn = no
+ ;
+ hlds_data__set_type_defn_body(OldBody, OldDefn0, OldDefn),
+ MaybeOldDefn = yes(OldDefn)
+ )
+ ;
+ MaybeOldDefn = no,
+ Status = Status1,
+ Body = Body0
+ ),
+ hlds_data__set_type_defn(TVarSet, Args, Body, Status, no, NeedQual,
+ Context, T),
+ (
+ MaybeOldDefn = no,
+ Body = foreign_type(_)
+ ->
+ TypeStr = error_util__describe_sym_name_and_arity(Name / Arity),
+ ErrorPieces = [
+ words("Error: type "),
+ fixed(TypeStr),
+ words("defined as foreign_type without being declared.")
+ ],
+ error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ MaybeOldDefn = yes(OldDefn1),
+ Body = foreign_type(_),
+ hlds_data__get_type_defn_status(OldDefn1, OldStatus1),
+ hlds_data__get_type_defn_body(OldDefn1, OldBody1),
+ OldBody1 = abstract_type(_),
+ status_is_exported_to_non_submodules(OldStatus1, no),
+ status_is_exported_to_non_submodules(Status0, yes)
+ ->
+ TypeStr = error_util__describe_sym_name_and_arity(Name / Arity),
+ ErrorPieces = [
+ words("Error: pragma foreign_type "),
+ fixed(TypeStr),
+ words("must have the same visibility as the type declaration.")
+ ],
+ error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ % if there was an existing non-abstract definition for the type
+ MaybeOldDefn = yes(T2),
+ hlds_data__get_type_defn_tvarset(T2, TVarSet_2),
+ hlds_data__get_type_defn_tparams(T2, Params_2),
+ hlds_data__get_type_defn_body(T2, Body_2),
+ hlds_data__get_type_defn_context(T2, OrigContext),
+ hlds_data__get_type_defn_status(T2, OrigStatus),
+ hlds_data__get_type_defn_in_exported_eqv(T2, OrigInExportedEqv),
+ hlds_data__get_type_defn_need_qualifier(T2, OrigNeedQual),
+ Body_2 \= abstract_type(_)
+ ->
+ globals__io_get_target(Target, !IO),
+ globals__io_lookup_bool_option(make_optimization_interface,
+ MakeOptInt, !IO),
+ ( Body = foreign_type(_) ->
+ module_info_contains_foreign_type(!ModuleInfo)
+ ;
+ true
+ ),
+ (
+ % then if this definition was abstract, ignore it
+ % (but update the status of the old defn if necessary)
+ Body = abstract_type(_)
+ ->
+ ( Status = OrigStatus ->
+ true
+ ;
+ hlds_data__set_type_defn(TVarSet_2, Params_2, Body_2, Status,
+ OrigInExportedEqv, OrigNeedQual, OrigContext, T3),
+ map__det_update(Types0, TypeCtor, T3, Types),
+ module_info_set_types(Types, !ModuleInfo)
+ )
+ ;
+ merge_foreign_type_bodies(Target, MakeOptInt, Body, Body_2,
+ NewBody)
+ ->
+ ( check_foreign_type_visibility(OrigStatus, Status1) ->
+ hlds_data__set_type_defn(TVarSet_2, Params_2, NewBody, Status,
+ OrigInExportedEqv, NeedQual, Context, T3),
+ map__det_update(Types0, TypeCtor, T3, Types),
+ module_info_set_types(Types, !ModuleInfo)
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ Pieces = [words("In definition of type"),
+ fixed(describe_sym_name_and_arity(Name / Arity) ++ ":"),
+ nl,
+ words("error: all definitions of a"),
+ words("type must have the same"),
+ words("visibility")],
+ error_util__write_error_pieces(Context, 0,
+ Pieces, !IO)
+ )
+ ;
+ % otherwise issue an error message if the second
+ % definition wasn't read while reading .opt files.
+ Status = opt_imported
+ ->
+ true
+ ;
+ module_info_incr_errors(!ModuleInfo),
+ multiple_def_error(Status, Name, Arity, "type", Context,
+ OrigContext, _, !IO)
+ )
+ ;
+ map__set(Types0, TypeCtor, T, Types),
+ module_info_set_types(Types, !ModuleInfo),
+ (
+ % XXX we can't handle abstract exported
+ % polymorphic equivalence types with monomorphic
+ % bodies, because the compiler stuffs up the
+ % type_info handling -- the caller passes type_infos,
+ % but the callee expects no type_infos
+ Body = eqv_type(EqvType),
+ Status = abstract_exported,
+ term__contains_var_list(Args, Var),
+ \+ term__contains_var(EqvType, Var)
+ ->
+ Pieces = [words("Sorry, not implemented:"),
+ words("polymorphic equivalence type,"),
+ words("with monomorphic definition,"),
+ words("exported as abstract type.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ globals__io_lookup_bool_option(verbose_errors,
+ VerboseErrors, !IO),
+ (
+ VerboseErrors = yes,
+ write_error_pieces(Context, 0, abstract_monotype_workaround,
+ !IO)
+ ;
+ VerboseErrors = no
+ ),
+ io__set_exit_status(1, !IO)
+ ;
+ true
+ )
+ ).
+
+:- func abstract_monotype_workaround = list(format_component).
+
+abstract_monotype_workaround = [
+ words("A quick work-around is to just export the type as a concrete,"),
+ words("type by putting the type definition in the interface section."),
+ words("A better work-around is to use a ""wrapper"" type, with just one"),
+ words("functor that has just one arg, instead of an equivalence type."),
+ words("(There's no performance penalty for this -- the compiler will"),
+ words("optimize the wrapper away.)")
+ ].
+
+%-----------------------------------------------------------------------------%
+
+ % We do not have syntax for adding `solver' annotations to
+ % `:- pragma foreign_type' declarations, so foreign_type bodies
+ % default to having an is_solver_type field of `non_solver_type'.
+ % If another declaration for the type has a `solver' annotation then
+ % we must update the foreign_type body to reflect this.
+ %
+ % rafe: XXX think it should be an error for foreign types to
+ % be solver types.
+ %
+:- pred combine_is_solver_type(hlds_type_body::in, hlds_type_body::out,
+ hlds_type_body::in, hlds_type_body::out) is det.
+
+combine_is_solver_type(OldBody, OldBody, Body, Body).
+
+ % Succeed iff the two type bodies have inconsistent is_solver_type
+ % annotations.
+:- pred is_solver_type_is_inconsistent(hlds_type_body::in, hlds_type_body::in)
+ is semidet.
+
+is_solver_type_is_inconsistent(OldBody, Body) :-
+ maybe_get_body_is_solver_type(OldBody, OldIsSolverType),
+ maybe_get_body_is_solver_type(Body, IsSolverType),
+ OldIsSolverType \= IsSolverType.
+
+:- pred maybe_get_body_is_solver_type(hlds_type_body::in, is_solver_type::out)
+ is semidet.
+
+maybe_get_body_is_solver_type(abstract_type(IsSolverType), IsSolverType).
+maybe_get_body_is_solver_type(solver_type(_, _), solver_type).
+
+ % check_foreign_type_visibility(OldStatus, NewDefnStatus).
+ %
+ % Check that the visibility of the new definition for
+ % a foreign type matches that of previous definitions.
+ %
+:- pred check_foreign_type_visibility(import_status::in,
+ import_status::in) is semidet.
+
+check_foreign_type_visibility(OldStatus, NewDefnStatus) :-
+ ( OldStatus = abstract_exported ->
+ % If OldStatus is abstract_exported, the previous
+ % definitions were local.
+ status_is_exported_to_non_submodules(NewDefnStatus, no)
+ ; OldStatus = exported ->
+ NewDefnStatus = exported
+ ;
+ status_is_exported_to_non_submodules(OldStatus, no),
+ status_is_exported_to_non_submodules(NewDefnStatus, no)
+ ).
+
+process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !IO) :-
+ hlds_data__get_type_defn_context(TypeDefn, Context),
+ hlds_data__get_type_defn_tvarset(TypeDefn, TVarSet),
+ hlds_data__get_type_defn_tparams(TypeDefn, Args),
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+ hlds_data__get_type_defn_status(TypeDefn, Status),
+ hlds_data__get_type_defn_need_qualifier(TypeDefn, NeedQual),
+ (
+ ConsList = Body ^ du_type_ctors,
+ ReservedTag = Body ^ du_type_reserved_tag,
+ module_info_ctors(!.ModuleInfo, Ctors0),
+ module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
+ check_for_errors(
+ (pred(M0::in, M::out, IO0::di, IO::uo) is det :-
+ module_info_ctor_field_table(M0, CtorFields0),
+ ctors_add(ConsList, TypeCtor, TVarSet, NeedQual, PQInfo,
+ Context, Status, CtorFields0, CtorFields, Ctors0, Ctors,
+ IO0, IO),
+ module_info_set_ctors(Ctors, M0, M1),
+ module_info_set_ctor_field_table(CtorFields, M1, M)
+ ), NewFoundError, !ModuleInfo, !IO),
+
+ globals__io_get_globals(Globals, !IO),
+ (
+ type_constructors_should_be_no_tag(ConsList, ReservedTag, Globals,
+ Name, CtorArgType, _)
+ ->
+ NoTagType = no_tag_type(Args, Name, CtorArgType),
+ module_info_no_tag_types(!.ModuleInfo, NoTagTypes0),
+ map__set(NoTagTypes0, TypeCtor, NoTagType, NoTagTypes),
+ module_info_set_no_tag_types(NoTagTypes, !ModuleInfo)
+ ;
+ true
+ )
+ ;
+ Body = abstract_type(_),
+ NewFoundError = no
+ ;
+ Body = solver_type(_, _),
+ NewFoundError = no
+ ;
+ Body = eqv_type(_),
+ NewFoundError = no
+ ;
+ Body = foreign_type(ForeignTypeBody),
+ check_foreign_type(TypeCtor, ForeignTypeBody, Context,
+ NewFoundError, !ModuleInfo, !IO)
+ ),
+ !:FoundError = !.FoundError `and` NewFoundError,
+ (
+ !.FoundError = yes
+ ->
+ true
+ ;
+ % Equivalence types are fully expanded on the IL and Java
+ % backends, so the special predicates aren't required.
+ are_equivalence_types_expanded(!.ModuleInfo),
+ Body = eqv_type(_)
+ ->
+ true
+ ;
+ construct_type(TypeCtor, Args, Type),
+ add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
+ !ModuleInfo)
+ ).
+
+ % Check_foreign_type ensures that if we are generating code for
+ % a specific backend that the foreign type has a representation
+ % on that backend.
+ %
+:- pred check_foreign_type(type_ctor::in, foreign_type_body::in,
+ prog_context::in, bool::out, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+check_foreign_type(TypeCtor, ForeignTypeBody, Context, FoundError, !ModuleInfo,
+ !IO) :-
+ TypeCtor = Name - Arity,
+ module_info_globals(!.ModuleInfo, Globals),
+ generating_code(GeneratingCode, !IO),
+ globals__get_target(Globals, Target),
+ ( have_foreign_type_for_backend(Target, ForeignTypeBody, yes) ->
+ FoundError = no
+ ; GeneratingCode = yes ->
+ %
+ % If we're not generating code the error may only have
+ % occurred because the grade options weren't passed.
+ %
+ io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
+ (
+ VeryVerbose = yes,
+ VerboseErrorPieces = [
+ nl,
+ words("There are representations for"),
+ words("this type on other back-ends,"),
+ words("but none for this back-end.")
+ ]
+ ;
+ VeryVerbose = no,
+ VerboseErrorPieces = []
+ ),
+ ( Target = c, LangStr = "C"
+ ; Target = il, LangStr = "IL"
+ ; Target = java, LangStr = "Java"
+ ; Target = asm, LangStr = "C"
+ ),
+ TypeStr = error_util__describe_sym_name_and_arity(Name/Arity),
+ ErrorPieces = [
+ words("Error: no"), words(LangStr),
+ words("`pragma foreign_type' declaration for"),
+ fixed(TypeStr) | VerboseErrorPieces
+ ],
+ error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
+ FoundError = yes,
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ FoundError = yes
+ ).
+
+ % Do the options imply that we will generate code for a specific
+ % back-end?
+ %
+:- pred generating_code(bool::out, io::di, io::uo) is det.
+
+generating_code(bool__not(NotGeneratingCode), !IO) :-
+ io_lookup_bool_option(make_short_interface, MakeShortInterface, !IO),
+ io_lookup_bool_option(make_interface, MakeInterface, !IO),
+ io_lookup_bool_option(make_private_interface, MakePrivateInterface, !IO),
+ io_lookup_bool_option(make_transitive_opt_interface,
+ MakeTransOptInterface, !IO),
+ io_lookup_bool_option(generate_source_file_mapping, GenSrcFileMapping, !IO),
+ io_lookup_bool_option(generate_dependencies, GenDepends, !IO),
+ io_lookup_bool_option(convert_to_mercury, ConvertToMercury, !IO),
+ io_lookup_bool_option(typecheck_only, TypeCheckOnly, !IO),
+ io_lookup_bool_option(errorcheck_only, ErrorCheckOnly, !IO),
+ io_lookup_bool_option(output_grade_string, OutputGradeString, !IO),
+ bool__or_list([MakeShortInterface, MakeInterface,
+ MakePrivateInterface, MakeTransOptInterface,
+ GenSrcFileMapping, GenDepends, ConvertToMercury,
+ TypeCheckOnly, ErrorCheckOnly, OutputGradeString],
+ NotGeneratingCode).
+
+:- pred merge_foreign_type_bodies(compilation_target::in, bool::in,
+ hlds_type_body::in, hlds_type_body::in, hlds_type_body::out)
+ is semidet.
+
+ % Ignore Mercury definitions if we've got a foreign type
+ % declaration suitable for this back-end and we aren't making the
+ % optimization interface. We need to keep the Mercury definition
+ % if we are making the optimization interface so that it gets
+ % output in the .opt file.
+ %
+merge_foreign_type_bodies(Target, MakeOptInterface,
+ foreign_type(ForeignTypeBody0), Body1, Body) :-
+ MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
+ (
+ MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
+ ;
+ MaybeForeignTypeBody1 = no,
+ ForeignTypeBody1 = foreign_type_body(no, no, no)
+ ),
+ merge_foreign_type_bodies_2(ForeignTypeBody0, ForeignTypeBody1,
+ ForeignTypeBody),
+ (
+ have_foreign_type_for_backend(Target, ForeignTypeBody, yes),
+ MakeOptInterface = no
+ ->
+ Body = foreign_type(ForeignTypeBody)
+ ;
+ Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
+ ).
+merge_foreign_type_bodies(Target, MakeOptInterface,
+ Body0 @ du_type(_, _, _, _, _, _),
+ Body1 @ foreign_type(_), Body) :-
+ merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
+merge_foreign_type_bodies(_, _, foreign_type(Body0),
+ foreign_type(Body1),
+ foreign_type(Body)) :-
+ merge_foreign_type_bodies_2(Body0, Body1, Body).
+
+:- pred merge_foreign_type_bodies_2(foreign_type_body::in,
+ foreign_type_body::in, foreign_type_body::out) is semidet.
+
+merge_foreign_type_bodies_2(foreign_type_body(MaybeILA, MaybeCA, MaybeJavaA),
+ foreign_type_body(MaybeILB, MaybeCB, MaybeJavaB),
+ foreign_type_body(MaybeIL, MaybeC, MaybeJava)) :-
+ merge_maybe(MaybeILA, MaybeILB, MaybeIL),
+ merge_maybe(MaybeCA, MaybeCB, MaybeC),
+ merge_maybe(MaybeJavaA, MaybeJavaB, MaybeJava).
+
+:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
+
+merge_maybe(no, no, no).
+merge_maybe(yes(T), no, yes(T)).
+merge_maybe(no, yes(T), yes(T)).
+
+make_status_abstract(Status, AbstractStatus) :-
+ ( Status = exported ->
+ AbstractStatus = abstract_exported
+ ; Status = imported(_) ->
+ AbstractStatus = abstract_imported
+ ;
+ AbstractStatus = Status
+ ).
+
+combine_status(StatusA, StatusB, Status) :-
+ ( combine_status_2(StatusA, StatusB, CombinedStatus) ->
+ Status = CombinedStatus
+ ;
+ error("unexpected status for type definition")
+ ).
+
+:- pred combine_status_2(import_status::in, import_status::in,
+ import_status::out) is semidet.
+
+combine_status_2(imported(_), Status2, Status) :-
+ combine_status_imported(Status2, Status).
+combine_status_2(local, Status2, Status) :-
+ combine_status_local(Status2, Status).
+combine_status_2(exported, _Status2, exported).
+combine_status_2(exported_to_submodules, Status2, Status) :-
+ combine_status_local(Status2, Status3),
+ ( Status3 = local ->
+ Status = exported_to_submodules
+ ;
+ Status = Status3
+ ).
+combine_status_2(opt_imported, _Status2, opt_imported).
+combine_status_2(abstract_imported, Status2, Status) :-
+ combine_status_abstract_imported(Status2, Status).
+combine_status_2(abstract_exported, Status2, Status) :-
+ combine_status_abstract_exported(Status2, Status).
+
+:- pred combine_status_imported(import_status::in, import_status::out)
+ is semidet.
+
+combine_status_imported(imported(Section), imported(Section)).
+combine_status_imported(local, imported(implementation)).
+combine_status_imported(exported, exported).
+combine_status_imported(opt_imported, opt_imported).
+combine_status_imported(abstract_imported, imported(interface)).
+combine_status_imported(abstract_exported, abstract_exported).
+
+:- pred combine_status_local(import_status::in, import_status::out) is semidet.
+
+combine_status_local(exported_to_submodules, exported_to_submodules).
+combine_status_local(imported(_), local).
+combine_status_local(local, local).
+combine_status_local(exported, exported).
+combine_status_local(opt_imported, local).
+combine_status_local(abstract_imported, local).
+combine_status_local(abstract_exported, abstract_exported).
+
+:- pred combine_status_abstract_exported(import_status::in, import_status::out)
+ is det.
+
+combine_status_abstract_exported(Status2, Status) :-
+ ( Status2 = exported ->
+ Status = exported
+ ;
+ Status = abstract_exported
+ ).
+
+:- pred combine_status_abstract_imported(import_status::in, import_status::out)
+ is det.
+
+combine_status_abstract_imported(Status2, Status) :-
+ ( Status2 = imported(Section) ->
+ Status = imported(Section)
+ ;
+ Status = abstract_imported
+ ).
+
+:- pred convert_type_defn(type_defn::in, type_ctor::in, globals::in,
+ hlds_type_body::out) is det.
+
+convert_type_defn(du_type(Body, MaybeUserEqComp), TypeCtor, Globals,
+ HLDSBody) :-
+ % Initially, when we first see the `:- type' definition,
+ % we assign the constructor tags assuming that there is no
+ % `:- pragma reserve_tag' declaration for this type.
+ % (If it turns out that there was one, then we will recompute the
+ % constructor tags by calling assign_constructor_tags again,
+ % with ReservedTagPragma = yes, when processing the pragma.)
+ ReservedTagPragma = no,
+ assign_constructor_tags(Body, TypeCtor, ReservedTagPragma, Globals,
+ CtorTags, IsEnum),
+ IsForeign = no,
+ HLDSBody = du_type(Body, CtorTags, IsEnum, MaybeUserEqComp,
+ ReservedTagPragma, IsForeign).
+convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
+convert_type_defn(solver_type(SolverTypeDetails, MaybeUserEqComp), _, _,
+ solver_type(SolverTypeDetails, MaybeUserEqComp)).
+convert_type_defn(abstract_type(IsSolverType), _, _,
+ abstract_type(IsSolverType)).
+convert_type_defn(foreign_type(ForeignType, MaybeUserEqComp, Assertions),
+ _, _, foreign_type(Body)) :-
+ (
+ ForeignType = il(ILForeignType),
+ Data = foreign_type_lang_data(ILForeignType, MaybeUserEqComp,
+ Assertions),
+ Body = foreign_type_body(yes(Data), no, no)
+ ;
+ ForeignType = c(CForeignType),
+ Data = foreign_type_lang_data(CForeignType, MaybeUserEqComp,
+ Assertions),
+ Body = foreign_type_body(no, yes(Data), no)
+ ;
+ ForeignType = java(JavaForeignType),
+ Data = foreign_type_lang_data(JavaForeignType, MaybeUserEqComp,
+ Assertions),
+ Body = foreign_type_body(no, no, yes(Data))
+ ).
+
+:- pred ctors_add(list(constructor)::in, type_ctor::in, tvarset::in,
+ need_qualifier::in, partial_qualifier_info::in, prog_context::in,
+ import_status::in, ctor_field_table::in, ctor_field_table::out,
+ cons_table::in, cons_table::out, io::di, io::uo) is det.
+
+ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !IO).
+ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, Context,
+ ImportStatus, !FieldNameTable, !Ctors, !IO) :-
+ Ctor = ctor(ExistQVars, Constraints, Name, Args),
+ QualifiedConsId = make_cons_id(Name, Args, TypeCtor),
+ ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeCtor,
+ Context),
+ %
+ % Insert the fully-qualified version of this cons_id into the
+ % cons_table.
+ % Also check that there is at most one definition of a given
+ % cons_id in each type.
+ %
+ ( map__search(!.Ctors, QualifiedConsId, QualifiedConsDefns0) ->
+ QualifiedConsDefns1 = QualifiedConsDefns0
+ ;
+ QualifiedConsDefns1 = []
+ ),
+ (
+ list__member(OtherConsDefn, QualifiedConsDefns1),
+ OtherConsDefn = hlds_cons_defn(_, _, _, TypeCtor, _)
+ ->
+ % XXX we should record each error using module_info_incr_errors
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: constructor `", !IO),
+ hlds_out__write_cons_id(QualifiedConsId, !IO),
+ io__write_string("' for type `", !IO),
+ hlds_out__write_type_ctor(TypeCtor, !IO),
+ io__write_string("' multiply defined.\n", !IO),
+ io__set_exit_status(1, !IO),
+ QualifiedConsDefns = QualifiedConsDefns1
+ ;
+ QualifiedConsDefns = [ConsDefn | QualifiedConsDefns1]
+ ),
+ map__set(!.Ctors, QualifiedConsId, QualifiedConsDefns, !:Ctors),
+
+ ( QualifiedConsId = cons(qualified(Module, ConsName), Arity) ->
+ % Add unqualified version of the cons_id to the
+ % cons_table, if appropriate.
+ ( NeedQual = may_be_unqualified ->
+ UnqualifiedConsId = cons(unqualified(ConsName), Arity),
+ multi_map__set(!.Ctors, UnqualifiedConsId, ConsDefn, !:Ctors)
+ ;
+ true
+ ),
+
+ % Add partially qualified versions of the cons_id
+ get_partial_qualifiers(Module, PQInfo, PartialQuals),
+ list__map_foldl(add_ctor(ConsName, Arity, ConsDefn),
+ PartialQuals, _PartiallyQualifiedConsIds, !Ctors),
+
+ assoc_list__keys(Args, FieldNames),
+ FirstField = 1,
+
+ add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
+ QualifiedConsId, Context, ImportStatus, FirstField,
+ !FieldNameTable, !IO)
+ ;
+ error("ctors_add: cons_id not qualified")
+ ),
+ ctors_add(Rest, TypeCtor, TVarSet, NeedQual, PQInfo, Context,
+ ImportStatus, !FieldNameTable, !Ctors, !IO).
+
+:- pred add_ctor(string::in, int::in, hlds_cons_defn::in, module_name::in,
+ cons_id::out, cons_table::in, cons_table::out) is det.
+
+add_ctor(ConsName, Arity, ConsDefn, ModuleQual, ConsId, CtorsIn, CtorsOut) :-
+ ConsId = cons(qualified(ModuleQual, ConsName), Arity),
+ multi_map__set(CtorsIn, ConsId, ConsDefn, CtorsOut).
+
+:- pred add_ctor_field_names(list(maybe(ctor_field_name))::in,
+ need_qualifier::in, list(module_name)::in, type_ctor::in, cons_id::in,
+ prog_context::in, import_status::in, int::in,
+ ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
+
+add_ctor_field_names([], _, _, _, _, _, _, _, !FieldNameTable, !IO).
+add_ctor_field_names([MaybeFieldName | FieldNames], NeedQual,
+ PartialQuals, TypeCtor, ConsId, Context, ImportStatus,
+ FieldNumber, !FieldNameTable, !IO) :-
+ (
+ MaybeFieldName = yes(FieldName),
+ FieldDefn = hlds_ctor_field_defn(Context, ImportStatus, TypeCtor,
+ ConsId, FieldNumber),
+ add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
+ !FieldNameTable, !IO)
+ ;
+ MaybeFieldName = no
+ ),
+ add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
+ ConsId, Context, ImportStatus, FieldNumber + 1,
+ !FieldNameTable, !IO).
+
+:- pred add_ctor_field_name(ctor_field_name::in, hlds_ctor_field_defn::in,
+ need_qualifier::in, list(module_name)::in,
+ ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
+
+add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
+ !FieldNameTable, !IO) :-
+ ( FieldName = qualified(FieldModule0, _) ->
+ FieldModule = FieldModule0
+ ;
+ error("add_ctor_field_name: unqualified field name")
+ ),
+ (
+ %
+ % Field names must be unique within a module, not
+ % just within a type because the function names for
+ % user-defined override functions for the builtin field
+ % access functions must be unique within a module.
+ %
+ map__search(!.FieldNameTable, FieldName, ConflictingDefns)
+ ->
+ ( ConflictingDefns = [ConflictingDefn] ->
+ ConflictingDefn = hlds_ctor_field_defn(OrigContext, _, _, _, _)
+ ;
+ error("add_ctor_field_name: multiple conflicting fields")
+ ),
+
+ % XXX we should record each error
+ % using module_info_incr_errors
+ FieldDefn = hlds_ctor_field_defn(Context, _, _, _, _),
+ mdbcomp__prim_data__sym_name_to_string(FieldName, FieldString),
+ ErrorPieces = [
+ words("Error: field"),
+ fixed(string__append_list(["`", FieldString, "'"])),
+ words("multiply defined.")
+ ],
+ error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
+
+ % This type of error doesn't fit well with
+ % how error_util does things -- error_util.m
+ % wants to write everything with a single context.
+ prog_out__write_context(OrigContext, !IO),
+ io__write_string(" Here is the previous definition of field `", !IO),
+ io__write_string(FieldString, !IO),
+ io__write_string("'.\n", !IO),
+ io__set_exit_status(1, !IO)
+ ;
+ unqualify_name(FieldName, UnqualFieldName),
+
+ % Add an unqualified version of the field name to the
+ % table, if appropriate.
+ ( NeedQual = may_be_unqualified ->
+ multi_map__set(!.FieldNameTable, unqualified(UnqualFieldName),
+ FieldDefn, !:FieldNameTable)
+ ;
+ true
+ ),
+
+ % Add partially qualified versions of the cons_id
+ list__foldl(do_add_ctor_field(UnqualFieldName, FieldDefn),
+ [FieldModule | PartialQuals], !FieldNameTable)
+ ).
+
+:- pred do_add_ctor_field(string::in, hlds_ctor_field_defn::in,
+ module_name::in, ctor_field_table::in, ctor_field_table::out) is det.
+
+do_add_ctor_field(FieldName, FieldNameDefn, ModuleName, !FieldNameTable) :-
+ multi_map__set(!.FieldNameTable, qualified(ModuleName, FieldName),
+ FieldNameDefn, !:FieldNameTable).
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.75
diff -u -b -r1.75 check_typeclass.m
--- compiler/check_typeclass.m 13 May 2005 11:33:48 -0000 1.75
+++ compiler/check_typeclass.m 21 Jul 2005 15:32:21 -0000
@@ -71,8 +71,9 @@
:- import_module bool.
:- import_module io.
-:- pred check_typeclass__check_typeclasses(qual_info::in, qual_info::out,
- module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
+:- pred check_typeclass__check_typeclasses(make_hlds_qual_info::in,
+ make_hlds_qual_info::out, module_info::in, module_info::out,
+ bool::out, io::di, io::uo) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
@@ -147,8 +148,9 @@
:- type error_message == pair(prog_context, list(format_component)).
:- type error_messages == list(error_message).
-:- pred check_typeclass__check_instance_decls(qual_info::in, qual_info::out,
- module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
+:- pred check_typeclass__check_instance_decls(make_hlds_qual_info::in,
+ make_hlds_qual_info::out, module_info::in, module_info::out,
+ bool::out, io::di, io::uo) is det.
check_typeclass__check_instance_decls(!QualInfo, !ModuleInfo, FoundError,
!IO) :-
@@ -180,7 +182,7 @@
---> check_tc_info(
error_messages :: error_messages,
module_info :: module_info,
- qual_info :: qual_info
+ qual_info :: make_hlds_qual_info
).
% Check all the instances of one class.
@@ -269,8 +271,9 @@
list(pred_id)::in, term__context::in,
instance_methods::in, hlds_instance_defn::in, hlds_instance_defn::out,
error_messages::in, error_messages::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ make_hlds_qual_info::in, make_hlds_qual_info::out, io::di, io::uo)
+ is det.
check_concrete_class_instance(ClassId, Vars, HLDSClassInterface,
ClassInterface, PredIds, TermContext,
@@ -408,7 +411,7 @@
% declaration.
error_messages,
module_info,
- qual_info
+ make_hlds_qual_info
).
% This structure holds the information about a particular instance
@@ -416,7 +419,7 @@
:- type instance_method_info --->
instance_method_info(
module_info,
- qual_info,
+ make_hlds_qual_info,
sym_name, % Name that the
% introduced pred
% should be given.
Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.48
diff -u -b -r1.48 clause_to_proc.m
--- compiler/clause_to_proc.m 22 Jul 2005 12:31:52 -0000 1.48
+++ compiler/clause_to_proc.m 25 Jul 2005 03:03:13 -0000
@@ -27,7 +27,7 @@
% of a predicate (e.g. sort). For each mode of the predicate,
% we select the clauses for that mode, disjoin them together,
% and save this in the proc_info.
-
+ %
:- pred copy_module_clauses_to_procs(list(pred_id)::in,
module_info::in, module_info::out) is det.
@@ -39,7 +39,7 @@
% Before copying the clauses to the procs, we need to add
% a default mode of `:- mode foo(in, in, ..., in) = out is det.'
% for functions that don't have an explicit mode declaration.
-
+ %
:- pred maybe_add_default_func_modes(list(pred_id)::in,
pred_table::in, pred_table::out) is det.
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.16
diff -u -b -r1.16 hlds_code_util.m
--- compiler/hlds_code_util.m 22 Mar 2005 06:39:58 -0000 1.16
+++ compiler/hlds_code_util.m 21 Jul 2005 12:24:43 -0000
@@ -23,18 +23,18 @@
:- import_module list.
% Are equivalence types fully expanded on this backend?
-
+ %
:- pred are_equivalence_types_expanded(module_info::in) is semidet.
% Find out how a function symbol (constructor) is represented
% in the given type.
-
+ %
:- func cons_id_to_tag(cons_id, type, module_info) = cons_tag.
% Given a list of types, mangle the names so into a string which
% identifies them. The types must all have their top level functor
% bound, with any arguments free variables.
-
+ %
:- pred make_instance_string(list(type)::in, string::out) is det.
:- implementation.
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.358
diff -u -b -r1.358 hlds_out.m
--- compiler/hlds_out.m 22 Jul 2005 12:31:54 -0000 1.358
+++ compiler/hlds_out.m 25 Jul 2005 03:03:13 -0000
@@ -2335,16 +2335,6 @@
io__write_string(", ", !IO),
hlds_out__write_var_name_list([VarName2 | Vars], !IO).
-:- pred hlds_out__write_string_list(list(string)::in, io::di, io::uo) is det.
-
-hlds_out__write_string_list([], !IO).
-hlds_out__write_string_list([Name], !IO) :-
- io__write_string(Name, !IO).
-hlds_out__write_string_list([Name1, Name2 | Names], !IO) :-
- io__write_string(Name1, !IO),
- io__write_string(", ", !IO),
- hlds_out__write_string_list([Name2 | Names], !IO).
-
:- pred hlds_out__write_aditi_builtin(module_info::in, aditi_builtin::in,
simple_call_id::in, list(prog_var)::in, prog_varset::in, bool::in,
int::in, string::in, io::di, io::uo) is det.
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.166
diff -u -b -r1.166 hlds_pred.m
--- compiler/hlds_pred.m 22 Jul 2005 12:31:55 -0000 1.166
+++ compiler/hlds_pred.m 25 Jul 2005 03:49:55 -0000
@@ -125,6 +125,8 @@
:- type proc_table == map(proc_id, proc_info).
+:- pred next_mode_id(proc_table::in, proc_id::out) is det.
+
:- type call_id
---> call(simple_call_id)
; generic_call(generic_call_id).
@@ -699,6 +701,11 @@
% language clauses?
).
+:- pred clauses_info_init(int::in, clauses_info::out) is det.
+
+:- pred clauses_info_init_for_assertion(prog_vars::in, clauses_info::out)
+ is det.
+
:- type clauses_rep.
% Returns yes iff the given clauses_rep represents the empty list of
@@ -725,8 +732,6 @@
:- type vartypes == map(prog_var, type).
-:- type tvar_name_map == map(string, tvar).
-
:- pred clauses_info_varset(clauses_info::in, prog_varset::out) is det.
% This partial map holds the types specified by any explicit
@@ -797,6 +802,27 @@
:- implementation.
+clauses_info_init(Arity, ClausesInfo) :-
+ map__init(VarTypes),
+ map__init(TVarNameMap),
+ varset__init(VarSet0),
+ make_n_fresh_vars("HeadVar__", Arity, HeadVars, VarSet0, VarSet),
+ rtti_varmaps_init(RttiVarMaps),
+ HasForeignClauses = no,
+ set_clause_list([], ClausesRep),
+ ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
+ HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses).
+
+clauses_info_init_for_assertion(HeadVars, ClausesInfo) :-
+ map__init(VarTypes),
+ map__init(TVarNameMap),
+ varset__init(VarSet),
+ rtti_varmaps_init(RttiVarMaps),
+ HasForeignClauses = no,
+ set_clause_list([], ClausesRep),
+ ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
+ HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses).
+
clauses_info_varset(CI, CI ^ varset).
clauses_info_explicit_vartypes(CI, CI ^ explicit_vartypes).
clauses_info_vartypes(CI, CI ^ vartypes).
@@ -1590,6 +1616,14 @@
hlds_pred__in_in_unification_proc_id(0).
+ % We could store the next available ModeId rather than recomputing
+ % it on demand, but it is probably more efficient this way.
+ %
+next_mode_id(Procs, ModeId) :-
+ map__to_assoc_list(Procs, List),
+ list__length(List, ModeInt),
+ proc_id_to_int(ModeId, ModeInt).
+
status_is_exported(imported(_), no).
status_is_exported(external(_), no).
status_is_exported(abstract_imported, no).
@@ -1793,9 +1827,8 @@
ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
HeadVars, Clauses, RttiVarMaps, HasForeignClauses),
- proc_info_declared_determinism(ProcInfo, MaybeDetism),
map__init(Procs0),
- next_mode_id(Procs0, MaybeDetism, ProcId),
+ next_mode_id(Procs0, ProcId),
map__det_insert(Procs0, ProcId, ProcInfo, Procs),
PredInfo = pred_info(ModuleName, PredName, Arity, PredOrFunc,
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.516
diff -u -b -r1.516 make_hlds.m
--- compiler/make_hlds.m 22 Jul 2005 12:31:57 -0000 1.516
+++ compiler/make_hlds.m 25 Jul 2005 08:27:15 -0000
@@ -38,6 +38,8 @@
:- import_module std_util.
:- import_module term.
+:- type make_hlds_qual_info.
+
% parse_tree_to_hlds(ParseTree, MQInfo, EqvMap, HLDS, QualInfo,
% InvalidTypes, InvalidModes):
%
@@ -50,8 +52,8 @@
% produce_instance_method_clauses (see below).
%
:- pred parse_tree_to_hlds(compilation_unit::in, mq_info::in, eqv_map::in,
- module_info::out, qual_info::out, bool::out, bool::out, io::di, io::uo)
- is det.
+ module_info::out, make_hlds_qual_info::out, bool::out, bool::out,
+ io::di, io::uo) is det.
:- pred add_new_proc(inst_varset::in, arity::in, list(mode)::in,
maybe(list(mode))::in, maybe(list(is_live))::in,
@@ -83,8 +85,6 @@
tvarset::in, (type)::in, type_ctor::in, prog_context::in,
import_status::in, module_info::in, module_info::out) is det.
-:- type qual_info.
-
% Given the definition for a predicate or function from a
% type class instance declaration, produce the clauses_info
% for that definition.
@@ -92,10539 +92,70 @@
:- pred produce_instance_method_clauses(instance_proc_def::in,
pred_or_func::in, arity::in, list(type)::in, pred_markers::in,
term__context::in, import_status::in, clauses_info::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
+ module_info::in, module_info::out,
+ make_hlds_qual_info::in, make_hlds_qual_info::out, io::di, io::uo) is det.
% Move the recompilation_info from the qual_info to the module_info
% after make_hlds is finished with it and the qual_info is dead.
%
-:- pred set_module_recompilation_info(qual_info::in,
+:- pred set_module_recomp_info(make_hlds_qual_info::in,
module_info::in, module_info::out) is det.
-:- pred next_mode_id(proc_table::in, maybe(determinism)::in, proc_id::out)
- is det.
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
:- implementation.
-:- import_module backend_libs.
-:- import_module backend_libs__export.
-:- import_module backend_libs__foreign.
-:- import_module check_hlds__clause_to_proc.
-:- import_module check_hlds__inst_match.
-:- import_module check_hlds__mode_errors.
-:- import_module check_hlds__mode_util.
-:- import_module check_hlds__purity.
-:- import_module check_hlds__typecheck.
-:- import_module check_hlds__type_util.
-:- import_module check_hlds__unify_proc.
-:- import_module hlds__goal_util.
-:- import_module hlds__hlds_code_util.
-:- import_module hlds__hlds_goal.
-:- import_module hlds__hlds_out.
-:- import_module hlds__make_tags.
-:- import_module hlds__passes_aux.
-:- import_module hlds__quantification.
-:- import_module hlds__special_pred.
-:- import_module libs__globals.
-:- import_module libs__options.
-:- import_module libs__polyhedron.
-:- import_module libs__lp_rational.
-:- import_module ll_backend.
-:- import_module ll_backend__fact_table.
-:- import_module ll_backend__llds.
-:- import_module parse_tree__error_util.
-:- import_module parse_tree__mercury_to_mercury.
-:- import_module parse_tree__module_qual.
-:- import_module parse_tree__modules.
-:- import_module parse_tree__prog_foreign.
-:- import_module parse_tree__prog_io.
-:- import_module parse_tree__prog_io_dcg.
-:- import_module parse_tree__prog_io_goal.
-:- import_module parse_tree__prog_io_util.
-:- import_module parse_tree__prog_mode.
-:- import_module parse_tree__prog_out.
-:- import_module parse_tree__prog_util.
-:- import_module parse_tree__prog_type.
-:- import_module recompilation.
-:- import_module transform_hlds__term_constr_main.
-:- import_module transform_hlds__term_constr_util.
-:- import_module transform_hlds__term_util.
-
-:- import_module assoc_list.
-:- import_module bag.
-:- import_module char.
-:- import_module getopt_io.
-:- import_module int.
-:- import_module map.
-:- import_module multi_map.
-:- import_module require.
-:- import_module set.
-:- import_module string.
-:- import_module svmap.
-:- import_module term.
-:- import_module term_io.
-:- import_module varset.
-
-parse_tree_to_hlds(module(Name, Items), MQInfo0, EqvMap, ModuleInfo, QualInfo,
- InvalidTypes, InvalidModes, !IO) :-
- some [!Module] (
- globals__io_get_globals(Globals, !IO),
- mq_info_get_partial_qualifier_info(MQInfo0, PQInfo),
- module_info_init(Name, Items, Globals, PQInfo, no, !:Module),
- add_item_list_decls_pass_1(Items,
- item_status(local, may_be_unqualified), !Module,
- no, InvalidModes0, !IO),
- globals__io_lookup_bool_option(statistics, Statistics, !IO),
- maybe_report_stats(Statistics, !IO),
-
- check_for_errors(
- add_item_list_decls_pass_2(Items,
- item_status(local, may_be_unqualified)),
- InvalidTypes1, !Module, !IO),
-
- % Add constructors and special preds to the HLDS.
- % This must be done after adding all type and
- % `:- pragma foreign_type' declarations.
- % If there were errors in foreign type type declarations,
- % doing this may cause a compiler abort.
- (
- InvalidTypes1 = no,
- module_info_types(!.Module, Types),
- map__foldl3(process_type_defn, Types,
- no, InvalidTypes2, !Module, !IO)
- ;
- InvalidTypes1 = yes,
- InvalidTypes2 = yes
- ),
-
- % Add the special preds for the builtin types which don't have a
- % type declaration, hence no hlds_type_defn is generated for them.
- (
- Name = mercury_public_builtin_module,
- compiler_generated_rtti_for_builtins(!.Module)
- ->
- varset__init(TVarSet),
- Body = abstract_type(non_solver_type),
- term__context_init(Context),
- Status = local,
- list__foldl(
- (pred(TypeCtor::in, M0::in, M::out) is det :-
- construct_type(TypeCtor, [], Type),
- add_special_preds(TVarSet, Type, TypeCtor, Body, Context,
- Status, M0, M)
- ), builtin_type_ctors_with_no_hlds_type_defn, !Module)
- ;
- true
- ),
-
- maybe_report_stats(Statistics, !IO),
- % balance any data structures that need it
- module_info_optimize(!Module),
- maybe_report_stats(Statistics, !IO),
- init_qual_info(MQInfo0, EqvMap, QualInfo0),
- add_item_list_clauses(Items, local, !Module, QualInfo0, QualInfo, !IO),
-
- qual_info_get_mq_info(QualInfo, MQInfo),
- mq_info_get_type_error_flag(MQInfo, InvalidTypes3),
- InvalidTypes = InvalidTypes1 `or` InvalidTypes2 `or` InvalidTypes3,
- mq_info_get_mode_error_flag(MQInfo, InvalidModes1),
- InvalidModes = InvalidModes0 `or` InvalidModes1,
- mq_info_get_num_errors(MQInfo, MQ_NumErrors),
-
- module_info_num_errors(!.Module, ModuleNumErrors),
- NumErrors = ModuleNumErrors + MQ_NumErrors,
- module_info_set_num_errors(NumErrors, !Module),
- % The predid list is constructed in reverse order, for efficiency,
- % so we return it to the correct order here.
- module_info_reverse_predids(!Module),
- ModuleInfo = !.Module
- ).
-
-:- pred check_for_errors(pred(module_info, module_info, io, io)
- ::pred(in, out, di, uo) is det, bool::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-check_for_errors(P, FoundError, !ModuleInfo, !IO) :-
- io__get_exit_status(BeforeStatus, !IO),
- io__set_exit_status(0, !IO),
- module_info_num_errors(!.ModuleInfo, BeforeNumErrors),
- P(!ModuleInfo, !IO),
- module_info_num_errors(!.ModuleInfo, AfterNumErrors),
- io__get_exit_status(AfterStatus, !IO),
- (
- AfterStatus = 0,
- BeforeNumErrors = AfterNumErrors
- ->
- FoundError = no
- ;
- FoundError = yes
- ),
- ( BeforeStatus \= 0 ->
- io__set_exit_status(BeforeStatus, !IO)
- ;
- true
- ).
-
-%-----------------------------------------------------------------------------%
-
- % When adding an item to the HLDS we need to know both its
- % import_status and whether uses of it must be module qualified.
-:- type item_status
- ---> item_status(import_status, need_qualifier).
-
-%-----------------------------------------------------------------------------%
-
- % pass 1:
- % Add the declarations one by one to the module,
- % except for type definitions and pragmas.
-
- % The `InvalidModes' bool records whether we detected
- % any cyclic insts or modes.
-
-:- pred add_item_list_decls_pass_1(item_list::in, item_status::in,
- module_info::in, module_info::out, bool::in, bool::out,
- io::di, io::uo) is det.
-
-add_item_list_decls_pass_1([], _, !ModuleInfo, !InvalidModes, !IO).
-add_item_list_decls_pass_1([Item - Context | Items], Status0, !ModuleInfo,
- !InvalidModes, !IO) :-
- add_item_decl_pass_1(Item, Context, Status0, Status1, !ModuleInfo,
- NewInvalidModes, !IO),
- !:InvalidModes = bool__or(!.InvalidModes, NewInvalidModes),
- add_item_list_decls_pass_1(Items, Status1, !ModuleInfo, !InvalidModes, !IO).
-
- % pass 2:
- % Add the type definitions and pragmas one by one to the module,
- % and add default modes for functions with no mode declaration.
- %
- % Adding type definitions needs to come after we have added the
- % pred declarations,
- % since we need to have the pred_id for `index/2' and `compare/3'
- % when we add compiler-generated clauses for `compare/3'.
- % (And similarly for other compiler-generated predicates like that.)
- %
- % Adding pragmas needs to come after we have added the
- % pred declarations, in order to allow the pragma declarations
- % for a predicate to syntactically precede the pred declaration.
- %
- % Adding default modes for functions needs to come after we have
- % processed all the mode declarations, since otherwise we can't be
- % sure that there isn't a mode declaration for the function.
-
-:- pred add_item_list_decls_pass_2(item_list::in, item_status::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-add_item_list_decls_pass_2([], _, !ModuleInfo, !IO).
-add_item_list_decls_pass_2([Item - Context | Items], Status0, !ModuleInfo, !IO) :-
- add_item_decl_pass_2(Item, Context, Status0, Status1, !ModuleInfo, !IO),
- add_item_list_decls_pass_2(Items, Status1, !ModuleInfo, !IO).
-
- % pass 3:
- % Add the clauses one by one to the module.
- % (I supposed this could conceivably be folded into pass 2?)
- %
- % Check that the declarations for field extraction
- % and update functions are sensible.
-
-:- pred add_item_list_clauses(item_list::in, import_status::in,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-add_item_list_clauses([], _Status, !ModuleInfo, !QualInfo, !IO).
-add_item_list_clauses([Item - Context | Items], Status0,
- !ModuleInfo, !QualInfo, !IO) :-
- add_item_clause(Item, Status0, Status1, Context, !ModuleInfo, !QualInfo,
- !IO),
- add_item_list_clauses(Items, Status1, !ModuleInfo, !QualInfo, !IO).
-
-%-----------------------------------------------------------------------------%
-
- % The bool records whether any cyclic insts or modes were
- % detected.
-
-:- pred add_item_decl_pass_1(item::in, prog_context::in,
- item_status::in, item_status::out, module_info::in, module_info::out,
- bool::out, io::di, io::uo) is det.
-
- % Dispatch on the different types of items.
-
- % skip clauses
-add_item_decl_pass_1(clause(_, _, _, _, _), _, !Status, !ModuleInfo, no, !IO).
-
- % If this is a solver type then we need to also add the declarations
- % for the compiler generated construction function and deconstruction
- % predicate for the special constrained data constructor.
- %
- % In pass 3 we add the corresponding clauses.
- %
- % Before switch detection, we turn calls to these functions/predicates
- % into ordinary constructions/deconstructions, but preserve the
- % corresponding impurity annotations.
- %
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
- Item = type_defn(TVarSet, SymName, TypeParams, TypeDefn, _Cond),
- (
- TypeDefn = solver_type(SolverTypeDetails, _MaybeUserEqComp)
- ->
- add_solver_type_decl_items(TVarSet, SymName, TypeParams,
- SolverTypeDetails, Context, !Status, !ModuleInfo, !IO)
- ;
- true
- ).
-
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode, !IO) :-
- Item = inst_defn(VarSet, Name, Params, InstDefn, Cond),
- module_add_inst_defn(VarSet, Name, Params, InstDefn, Cond, Context,
- !.Status, !ModuleInfo, InvalidMode, !IO).
-
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode, !IO) :-
- Item = mode_defn(VarSet, Name, Params, ModeDefn, Cond),
- module_add_mode_defn(VarSet, Name, Params, ModeDefn,
- Cond, Context, !.Status, !ModuleInfo, InvalidMode, !IO).
-
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
- Item = pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, _WithType, _WithInst, MaybeDet, _Cond,
- Purity, ClassContext),
- init_markers(Markers),
- module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, MaybeDet, Purity, ClassContext, Markers,
- Context, !.Status, _, !ModuleInfo, !IO).
-
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
- Item = pred_or_func_mode(VarSet, MaybePredOrFunc, PredName, Modes,
- _WithInst, MaybeDet, _Cond),
- (
- MaybePredOrFunc = yes(PredOrFunc),
- !.Status = item_status(ImportStatus, _),
- IsClassMethod = no,
- module_add_mode(VarSet, PredName, Modes, MaybeDet, ImportStatus,
- Context, PredOrFunc, IsClassMethod, _, !ModuleInfo, !IO)
- ;
- MaybePredOrFunc = no,
- % equiv_type.m should have either set the pred_or_func
- % or removed the item from the list.
- unexpected(this_file, "add_item_decl_pass_1: " ++
- "no pred_or_func on mode declaration")
- ).
-
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
- Item = pragma(_).
-
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
- Item = promise(_, _, _, _).
-
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
- Item = module_defn(_VarSet, ModuleDefn),
- ( module_defn_update_import_status(ModuleDefn, StatusPrime) ->
- !:Status = StatusPrime
- ; ModuleDefn = import(module(Specifiers)) ->
- !.Status = item_status(IStat, _),
- (
- ( status_defined_in_this_module(IStat, yes)
- ; IStat = imported(ancestor_private_interface)
- )
- ->
- module_add_imported_module_specifiers(Specifiers, !ModuleInfo)
- ;
- module_add_indirectly_imported_module_specifiers(Specifiers,
- !ModuleInfo)
- )
- ; ModuleDefn = use(module(Specifiers)) ->
- !.Status = item_status(IStat, _),
- (
- ( status_defined_in_this_module(IStat, yes)
- ; IStat = imported(ancestor)
- )
- ->
- module_add_imported_module_specifiers(Specifiers, !ModuleInfo)
- ;
- module_add_indirectly_imported_module_specifiers(Specifiers,
- !ModuleInfo)
- )
- ; ModuleDefn = include_module(_) ->
- true
- ; ModuleDefn = external(MaybeBackend, External) ->
- ( External = name_arity(Name, Arity) ->
- lookup_current_backend(CurrentBackend, !IO),
- (
- (
- MaybeBackend = no
- ;
- MaybeBackend = yes(Backend),
- Backend = CurrentBackend
- )
- ->
- module_mark_as_external(Name, Arity, Context, !ModuleInfo, !IO)
- ;
- true
- )
- ;
- prog_out__write_context(Context, !IO),
- report_warning("Warning: `external' declaration requires arity.\n",
- !IO)
- )
- ; ModuleDefn = module(_ModuleName) ->
- report_unexpected_decl("module", Context, !IO)
- ; ModuleDefn = end_module(_ModuleName) ->
- report_unexpected_decl("end_module", Context, !IO)
- ; ModuleDefn = version_numbers(_, _) ->
- true
- ; ModuleDefn = transitively_imported ->
- true
- ;
- prog_out__write_context(Context, !IO),
- report_warning("Warning: declaration not yet implemented.\n", !IO)
- ).
-
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
- Item = nothing(_).
-
-add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
- Item = typeclass(Constraints, FunDeps, Name, Vars, Interface, VarSet),
- module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface,
- VarSet, Context, !.Status, !ModuleInfo, !IO).
-
- % We add instance declarations on the second pass so that we don't add
- % an instance declaration before its class declaration.
-add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
- Item = instance(_, _, _, _, _,_).
-
-%-----------------------------------------------------------------------------%
-
- % A solver type t defined with
- %
- % :- solver type st
- % where representation is rt, % type
- % initialisation is ip, % pred
- % ground is gi, % inst
- % any is ai, ... % inst
- %
- % causes the following to be introduced:
- %
- % :- impure func 'representation of ground st'(st::in) =
- % (rt::out(gi)) is det.
- % :- impure func 'representation of any st'(st::in(any)) =
- % (rt::out(ai)) is det.
- %
- % :- impure func 'representation to ground st'(rt::in(gi)) =
- % (st::out) is det.
- % :- impure func 'representation to any st'(rt::in(ai)) =
- % (st::out(any)) is det.
- %
-:- pred add_solver_type_decl_items(tvarset::in, sym_name::in,
- list(type_param)::in, solver_type_details::in, prog_context::in,
- item_status::in, item_status::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-add_solver_type_decl_items(TVarSet, TypeSymName, TypeParams,
- SolverTypeDetails, Context, !Status, !ModuleInfo, !IO) :-
-
- SolverType = sym_name_and_args_to_term(TypeSymName, TypeParams,
- Context),
- Arity = length(TypeParams),
-
- RepnType = SolverTypeDetails ^ representation_type,
- AnyInst = SolverTypeDetails ^ any_inst,
- GroundInst = SolverTypeDetails ^ ground_inst,
-
- InAnyMode = in_mode(AnyInst),
- InGroundMode = in_mode(GroundInst),
-
- OutAnyMode = out_mode(AnyInst),
- OutGroundMode = out_mode(GroundInst),
-
- InstVarSet = varset__init,
- ExistQTVars = [],
-
- % Insert the conversion function declarations.
-
- % The `:- impure
- % func 'representation of ground st'(st::in(gi)) =
- % (rt::out) is det' declaration.
- %
- ToGroundRepnSymName = solver_to_ground_repn_symname(TypeSymName, Arity),
- ToGroundRepnArgTypes =
- [type_and_mode(SolverType, in_mode ),
- type_and_mode(RepnType, OutGroundMode)],
- ToGroundRepnTypeSigItem =
- pred_or_func(TVarSet, InstVarSet, ExistQTVars,
- function,
- ToGroundRepnSymName,
- ToGroundRepnArgTypes,
- no, /* no `with_type` ... */
- no, /* no `with_inst` ... */
- yes(det),
- true, /* no `where ...' */
- (impure),
- constraints([], []) /* no type class constraints */
- ),
- add_item_decl_pass_1(ToGroundRepnTypeSigItem, Context, !Status, !ModuleInfo,
- InvalidToGroundRepnMode, !IO),
-
- (
- InvalidToGroundRepnMode = yes,
- error("make_hlds.add_solver_type_decl_items: invalid mode " ++
- "in ToGroundRepn item")
- ;
- InvalidToGroundRepnMode = no
- ),
-
- % The `:- impure
- % func 'representation of any st'(st::in(ai)) =
- % (rt::out(any)) is det' declaration.
- %
- ToAnyRepnSymName = solver_to_any_repn_symname(TypeSymName, Arity),
- ToAnyRepnArgTypes =
- [type_and_mode(SolverType, in_any_mode ),
- type_and_mode(RepnType, OutAnyMode)],
- ToAnyRepnTypeSigItem =
- pred_or_func(TVarSet, InstVarSet, ExistQTVars,
- function,
- ToAnyRepnSymName,
- ToAnyRepnArgTypes,
- no, /* no `with_type` ... */
- no, /* no `with_inst` ... */
- yes(det),
- true, /* no `where ...' */
- (impure),
- constraints([], []) /* no type class constraints */
- ),
- add_item_decl_pass_1(ToAnyRepnTypeSigItem, Context, !Status, !ModuleInfo,
- InvalidToAnyRepnMode, !IO),
-
- (
- InvalidToAnyRepnMode = yes,
- error("make_hlds.add_solver_type_decl_items: invalid mode " ++
- "in ToAnyRepn item")
- ;
- InvalidToAnyRepnMode = no
- ),
-
- % The `:- impure
- % func 'representation to ground st'(rt::in(gi)) =
- % (st::out) is det' declaration.
- %
- FromGroundRepnSymName = repn_to_ground_solver_symname(TypeSymName, Arity),
- FromGroundRepnArgTypes =
- [type_and_mode(RepnType, InGroundMode ),
- type_and_mode(SolverType, out_mode )],
- FromGroundRepnTypeSigItem =
- pred_or_func(TVarSet, InstVarSet, ExistQTVars,
- function,
- FromGroundRepnSymName,
- FromGroundRepnArgTypes,
- no, /* no `with_type` ... */
- no, /* no `with_inst` ... */
- yes(det),
- true, /* no `where ...' */
- (impure),
- constraints([], []) /* no type class constraints */
- ),
- add_item_decl_pass_1(FromGroundRepnTypeSigItem, Context, !Status,
- !ModuleInfo,
- InvalidFromGroundRepnMode, !IO),
-
- (
- InvalidFromGroundRepnMode = yes,
- error("make_hlds.add_solver_type_decl_items: invalid mode " ++
- "in FromGroundRepn item")
- ;
- InvalidFromGroundRepnMode = no
- ),
-
- % The `:- impure
- % func 'representation to any st'(rt::in(ai)) =
- % (st::out(any)) is det' declaration.
- %
- FromAnyRepnSymName = repn_to_any_solver_symname(TypeSymName, Arity),
- FromAnyRepnArgTypes =
- [type_and_mode(RepnType, InAnyMode ),
- type_and_mode(SolverType, out_any_mode)],
- FromAnyRepnTypeSigItem =
- pred_or_func(TVarSet, InstVarSet, ExistQTVars,
- function,
- FromAnyRepnSymName,
- FromAnyRepnArgTypes,
- no, /* no `with_type` ... */
- no, /* no `with_inst` ... */
- yes(det),
- true, /* no `where ...' */
- (impure),
- constraints([], []) /* no type class constraints */
- ),
- add_item_decl_pass_1(FromAnyRepnTypeSigItem, Context, !Status, !ModuleInfo,
- InvalidFromAnyRepnMode, !IO),
-
- (
- InvalidFromAnyRepnMode = yes,
- error("make_hlds.add_solver_type_decl_items: invalid mode " ++
- "in FromAnyRepn item")
- ;
- InvalidFromAnyRepnMode = no
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Obtain the solver type conversion function sym_names from
- % the solver type sym_name.
- %
-:- func solver_to_ground_repn_symname(sym_name, arity) = sym_name.
-solver_to_ground_repn_symname(SymName, Arity) =
- solver_conversion_fn_symname("representation of ground ", SymName, Arity).
-
-:- func solver_to_any_repn_symname(sym_name, arity) = sym_name.
-solver_to_any_repn_symname(SymName, Arity) =
- solver_conversion_fn_symname("representation of any ", SymName, Arity).
-
-:- func repn_to_ground_solver_symname(sym_name, arity) = sym_name.
-repn_to_ground_solver_symname(SymName, Arity) =
- solver_conversion_fn_symname("representation to ground ", SymName, Arity).
-
-:- func repn_to_any_solver_symname(sym_name, arity) = sym_name.
-repn_to_any_solver_symname(SymName, Arity) =
- solver_conversion_fn_symname("representation to any ", SymName, Arity).
-
-:- func solver_conversion_fn_symname(string, sym_name, arity) = sym_name.
-solver_conversion_fn_symname(Prefix, unqualified(Name), Arity) =
- unqualified(Prefix ++ Name ++ "/" ++ int_to_string(Arity)).
-solver_conversion_fn_symname(Prefix, qualified(ModuleNames, Name), Arity) =
- qualified(ModuleNames, Prefix ++ Name ++ "/" ++ int_to_string(Arity)).
-
-%-----------------------------------------------------------------------------%
-
- % dispatch on the different types of items
-
-:- pred add_item_decl_pass_2(item::in, prog_context::in, item_status::in,
- item_status::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !IO) :-
- Item = module_defn(_VarSet, ModuleDefn),
- ( module_defn_update_import_status(ModuleDefn, StatusPrime) ->
- !:Status = StatusPrime
- ;
- true
- ).
-
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
- Item = type_defn(VarSet, Name, Args, TypeDefn, Cond),
- module_add_type_defn(VarSet, Name, Args, TypeDefn, Cond, Context,
- !.Status, !ModuleInfo, !IO).
-
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
- Item = pragma(Pragma),
- %
- % check for invalid pragmas in the `interface' section
- %
- !.Status = item_status(ImportStatus, _),
- pragma_allowed_in_interface(Pragma, Allowed),
- (
- Allowed = no,
- check_not_exported(ImportStatus, Context, "`pragma' declaration", !IO)
- ;
- Allowed = yes
- ),
- %
- % switch on the pragma type
- %
- (
- % ignore `pragma source_file' declarations - they're dealt
- % with elsewhere
- Pragma = source_file(_)
- ;
- Pragma = foreign_code(Lang, Body_Code),
- module_add_foreign_body_code(Lang, Body_Code, Context, !ModuleInfo)
- ;
- Pragma = foreign_decl(Lang, IsLocal, C_Header),
- module_add_foreign_decl(Lang, IsLocal, C_Header, Context, !ModuleInfo)
- ;
- Pragma = foreign_import_module(Lang, Import),
- module_add_foreign_import_module(Lang, Import, Context, !ModuleInfo)
- ;
- % Handle pragma foreign procs later on (when we process
- % clauses).
- Pragma = foreign_proc(_, _, _, _, _, _)
- ;
- % Handle pragma tabled decls later on (when we process
- % clauses).
- Pragma = tabled(_, _, _, _, _)
- ;
- Pragma = inline(Name, Arity),
- add_pred_marker("inline", Name, Arity, ImportStatus, Context,
- inline, [no_inline], !ModuleInfo, !IO)
- ;
- Pragma = no_inline(Name, Arity),
- add_pred_marker("no_inline", Name, Arity, ImportStatus, Context,
- no_inline, [inline], !ModuleInfo, !IO)
- ;
- Pragma = obsolete(Name, Arity),
- add_pred_marker("obsolete", Name, Arity, ImportStatus,
- Context, obsolete, [], !ModuleInfo, !IO)
- ;
- % Handle pragma import decls later on (when we process
- % clauses and pragma c_code).
- Pragma = import(_, _, _, _, _)
- ;
- % Handle pragma export decls later on, after default
- % function modes have been added.
- Pragma = export(_, _, _, _)
- ;
- % Used for inter-module unused argument elimination.
- % This can only appear in .opt files.
- Pragma = unused_args(PredOrFunc, SymName, Arity, ModeNum,
- UnusedArgs),
- ( ImportStatus \= opt_imported ->
- prog_out__write_context(Context, !IO),
- io__write_string("Error: illegal use of pragma `unused_args'.\n",
- !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- add_pragma_unused_args(PredOrFunc, SymName, Arity, ModeNum,
- UnusedArgs, Context, !ModuleInfo, !IO)
- )
- ;
- Pragma = exceptions(PredOrFunc, SymName, Arity, ModeNum, ThrowStatus),
- ( ImportStatus \= opt_imported ->
- prog_out.write_context(Context, !IO),
- io.write_string("Error: illegal use of pragma `exceptions'.\n",
- !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- add_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum,
- ThrowStatus, Context, !ModuleInfo, !IO)
- )
- ;
- % Handle pragma type_spec decls later on (when we process
- % clauses).
- Pragma = type_spec(_, _, _, _, _, _, _, _)
- ;
- % Handle pragma fact_table decls later on (when we process
- % clauses -- since these decls take the place of clauses).
- Pragma = fact_table(_, _, _)
- ;
- % Handle pragma reserve_tag decls later on (when we process
- % clauses -- they need to be handled after the type definitions
- % have been added).
- Pragma = reserve_tag(_, _)
- ;
- Pragma = aditi(PredName, Arity),
- maybe_enable_aditi_compilation(!.Status, Context, !ModuleInfo, !IO),
- add_pred_marker("aditi", PredName, Arity, ImportStatus, Context,
- aditi, [], !ModuleInfo, !IO),
- add_stratified_pred("aditi", PredName, Arity, Context, !ModuleInfo, !IO)
- ;
- Pragma = base_relation(PredName, Arity),
- maybe_enable_aditi_compilation(!.Status, Context, !ModuleInfo, !IO),
- add_pred_marker("aditi", PredName, Arity, ImportStatus, Context, aditi,
- [], !ModuleInfo, !IO),
- add_pred_marker("base_relation", PredName, Arity, ImportStatus,
- Context, base_relation, [], !ModuleInfo, !IO),
- module_mark_as_external(PredName, Arity, Context, !ModuleInfo, !IO)
- ;
- Pragma = aditi_index(PredName, Arity, Index),
- add_base_relation_index(PredName, Arity, Index, ImportStatus,
- Context, !ModuleInfo, !IO)
- ;
- Pragma = naive(PredName, Arity),
- add_pred_marker("naive", PredName, Arity, ImportStatus,
- Context, naive, [psn], !ModuleInfo, !IO)
- ;
- Pragma = psn(PredName, Arity),
- add_pred_marker("psn", PredName, Arity, ImportStatus,
- Context, psn, [naive], !ModuleInfo, !IO)
- ;
- Pragma = aditi_memo(Name, Arity),
- add_pred_marker("aditi_memo", Name, Arity, ImportStatus,
- Context, aditi_memo, [aditi_no_memo], !ModuleInfo, !IO)
- ;
- Pragma = aditi_no_memo(PredName, Arity),
- add_pred_marker("aditi_no_memo", PredName, Arity, ImportStatus,
- Context, aditi_no_memo, [aditi_memo], !ModuleInfo, !IO)
- ;
- Pragma = supp_magic(PredName, Arity),
- add_pred_marker("supp_magic", PredName, Arity, ImportStatus,
- Context, supp_magic, [context], !ModuleInfo, !IO)
- ;
- Pragma = context(PredName, Arity),
- add_pred_marker("context", PredName, Arity, ImportStatus,
- Context, context, [supp_magic], !ModuleInfo, !IO)
- ;
- Pragma = owner(PredName, Arity, Owner),
- set_pred_owner(PredName, Arity, Owner, ImportStatus,
- Context, !ModuleInfo, !IO)
- ;
- Pragma = promise_pure(Name, Arity),
- add_pred_marker("promise_pure", Name, Arity, ImportStatus,
- Context, promised_pure, [], !ModuleInfo, !IO)
- ;
- Pragma = promise_semipure(Name, Arity),
- add_pred_marker("promise_semipure", Name, Arity, ImportStatus,
- Context, promised_semipure, [], !ModuleInfo, !IO)
- ;
- % Handle pragma termination_info decls later on, in pass 3 --
- % we need to add function default modes before handling
- % these pragmas
- Pragma = termination_info(_, _, _, _, _)
- ;
- % As for termination_info pragmas
- Pragma = termination2_info(_, _, _, _, _, _)
- ;
- Pragma = terminates(Name, Arity),
- add_pred_marker("terminates", Name, Arity, ImportStatus, Context,
- terminates, [check_termination, does_not_terminate], !ModuleInfo,
- !IO)
- ;
- Pragma = does_not_terminate(Name, Arity),
- add_pred_marker("does_not_terminate", Name, Arity, ImportStatus,
- Context, does_not_terminate, [check_termination, terminates],
- !ModuleInfo, !IO)
- ;
- Pragma = check_termination(Name, Arity),
- add_pred_marker("check_termination", Name, Arity, ImportStatus,
- Context, check_termination, [terminates, does_not_terminate],
- !ModuleInfo, !IO)
- ;
- Pragma = mode_check_clauses(Name, Arity),
- add_pred_marker("mode_check_clauses", Name, Arity, ImportStatus,
- Context, mode_check_clauses, [], !ModuleInfo, !IO),
-
- % Allowing the predicate to be inlined could lead to code generator
- % aborts. This is because the caller that inlines this predicate may
- % then push other code into the disjunction or switch's branches,
- % which would invalidate the instmap_deltas that the mode_check_clauses
- % feature prevents the recomputation of.
- add_pred_marker("mode_check_clauses", Name, Arity, ImportStatus,
- Context, no_inline, [inline], !ModuleInfo, !IO)
- ).
-add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !IO) :-
- Item = pred_or_func(_TypeVarSet, _InstVarSet, _ExistQVars,
- PredOrFunc, SymName, TypesAndModes, _WithType, _WithInst,
- _MaybeDet, _Cond, _Purity, _ClassContext),
- %
- % add default modes for function declarations, if necessary
- %
- (
- PredOrFunc = predicate
- ;
- PredOrFunc = function,
- list__length(TypesAndModes, Arity),
- adjust_func_arity(function, FuncArity, Arity),
- module_info_get_predicate_table(!.ModuleInfo, PredTable0),
- (
- predicate_table_search_func_sym_arity(PredTable0,
- is_fully_qualified, SymName, FuncArity, PredIds)
- ->
- predicate_table_get_preds(PredTable0, Preds0),
- maybe_add_default_func_modes(PredIds, Preds0, Preds),
- predicate_table_set_preds(Preds, PredTable0, PredTable),
- module_info_set_predicate_table(PredTable, !ModuleInfo)
- ;
- error("make_hlds.m: can't find func declaration")
- )
- ).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
- Item = promise(_, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
- Item = clause(_, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
- Item = inst_defn(_, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
- Item = mode_defn(_, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
- Item = pred_or_func_mode(_, _, _, _, _, _, _).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
- Item = nothing(_).
-add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
- Item = typeclass(_, _, _, _, _, _).
-add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
- Item = instance(Constraints, Name, Types, Body, VarSet,
- InstanceModuleName),
- !.Status = item_status(ImportStatus, _),
- ( Body = abstract ->
- make_status_abstract(ImportStatus, BodyStatus)
- ;
- BodyStatus = ImportStatus
- ),
- module_add_instance_defn(InstanceModuleName, Constraints, Name, Types,
- Body, VarSet, BodyStatus, Context, !ModuleInfo, !IO).
-
-%------------------------------------------------------------------------------
-
- % If a module_defn updates the import_status, return the new
- % status and whether uses of the following items must be module
- % qualified, otherwise fail.
-:- pred module_defn_update_import_status(module_defn::in, item_status::out)
- is semidet.
-
-module_defn_update_import_status(interface,
- item_status(exported, may_be_unqualified)).
-module_defn_update_import_status(implementation,
- item_status(local, may_be_unqualified)).
-module_defn_update_import_status(private_interface,
- item_status(exported_to_submodules, may_be_unqualified)).
-module_defn_update_import_status(imported(Section),
- item_status(imported(Section), may_be_unqualified)).
-module_defn_update_import_status(used(Section),
- item_status(imported(Section), must_be_qualified)).
-module_defn_update_import_status(opt_imported,
- item_status(opt_imported, must_be_qualified)).
-module_defn_update_import_status(abstract_imported,
- item_status(abstract_imported, must_be_qualified)).
-
-%-----------------------------------------------------------------------------%
-
- % If there are any Aditi procedures enable Aditi compilation.
- % If there are only imported Aditi procedures, magic.m still
- % needs to remove the `aditi' and `base_relation' markers
- % so that the procedures are not ignored by the code
- % generation annotation passes (e.g. arg_info.m).
-:- pred maybe_enable_aditi_compilation(item_status::in, term__context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-maybe_enable_aditi_compilation(_Status, Context, !ModuleInfo, !IO) :-
- globals__io_lookup_bool_option(aditi, Aditi, !IO),
- (
- Aditi = no,
- prog_out__write_context(Context, !IO),
- io__write_string("Error: compilation of Aditi procedures\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" requires the `--aditi' option.\n", !IO),
- io__set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- Aditi = yes,
- % There are Aditi procedures - enable Aditi code generation.
- module_info_set_do_aditi_compilation(!ModuleInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
- % dispatch on the different types of items
-
-:- pred add_item_clause(item::in, import_status::in, import_status::out,
- prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- Item = clause(VarSet, PredOrFunc, PredName, Args, Body),
- check_not_exported(!.Status, Context, "clause", !IO),
- GoalType = none,
- % at this stage we only need know that it's not a promise declaration
- module_add_clause(VarSet, PredOrFunc, PredName, Args, Body, !.Status,
- Context, GoalType, !ModuleInfo, !QualInfo, !IO).
-
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- Item = type_defn(_TVarSet, SymName, TypeParams, TypeDefn, _Cond),
- % If this is a solver type then we need to also add clauses
- % the compiler generated inst cast predicate (the declaration
- % for which was added in pass 1).
- (
- TypeDefn = solver_type(SolverTypeDetails, _MaybeUserEqComp)
- ->
- add_solver_type_clause_items(SymName, TypeParams, SolverTypeDetails,
- !Status, Context, !ModuleInfo, !QualInfo, !IO)
- ;
- true
- ).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
- Item = inst_defn(_, _, _, _, _).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
- Item = mode_defn(_, _, _, _, _).
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- Item = pred_or_func(_, _, _, PredOrFunc, SymName, TypesAndModes,
- _WithType, _WithInst, _, _, _, _),
- (
- PredOrFunc = predicate
- ;
- PredOrFunc = function,
- list__length(TypesAndModes, PredArity),
- adjust_func_arity(function, FuncArity, PredArity),
- maybe_check_field_access_function(SymName, FuncArity, !.Status,
- Context, !.ModuleInfo, !IO)
- ).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
- Item = pred_or_func_mode(_, _, _, _, _, _, _).
-add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
- Item = module_defn(_, Defn),
- ( Defn = version_numbers(ModuleName, ModuleVersionNumbers) ->
- %
- % Record the version numbers for each imported module
- % if smart recompilation is enabled.
- %
- apply_to_recompilation_info(
- (pred(RecompInfo0::in, RecompInfo::out) is det :-
- RecompInfo = RecompInfo0 ^ version_numbers ^
- map__elem(ModuleName) := ModuleVersionNumbers
- ),
- !QualInfo)
- ; module_defn_update_import_status(Defn, ItemStatus1) ->
- ItemStatus1 = item_status(!:Status, NeedQual),
- qual_info_get_mq_info(!.QualInfo, MQInfo0),
- mq_info_set_need_qual_flag(NeedQual, MQInfo0, MQInfo),
- qual_info_set_mq_info(MQInfo, !QualInfo)
- ;
- true
- ).
-add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- Item = pragma(Pragma),
- (
- Pragma = foreign_proc(Attributes, Pred, PredOrFunc,
- Vars, VarSet, PragmaImpl)
- ->
- module_add_pragma_foreign_proc(Attributes, Pred, PredOrFunc,
- Vars, VarSet, PragmaImpl, !.Status, Context,
- !ModuleInfo, !QualInfo, !IO)
- ;
- Pragma = import(Name, PredOrFunc, Modes, Attributes,
- C_Function)
- ->
- module_add_pragma_import(Name, PredOrFunc, Modes, Attributes,
- C_Function, !.Status, Context, !ModuleInfo, !QualInfo, !IO)
- ;
- Pragma = fact_table(Pred, Arity, File)
- ->
- module_add_pragma_fact_table(Pred, Arity, File, !.Status,
- Context, !ModuleInfo, !QualInfo, !IO)
- ;
- Pragma = tabled(Type, Name, Arity, PredOrFunc, Mode)
- ->
- globals__io_lookup_bool_option(type_layout, TypeLayout, !IO),
- (
- TypeLayout = yes,
- module_add_pragma_tabled(Type, Name, Arity, PredOrFunc,
- Mode, !.Status, Context, !ModuleInfo, !IO)
- ;
- TypeLayout = no,
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma ", !IO),
- EvalMethodS = eval_method_to_string(Type),
- io__write_string(EvalMethodS, !IO),
- io__write_string("' declaration requires the type_ctor_layout\n",
- !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" structures. Use " ++
- "the --type-layout flag to enable them.\n", !IO)
- )
- ;
- Pragma = type_spec(_, _, _, _, _, _, _, _)
- ->
- %
- % XXX For the Java back-end, `pragma type_spec' can
- % result in class names that exceed the limits on file
- % name length. So we ignore these pragmas for the
- % Java back-end.
- %
- globals__io_get_target(Target, !IO),
- ( Target = java ->
- true
- ;
- add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !IO)
- )
- ;
- Pragma = termination_info(PredOrFunc, SymName, ModeList,
- MaybeArgSizeInfo, MaybeTerminationInfo)
- ->
- add_pragma_termination_info(PredOrFunc, SymName, ModeList,
- MaybeArgSizeInfo, MaybeTerminationInfo, Context,
- !ModuleInfo, !IO)
- ;
- Pragma = termination2_info(PredOrFunc, SymName, ModeList,
- MaybeSuccessArgSizeInfo, MaybeFailureArgSizeInfo,
- MaybeTerminationInfo)
- ->
- add_pragma_termination2_info(PredOrFunc, SymName, ModeList,
- MaybeSuccessArgSizeInfo,
- MaybeFailureArgSizeInfo, MaybeTerminationInfo, Context,
- !ModuleInfo, !IO)
- ;
- Pragma = reserve_tag(TypeName, TypeArity)
- ->
- add_pragma_reserve_tag(TypeName, TypeArity, !.Status,
- Context, !ModuleInfo, !IO)
- ;
- Pragma = export(Name, PredOrFunc, Modes, C_Function)
- ->
- add_pragma_export(Name, PredOrFunc, Modes, C_Function,
- Context, !ModuleInfo, !IO)
- ;
- % don't worry about any pragma declarations other than the
- % clause-like pragmas (c_code, tabling and fact_table),
- % foreign_type and the termination_info pragma here,
- % since they've already been handled earlier, in pass 2
- true
- ).
-
-add_item_clause(promise(PromiseType, Goal, VarSet, UnivVars),
- !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- %
- % If the outermost universally quantified variables
- % are placed in the head of the dummy predicate, the
- % typechecker will avoid warning about unbound
- % type variables as this implicity adds a universal
- % quantification of the typevariables needed.
- %
- term__var_list_to_term_list(UnivVars, HeadVars),
-
- % extra error checking for promise ex declarations
- ( PromiseType \= true ->
- check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !IO)
- ;
- true
- ),
-
- % add as dummy predicate
- add_promise_clause(PromiseType, HeadVars, VarSet, Goal, Context,
- !.Status, !ModuleInfo, !QualInfo, !IO).
-
-add_item_clause(nothing(_), !Status, _, !ModuleInfo, !QualInfo, !IO).
-add_item_clause(typeclass(_, _, _, _, _, _), !Status, _, !ModuleInfo,
- !QualInfo, !IO).
-add_item_clause(instance(_, _, _, _, _, _), !Status, _, !ModuleInfo, !QualInfo,
- !IO).
-
-:- pred add_solver_type_clause_items(sym_name::in, list(type_param)::in,
- solver_type_details::in, import_status::in, import_status::out,
- prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-add_solver_type_clause_items(TypeSymName, TypeParams, SolverTypeDetails,
- !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
-
- Arity = length(TypeParams),
-
- AnyInst = SolverTypeDetails ^ any_inst,
- GroundInst = SolverTypeDetails ^ ground_inst,
-
- InAnyMode = in_mode(AnyInst),
- InGroundMode = in_mode(GroundInst),
-
- OutAnyMode = out_mode(AnyInst),
- OutGroundMode = out_mode(GroundInst),
-
- VarSet0 = varset__init,
- varset__new_var(VarSet0, X, VarSet1),
- varset__new_var(VarSet1, Y, VarSet),
-
- Attrs0 = default_attributes(c),
- some [!Attrs] (
- !:Attrs = Attrs0,
- set_may_call_mercury(will_not_call_mercury, !Attrs),
- set_thread_safe(thread_safe, !Attrs),
- set_terminates(terminates, !Attrs),
- Attrs = !.Attrs
- ),
-
- Impl = ordinary("Y = X;", yes(Context)),
-
- % The `func(in) = out(<i_ground>) is det' mode.
- %
- ToGroundRepnSymName = solver_to_ground_repn_symname(TypeSymName, Arity),
- ToGroundRepnArgs = [ pragma_var(X, "X", in_mode ),
- pragma_var(Y, "Y", OutGroundMode) ],
- ToGroundRepnForeignProc =
- foreign_proc(
- Attrs,
- ToGroundRepnSymName,
- function,
- ToGroundRepnArgs,
- VarSet,
- Impl
- ),
- ToGroundRepnItem = pragma(ToGroundRepnForeignProc),
- add_item_clause(ToGroundRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
-
- % The `func(in(any)) = out(<i_any>) is det' mode.
- %
- ToAnyRepnSymName = solver_to_any_repn_symname(TypeSymName, Arity),
- ToAnyRepnArgs = [ pragma_var(X, "X", in_any_mode),
- pragma_var(Y, "Y", OutAnyMode ) ],
- ToAnyRepnForeignProc =
- foreign_proc(
- Attrs,
- ToAnyRepnSymName,
- function,
- ToAnyRepnArgs,
- VarSet,
- Impl
- ),
- ToAnyRepnItem = pragma(ToAnyRepnForeignProc),
- add_item_clause(ToAnyRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
- !IO),
-
- % The `func(in(<i_ground>)) = out is det' mode.
- %
- FromGroundRepnSymName = repn_to_ground_solver_symname(TypeSymName, Arity),
- FromGroundRepnArgs = [ pragma_var(X, "X", InGroundMode),
- pragma_var(Y, "Y", out_mode) ],
- FromGroundRepnForeignProc =
- foreign_proc(
- Attrs,
- FromGroundRepnSymName,
- function,
- FromGroundRepnArgs,
- VarSet,
- Impl
- ),
- FromGroundRepnItem = pragma(FromGroundRepnForeignProc),
- add_item_clause(FromGroundRepnItem, !Status, Context, !ModuleInfo,
- !QualInfo, !IO),
-
- % The `func(in(<i_any>)) = out(any) is det' mode.
- %
- FromAnyRepnSymName = repn_to_any_solver_symname(TypeSymName, Arity),
- FromAnyRepnArgs = [ pragma_var(X, "X", InAnyMode ),
- pragma_var(Y, "Y", out_any_mode) ],
- FromAnyRepnForeignProc =
- foreign_proc(
- Attrs,
- FromAnyRepnSymName,
- function,
- FromAnyRepnArgs,
- VarSet,
- Impl
- ),
- FromAnyRepnItem = pragma(FromAnyRepnForeignProc),
- add_item_clause(FromAnyRepnItem, !Status, Context, !ModuleInfo, !QualInfo,
- !IO).
-
-%-----------------------------------------------------------------------------%
-
- % We need to "unparse" the sym_name to construct the properly
- % module qualified term.
- %
-:- func sym_name_and_args_to_term(sym_name, list(term(T)), prog_context) =
- term(T).
-
-sym_name_and_args_to_term(unqualified(Name), Xs, Context) =
- term__functor(term__atom(Name), Xs, Context).
-
-sym_name_and_args_to_term(qualified(ModuleNames, Name), Xs, Context) =
- sym_name_and_term_to_term(ModuleNames,
- term__functor(term__atom(Name), Xs, Context), Context).
-
-:- func sym_name_and_term_to_term(module_specifier, term(T), prog_context) =
- term(T).
-
-sym_name_and_term_to_term(unqualified(ModuleName), Term, Context) =
- term__functor(
- term__atom("."),
- [ term__functor(term__atom(ModuleName), [], Context), Term ],
- Context
- ).
-
-sym_name_and_term_to_term(qualified(ModuleNames, ModuleName), Term, Context) =
- term__functor(
- term__atom("."),
- [ sym_name_and_term_to_term(
- ModuleNames,
- term__functor(term__atom(ModuleName), [], Context),
- Context
- ),
- Term ],
- Context
- ).
-
-:- pred add_promise_clause(promise_type::in, list(term(prog_var_type))::in,
- prog_varset::in, goal::in, prog_context::in, import_status::in,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-add_promise_clause(PromiseType, HeadVars, VarSet, Goal, Context, Status,
- !ModuleInfo, !QualInfo, !IO) :-
- term__context_line(Context, Line),
- term__context_file(Context, File),
- string__format(prog_out__promise_to_string(PromiseType) ++
- "__%d__%s", [i(Line), s(File)], Name),
- %
- % Promise declarations are recorded as a predicate with a
- % goal_type of promise(X), where X is of promise_type. This
- % allows us to leverage off all the other checks in the
- % compiler that operate on predicates.
- %
- % :- promise all [A,B,R] ( R = A + B <=> R = B + A ).
- %
- % becomes
- %
- % promise__lineno_filename(A, B, R) :-
- % ( R = A + B <=> R = B + A ).
- %
- GoalType = promise(PromiseType) ,
- module_info_name(!.ModuleInfo, ModuleName),
- module_add_clause(VarSet, predicate, qualified(ModuleName, Name),
- HeadVars, Goal, Status, Context, GoalType, !ModuleInfo, !QualInfo, !IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred check_not_exported(import_status::in, prog_context::in, string::in,
- io::di, io::uo) is det.
-
-check_not_exported(Status, Context, Message, !IO) :-
- %
- % check that clauses are not exported
- %
- ( Status = exported ->
- prog_out__write_context(Context, !IO),
- string__append_list(["Warning: ", Message, " in module interface.\n"],
- WarningMessage),
- report_warning(WarningMessage, !IO)
- ;
- true
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_pragma_export(sym_name::in, pred_or_func::in, list(mode)::in,
- string::in, prog_context::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-add_pragma_export(Name, PredOrFunc, Modes, C_Function, Context, !ModuleInfo,
- !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, PredTable),
- list__length(Modes, Arity),
- (
- predicate_table_search_pf_sym_arity(PredTable,
- may_be_partially_qualified, PredOrFunc, Name,
- Arity, [PredId])
- ->
- predicate_table_get_preds(PredTable, Preds),
- map__lookup(Preds, PredId, PredInfo),
- pred_info_procedures(PredInfo, Procs),
- map__to_assoc_list(Procs, ExistingProcs),
- (
- get_procedure_matching_declmodes(ExistingProcs, Modes,
- !.ModuleInfo, ProcId)
- ->
- map__lookup(Procs, ProcId, ProcInfo),
- proc_info_declared_determinism(ProcInfo, MaybeDet),
- % We cannot catch those multi or nondet procedures that
- % don't have a determinism declaration until after
- % determinism analysis.
- (
- MaybeDet = yes(Det),
- ( Det = nondet ; Det = multidet )
- ->
- Pieces = [words("Error: "),
- fixed("`:- pragma export' declaration"),
- words("for a procedure that has"),
- words("a declared determinism of"),
- fixed(hlds_out.determinism_to_string(Det)
- ++ ".")
- ],
- error_util.write_error_pieces(Context, 0, Pieces, !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- module_info_get_pragma_exported_procs(!.ModuleInfo,
- PragmaExportedProcs0),
- NewExportedProc = pragma_exported_proc(PredId, ProcId,
- C_Function, Context),
- PragmaExportedProcs = [NewExportedProc | PragmaExportedProcs0],
- module_info_set_pragma_exported_procs(PragmaExportedProcs,
- !ModuleInfo)
- )
- ;
- undefined_mode_error(Name, Arity, Context,
- "`:- pragma export' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
- )
- ;
- undefined_pred_or_func_error(Name, Arity, Context,
- "`:- pragma export' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_pragma_reserve_tag(sym_name::in, arity::in, import_status::in,
- prog_context::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
- !IO) :-
- TypeCtor = TypeName - TypeArity,
- module_info_types(!.ModuleInfo, Types0),
- TypeStr = error_util__describe_sym_name_and_arity(
- TypeName / TypeArity),
- ErrorPieces1 = [
- words("In"),
- fixed("`pragma reserve_tag'"),
- words("declaration for"),
- fixed(TypeStr ++ ":")
- ],
- ( map__search(Types0, TypeCtor, TypeDefn0) ->
- hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
- hlds_data__get_type_defn_status(TypeDefn0, TypeStatus),
- (
- not (
- TypeStatus = PragmaStatus
- ;
- TypeStatus = abstract_exported,
- ( PragmaStatus = local
- ; PragmaStatus = exported_to_submodules
- )
- )
- ->
- error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
- ErrorPieces2 = [
- words("error: `reserve_tag' declaration must"),
- words("have the same visibility as the"),
- words("type definition.")
- ],
- error_util__write_error_pieces_not_first_line(Context, 0,
- ErrorPieces2, !IO),
- io__set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo)
-
- ;
- TypeBody0 = du_type(Body, _CtorTags0, _IsEnum0,
- MaybeUserEqComp, ReservedTag0, IsForeign)
- ->
- (
- ReservedTag0 = yes,
- % make doubly sure that we don't get any
- % spurious warnings with intermodule
- % optimization...
- TypeStatus \= opt_imported
- ->
- error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
- ErrorPieces2 = [
- words("warning: multiple"),
- fixed("`pragma reserved_tag'"),
- words("declarations for the same type.")
- ],
- error_util__write_error_pieces_not_first_line(Context, 0,
- ErrorPieces2, !IO)
- ;
- true
- ),
- %
- % We passed all the semantic checks.
- % Mark the type has having a reserved tag,
- % and recompute the constructor tags.
- %
- ReservedTag = yes,
- module_info_globals(!.ModuleInfo, Globals),
- assign_constructor_tags(Body, TypeCtor, ReservedTag, Globals,
- CtorTags, IsEnum),
- TypeBody = du_type(Body, CtorTags, IsEnum, MaybeUserEqComp,
- ReservedTag, IsForeign),
- hlds_data__set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
- map__set(Types0, TypeCtor, TypeDefn, Types),
- module_info_set_types(Types, !ModuleInfo)
- ;
- error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
- ErrorPieces2 = [
- words("error:"),
- fixed(TypeStr),
- words("is not a discriminated union type.")
- ],
- error_util__write_error_pieces_not_first_line(Context, 0,
- ErrorPieces2, !IO),
- io__set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo)
- )
- ;
- error_util__write_error_pieces(Context, 0, ErrorPieces1, !IO),
- ErrorPieces2 = [
- words("error: undefined type"),
- fixed(TypeStr ++ ".")
- ],
- error_util__write_error_pieces_not_first_line(Context, 0, ErrorPieces2,
- !IO),
- io__set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_pragma_unused_args(pred_or_func::in, sym_name::in, arity::in,
- mode_num::in, list(int)::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-add_pragma_unused_args(PredOrFunc, SymName, Arity, ModeNum, UnusedArgs,
- Context, !ModuleInfo, !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, Preds),
- (
- predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
- PredOrFunc, SymName, Arity, [PredId])
- ->
- module_info_unused_arg_info(!.ModuleInfo, UnusedArgInfo0),
- % convert the mode number to a proc_id
- proc_id_to_int(ProcId, ModeNum),
- map__set(UnusedArgInfo0, proc(PredId, ProcId), UnusedArgs,
- UnusedArgInfo),
- module_info_set_unused_arg_info(UnusedArgInfo, !ModuleInfo)
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("Internal compiler error: " ++
- "unknown predicate in `pragma unused_args'.\n", !IO),
- module_info_incr_errors(!ModuleInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_pragma_exceptions(pred_or_func::in, sym_name::in, arity::in,
- mode_num::in, exception_status::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-add_pragma_exceptions(PredOrFunc, SymName, Arity, ModeNum, ThrowStatus,
- _Context, !ModuleInfo, !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, Preds),
- (
- predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
- PredOrFunc, SymName, Arity, [PredId])
- ->
- module_info_exception_info(!.ModuleInfo, ExceptionsInfo0),
- % convert the mode number to a proc_id
- proc_id_to_int(ProcId, ModeNum),
- map__set(ExceptionsInfo0, proc(PredId, ProcId), ThrowStatus,
- ExceptionsInfo),
- module_info_set_exception_info(ExceptionsInfo, !ModuleInfo)
- ;
- % XXX We'll just ignore this for the time being -
- % it causes errors with transitive-intermodule optimization.
- %prog_out__write_context(Context, !IO),
- %io__write_string("Internal compiler error: " ++
- % "unknown predicate in `pragma exceptions'.\n", !IO),
- %module_info_incr_errors(!ModuleInfo)
- true
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_pragma_type_spec(pragma_type::in(type_spec), term__context::in,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !IO) :-
- Pragma = type_spec(SymName, _, Arity, MaybePredOrFunc, _, _, _, _),
- module_info_get_predicate_table(!.ModuleInfo, Preds),
- (
- (
- MaybePredOrFunc = yes(PredOrFunc),
- adjust_func_arity(PredOrFunc, Arity, PredArity),
- predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
- PredOrFunc, SymName, PredArity, PredIds)
- ;
- MaybePredOrFunc = no,
- predicate_table_search_sym_arity(Preds, is_fully_qualified,
- SymName, Arity, PredIds)
- ),
- PredIds \= []
- ->
- list__foldl3(add_pragma_type_spec_2(Pragma, Context), PredIds,
- !ModuleInfo, !QualInfo, !IO)
- ;
- undefined_pred_or_func_error(SymName, Arity, Context,
- "`:- pragma type_spec' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
- ).
-
-:- pred add_pragma_type_spec_2(pragma_type::in(type_spec), prog_context::in,
- pred_id::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-add_pragma_type_spec_2(Pragma0, Context, PredId, !ModuleInfo, !QualInfo,
- !IO) :-
- Pragma0 = type_spec(SymName, SpecName, Arity, _, MaybeModes, Subst,
- TVarSet0, ExpandedItems),
- module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
- handle_pragma_type_spec_subst(Context, Subst, PredInfo0,
- TVarSet0, TVarSet, Types, ExistQVars, ClassContext, SubstOk,
- !ModuleInfo, !IO),
- (
- SubstOk = yes(RenamedSubst),
- pred_info_procedures(PredInfo0, Procs0),
- handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes,
- ProcIds, Procs0, Procs, ModesOk, !ModuleInfo, !IO),
- globals__io_lookup_bool_option(user_guided_type_specialization,
- DoTypeSpec, !IO),
- globals__io_lookup_bool_option(smart_recompilation, Smart, !IO),
- (
- ModesOk = yes,
- % Even if we aren't doing type specialization, we need
- % to create the interface procedures for local
- % predicates to check the type-class correctness of
- % the requested specializations.
- %
- % If we're doing smart recompilation we need to record
- % the pragmas even if we aren't doing type
- % specialization to avoid problems with differing
- % output for the recompilation tests in debugging
- % grades.
- %
- ( DoTypeSpec = yes
- ; \+ pred_info_is_imported(PredInfo0)
- ; Smart = yes
- )
- ->
- %
- % Build a clause to call the old predicate with the
- % specified types to force the specialization.
- % For imported predicates this forces the creation
- % of the proper interface.
- %
- PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
- adjust_func_arity(PredOrFunc, Arity, PredArity),
- varset__init(ArgVarSet0),
- make_n_fresh_vars("HeadVar__", PredArity, Args,
- ArgVarSet0, ArgVarSet),
- % XXX We could use explicit type qualifications here
- % for the argument types, but explicit type
- % qualification doesn't work correctly with type
- % inference due to a bug somewhere in typecheck.m
- % -- the explicitly declared types are not kept in
- % sync with the predicate's tvarset after the first
- % pass of type checking.
- % map__from_corresponding_lists(Args, Types, VarTypes0)
- map__init(VarTypes0),
- goal_info_init(GoalInfo0),
- set__list_to_set(Args, NonLocals),
- goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1),
- goal_info_set_context(GoalInfo1, Context, GoalInfo),
-
- %
- % We don't record the called predicate as used -- it
- % is only used if there is some other call. This call
- % is only used to make higher_order.m generate
- % the interface for the type specialized procedure, and
- % will be removed by higher_order.m after that is done.
- %
- do_construct_pred_or_func_call(PredId, PredOrFunc,
- SymName, Args, GoalInfo, Goal),
- Clause = clause(ProcIds, Goal, mercury, Context),
- rtti_varmaps_init(RttiVarMaps),
- map__init(TVarNameMap),
- HasForeignClauses = no,
- set_clause_list([Clause], ClausesRep),
- Clauses = clauses_info(ArgVarSet, VarTypes0, TVarNameMap,
- VarTypes0, Args, ClausesRep, RttiVarMaps, HasForeignClauses),
- pred_info_get_markers(PredInfo0, Markers0),
- add_marker(calls_are_fully_qualified, Markers0, Markers),
- map__init(Proofs),
- map__init(ConstraintMap),
-
- ( pred_info_is_imported(PredInfo0) ->
- Status = opt_imported
- ;
- pred_info_import_status(PredInfo0, Status)
- ),
-
- ModuleName = pred_info_module(PredInfo0),
- pred_info_get_aditi_owner(PredInfo0, Owner),
- pred_info_get_origin(PredInfo0, OrigOrigin),
- SubstDesc = list__map(subst_desc, Subst),
- Origin = transformed(type_specialization(SubstDesc),
- OrigOrigin, PredId),
- pred_info_init(ModuleName, SpecName, PredArity, PredOrFunc,
- Context, Origin, Status, none, Markers, Types, TVarSet,
- ExistQVars, ClassContext, Proofs, ConstraintMap, Owner,
- Clauses, NewPredInfo0),
- pred_info_set_procedures(Procs, NewPredInfo0, NewPredInfo),
- module_info_get_predicate_table(!.ModuleInfo, PredTable0),
- predicate_table_insert(NewPredInfo, NewPredId,
- PredTable0, PredTable),
- module_info_set_predicate_table(PredTable,
- !ModuleInfo),
-
- %
- % Record the type specialisation in the module_info.
- %
- module_info_type_spec_info(!.ModuleInfo, TypeSpecInfo0),
- TypeSpecInfo0 = type_spec_info(ProcsToSpec0,
- ForceVersions0, SpecMap0, PragmaMap0),
- list__map((pred(ProcId::in, PredProcId::out) is det :-
- PredProcId = proc(PredId, ProcId)
- ), ProcIds, PredProcIds),
- set__insert_list(ProcsToSpec0, PredProcIds,
- ProcsToSpec),
- set__insert(ForceVersions0, NewPredId, ForceVersions),
-
- ( Status = opt_imported ->
- % For imported predicates dead_proc_elim.m
- % needs to know that if the original predicate
- % is used, the predicate to force the
- % production of the specialised interface is
- % also used.
- multi_map__set(SpecMap0, PredId, NewPredId, SpecMap)
- ;
- SpecMap = SpecMap0
- ),
- Pragma = type_spec(SymName, SpecName, Arity, yes(PredOrFunc),
- MaybeModes, map__to_assoc_list(RenamedSubst), TVarSet,
- ExpandedItems),
- multi_map__set(PragmaMap0, PredId, Pragma, PragmaMap),
- TypeSpecInfo = type_spec_info(ProcsToSpec, ForceVersions, SpecMap,
- PragmaMap),
- module_info_set_type_spec_info(TypeSpecInfo,
- !ModuleInfo),
-
- status_is_imported(Status, IsImported),
- (
- IsImported = yes,
- ItemType = pred_or_func_to_item_type(PredOrFunc),
- apply_to_recompilation_info(
- recompilation__record_expanded_items(
- item_id(ItemType, SymName - Arity), ExpandedItems),
- !QualInfo)
- ;
- IsImported = no
- )
- ;
- true
- )
- ;
- SubstOk = no
- ).
-
-:- func subst_desc(pair(tvar, type)) = pair(int, type).
-
-subst_desc(TVar - Type) = var_to_int(TVar) - Type.
-
- % Check that the type substitution for a `:- pragma type_spec'
- % declaration is valid.
- % A type substitution is invalid if:
- % - it substitutes unknown type variables
- % - it substitutes existentially quantified type variables
- % Type substitutions are also invalid if the replacement types are
- % not ground, however this is a (hopefully temporary) limitation
- % of the current implementation, so it only results in a warning.
-:- pred handle_pragma_type_spec_subst(prog_context::in,
- assoc_list(tvar, type)::in, pred_info::in, tvarset::in, tvarset::out,
- list(type)::out, existq_tvars::out, prog_constraints::out,
- maybe(tsubst)::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-handle_pragma_type_spec_subst(Context, Subst, PredInfo0, TVarSet0, TVarSet,
- Types, ExistQVars, ClassContext, SubstOk, !ModuleInfo, !IO) :-
- assoc_list__keys(Subst, VarsToSub),
- (
- Subst = []
- ->
- error("handle_pragma_type_spec_subst: empty substitution")
- ;
- find_duplicate_list_elements(VarsToSub, MultiSubstVars0),
- MultiSubstVars0 \= []
- ->
- list__sort_and_remove_dups(MultiSubstVars0, MultiSubstVars),
- report_multiple_subst_vars(PredInfo0, Context, TVarSet0,
- MultiSubstVars, !IO),
- module_info_incr_errors(!ModuleInfo),
- io__set_exit_status(1, !IO),
- ExistQVars = [],
- Types = [],
- ClassContext = constraints([], []),
- varset__init(TVarSet),
- SubstOk = no
- ;
- pred_info_typevarset(PredInfo0, CalledTVarSet),
- varset__create_name_var_map(CalledTVarSet, NameVarIndex0),
- list__filter((pred(Var::in) is semidet :-
- varset__lookup_name(TVarSet0, Var, VarName),
- \+ map__contains(NameVarIndex0, VarName)
- ), VarsToSub, UnknownVarsToSub),
- (
- UnknownVarsToSub = [],
- % Check that the substitution is not recursive.
- set__list_to_set(VarsToSub, VarsToSubSet),
-
- assoc_list__values(Subst, SubstTypes0),
- term__vars_list(SubstTypes0, TVarsInSubstTypes0),
- set__list_to_set(TVarsInSubstTypes0,
- TVarsInSubstTypes),
-
- set__intersect(TVarsInSubstTypes, VarsToSubSet, RecSubstTVars0),
- set__to_sorted_list(RecSubstTVars0, RecSubstTVars),
-
- ( RecSubstTVars = [] ->
- map__init(TVarRenaming0),
- list__append(VarsToSub, TVarsInSubstTypes0, VarsToReplace),
-
- get_new_tvars(VarsToReplace, TVarSet0, CalledTVarSet, TVarSet,
- NameVarIndex0, _, TVarRenaming0, TVarRenaming),
-
- % Check that none of the existentially
- % quantified variables were substituted.
- map__apply_to_list(VarsToSub, TVarRenaming, RenamedVarsToSub),
- pred_info_get_exist_quant_tvars(PredInfo0, ExistQVars),
- list__filter((pred(RenamedVar::in) is semidet :-
- list__member(RenamedVar, ExistQVars)
- ), RenamedVarsToSub, SubExistQVars),
- (
- SubExistQVars = [],
- map__init(TypeSubst0),
- term__apply_variable_renaming_to_list(SubstTypes0,
- TVarRenaming, SubstTypes),
- assoc_list__from_corresponding_lists(RenamedVarsToSub,
- SubstTypes, SubAL),
- list__foldl(map_set_from_pair, SubAL,
- TypeSubst0, TypeSubst),
-
- % Apply the substitution.
- pred_info_arg_types(PredInfo0, Types0),
- pred_info_get_class_context(PredInfo0, ClassContext0),
- term__apply_rec_substitution_to_list(Types0, TypeSubst,
- Types),
- apply_rec_subst_to_prog_constraints(TypeSubst,
- ClassContext0, ClassContext),
- SubstOk = yes(TypeSubst)
- ;
- SubExistQVars = [_ | _],
- report_subst_existq_tvars(PredInfo0, Context,
- SubExistQVars, !IO),
- io__set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo),
- Types = [],
- ClassContext = constraints([], []),
- SubstOk = no
- )
- ;
- report_recursive_subst(PredInfo0, Context, TVarSet0,
- RecSubstTVars, !IO),
- io__set_exit_status(1, !IO),
- module_info_incr_errors(!ModuleInfo),
- ExistQVars = [],
- Types = [],
- ClassContext = constraints([], []),
- varset__init(TVarSet),
- SubstOk = no
- )
- ;
- UnknownVarsToSub = [_ | _],
- report_unknown_vars_to_subst(PredInfo0, Context, TVarSet0,
- UnknownVarsToSub, !IO),
- module_info_incr_errors(!ModuleInfo),
- io__set_exit_status(1, !IO),
- ExistQVars = [],
- Types = [],
- ClassContext = constraints([], []),
- varset__init(TVarSet),
- SubstOk = no
- )
- ).
-
-:- pred map_set_from_pair(pair(K, V)::in, map(K, V)::in, map(K, V)::out)
- is det.
-
-map_set_from_pair(K - V, !Map) :-
- svmap__set(K, V, !Map).
-
-:- pred find_duplicate_list_elements(list(T)::in, list(T)::out) is det.
-
-find_duplicate_list_elements([], []).
-find_duplicate_list_elements([H | T], Vars) :-
- find_duplicate_list_elements(T, Vars0),
- ( list__member(H, T) ->
- Vars = [H | Vars0]
- ;
- Vars = Vars0
- ).
-
-:- pred report_subst_existq_tvars(pred_info::in, prog_context::in,
- list(tvar)::in, io::di, io::uo) is det.
-
-report_subst_existq_tvars(PredInfo0, Context, SubExistQVars, !IO) :-
- report_pragma_type_spec(PredInfo0, Context, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" error: the substitution includes the existentially\n",
- !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" quantified type ", !IO),
- pred_info_typevarset(PredInfo0, TVarSet),
- report_variables(SubExistQVars, TVarSet, !IO),
- io__write_string(".\n", !IO).
-
-:- pred report_recursive_subst(pred_info::in, prog_context::in, tvarset::in,
- list(tvar)::in, io::di, io::uo) is det.
-
-report_recursive_subst(PredInfo0, Context, TVarSet, RecursiveVars, !IO) :-
- report_pragma_type_spec(PredInfo0, Context, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" error: ", !IO),
- report_variables(RecursiveVars, TVarSet, !IO),
- ( RecursiveVars = [_] ->
- io__write_string(" occurs\n", !IO)
- ;
- io__write_string(" occur\n", !IO)
- ),
- prog_out__write_context(Context, !IO),
- io__write_string(" on both sides of the substitution.\n", !IO).
-
-:- pred report_multiple_subst_vars(pred_info::in, prog_context::in,
- tvarset::in, list(tvar)::in, io::di, io::uo) is det.
-
-report_multiple_subst_vars(PredInfo0, Context, TVarSet, MultiSubstVars, !IO) :-
- report_pragma_type_spec(PredInfo0, Context, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" error: ", !IO),
- report_variables(MultiSubstVars, TVarSet, !IO),
- ( MultiSubstVars = [_] ->
- io__write_string(" has ", !IO)
- ;
- io__write_string(" have ", !IO)
- ),
- io__write_string("multiple replacement types.\n", !IO).
-
-:- pred report_unknown_vars_to_subst(pred_info::in, prog_context::in,
- tvarset::in, list(tvar)::in, io::di, io::uo) is det.
-
-report_unknown_vars_to_subst(PredInfo0, Context, TVarSet, UnknownVars, !IO) :-
- report_pragma_type_spec(PredInfo0, Context, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" error: ", !IO),
- report_variables(UnknownVars, TVarSet, !IO),
- ( UnknownVars = [_] ->
- io__write_string(" does not ", !IO)
- ;
- io__write_string(" do not ", !IO)
- ),
- PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
- (
- PredOrFunc = predicate,
- Decl = "`:- pred'"
- ;
- PredOrFunc = function,
- Decl = "`:- func'"
- ),
- io__write_string("occur in the ", !IO),
- io__write_string(Decl, !IO),
- io__write_string(" declaration.\n", !IO).
-
-:- pred report_pragma_type_spec(pred_info::in, term__context::in,
- io::di, io::uo) is det.
-
-report_pragma_type_spec(PredInfo0, Context, !IO) :-
- Module = pred_info_module(PredInfo0),
- Name = pred_info_name(PredInfo0),
- Arity = pred_info_orig_arity(PredInfo0),
- PredOrFunc = pred_info_is_pred_or_func(PredInfo0),
- prog_out__write_context(Context, !IO),
- io__write_string("In `:- pragma type_spec' declaration for ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc,
- qualified(Module, Name)/Arity, !IO),
- io__write_string(":\n", !IO).
-
-:- pred report_variables(list(tvar)::in, tvarset::in, io::di, io::uo) is det.
-
-report_variables(SubExistQVars, VarSet, !IO) :-
- ( SubExistQVars = [_] ->
- io__write_string("variable `", !IO)
- ;
- io__write_string("variables `", !IO)
- ),
- mercury_output_vars(SubExistQVars, VarSet, no, !IO),
- io__write_string("'", !IO).
-
- % Check that the mode list for a `:- pragma type_spec' declaration
- % specifies a known procedure.
-:- pred handle_pragma_type_spec_modes(sym_name::in, arity::in,
- prog_context::in, maybe(list(mode))::in, list(proc_id)::out,
- proc_table::in, proc_table::out, bool::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-handle_pragma_type_spec_modes(SymName, Arity, Context, MaybeModes, ProcIds,
- !Procs, ModesOk, !ModuleInfo, !IO) :-
- (
- MaybeModes = yes(Modes),
- map__to_assoc_list(!.Procs, ExistingProcs),
- (
- get_procedure_matching_argmodes(ExistingProcs, Modes,
- !.ModuleInfo, ProcId)
- ->
- map__lookup(!.Procs, ProcId, ProcInfo),
- map__det_insert(map__init, ProcId, ProcInfo, !:Procs),
- ProcIds = [ProcId],
- ModesOk = yes
- ;
- ProcIds = [],
- module_info_incr_errors(!ModuleInfo),
- undefined_mode_error(SymName, Arity, Context,
- "`:- pragma type_spec' declaration", !IO),
- ModesOk = no
- )
- ;
- MaybeModes = no,
- map__keys(!.Procs, ProcIds),
- ModesOk = yes
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_pragma_termination2_info(pred_or_func::in, sym_name::in,
- list(mode)::in, maybe(pragma_constr_arg_size_info)::in,
- maybe(pragma_constr_arg_size_info)::in,
- maybe(pragma_termination_info)::in, prog_context::in, module_info::in,
- module_info::out, io::di, io::uo) is det.
-add_pragma_termination2_info(PredOrFunc, SymName, ModeList,
- MaybePragmaSuccessArgSizeInfo, MaybePragmaFailureArgSizeInfo,
- MaybePragmaTerminationInfo,
- Context, !ModuleInfo, !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, Preds),
- list.length(ModeList, Arity),
- (
- predicate_table_search_pf_sym_arity(Preds,
- is_fully_qualified, PredOrFunc, SymName, Arity, PredIds),
- PredIds \= []
- ->
- ( PredIds = [PredId] ->
- module_info_preds(!.ModuleInfo, PredTable0),
- map.lookup(PredTable0, PredId, PredInfo0),
- pred_info_procedures(PredInfo0, ProcTable0),
- map.to_assoc_list(ProcTable0, ProcList),
- (
- get_procedure_matching_declmodes(ProcList,
- ModeList, !.ModuleInfo, ProcId)
- ->
- map.lookup(ProcTable0, ProcId, ProcInfo0),
- add_context_to_constr_termination_info(
- MaybePragmaTerminationInfo, Context,
- MaybeTerminationInfo),
-
- some [!TermInfo] (
- proc_info_get_termination2_info(ProcInfo0, !:TermInfo),
-
- !:TermInfo = !.TermInfo ^ import_success :=
- MaybePragmaSuccessArgSizeInfo,
- !:TermInfo = !.TermInfo ^ import_failure :=
- MaybePragmaFailureArgSizeInfo,
- !:TermInfo = !.TermInfo ^ term_status :=
- MaybeTerminationInfo,
-
- proc_info_set_termination2_info(!.TermInfo,
- ProcInfo0, ProcInfo)
- ),
- map__det_update(ProcTable0, ProcId, ProcInfo,
- ProcTable),
- pred_info_set_procedures(ProcTable, PredInfo0,
- PredInfo),
- map__det_update(PredTable0, PredId, PredInfo,
- PredTable),
- module_info_set_preds(PredTable, !ModuleInfo)
- ;
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io.write_string(
- "Error: `:- pragma termination2_info' " ++
- "declaration for undeclared mode of ", !IO),
- hlds_out.write_simple_call_id(PredOrFunc,
- SymName/Arity, !IO),
- io.write_string(".\n", !IO)
- )
- ;
- prog_out.write_context(Context, !IO),
- io.write_string("Error: ambiguous predicate name ", !IO),
- hlds_out.write_simple_call_id(PredOrFunc, SymName/Arity, !IO),
- io.nl(!IO),
- prog_out.write_context(Context, !IO),
- io.write_string(
- " in `pragma termination2_info'.\n", !IO),
- module_info_incr_errors(!ModuleInfo)
- )
- ;
- % XXX This happens in `.trans_opt' files sometimes --
- % so just ignore it
- true
- /***
- **** undefined_pred_or_func_error(
- **** SymName, Arity, Context,
- **** "`:- pragma termination2_info' declaration"),
- **** { module_info_incr_errors(!ModuleInfo) }
- ***/
- ).
-
-%------------------------------------------------------------------------------%
-
-:- pred add_pragma_termination_info(pred_or_func::in, sym_name::in,
- list(mode)::in, maybe(pragma_arg_size_info)::in,
- maybe(pragma_termination_info)::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-add_pragma_termination_info(PredOrFunc, SymName, ModeList,
- MaybePragmaArgSizeInfo, MaybePragmaTerminationInfo,
- Context, !ModuleInfo, !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, Preds),
- list__length(ModeList, Arity),
- (
- predicate_table_search_pf_sym_arity(Preds, is_fully_qualified,
- PredOrFunc, SymName, Arity, PredIds),
- PredIds \= []
- ->
- ( PredIds = [PredId] ->
- module_info_preds(!.ModuleInfo, PredTable0),
- map__lookup(PredTable0, PredId, PredInfo0),
- pred_info_procedures(PredInfo0, ProcTable0),
- map__to_assoc_list(ProcTable0, ProcList),
- (
- get_procedure_matching_declmodes(ProcList, ModeList,
- !.ModuleInfo, ProcId)
- ->
- add_context_to_arg_size_info(MaybePragmaArgSizeInfo,
- Context, MaybeArgSizeInfo),
- add_context_to_termination_info(MaybePragmaTerminationInfo,
- Context, MaybeTerminationInfo),
- map__lookup(ProcTable0, ProcId, ProcInfo0),
- proc_info_set_maybe_arg_size_info(MaybeArgSizeInfo,
- ProcInfo0, ProcInfo1),
- proc_info_set_maybe_termination_info(MaybeTerminationInfo,
- ProcInfo1, ProcInfo),
- map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
- pred_info_set_procedures(ProcTable, PredInfo0, PredInfo),
- map__det_update(PredTable0, PredId, PredInfo, PredTable),
- module_info_set_preds(PredTable, !ModuleInfo)
- ;
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma termination_info' ", !IO),
- io__write_string("declaration for undeclared mode of ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, SymName/Arity, !IO),
- io__write_string(".\n", !IO)
- )
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("Error: ambiguous predicate name ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, SymName/Arity, !IO),
- io__nl(!IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" in `pragma termination_info'.\n", !IO),
- module_info_incr_errors(!ModuleInfo)
- )
- ;
- % XXX This happens in `.trans_opt' files sometimes --
- % so just ignore it
- true
- % undefined_pred_or_func_error(SymName, Arity, Context,
- % "`:- pragma termination_info' declaration",
- % !IO),
- % module_info_incr_errors(!ModuleInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_stratified_pred(string::in, sym_name::in, arity::in,
- term__context::in, module_info::in, module_info::out, io::di, io::uo)
- is det.
-
-add_stratified_pred(PragmaName, Name, Arity, Context, !ModuleInfo, !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, PredTable0),
- (
- predicate_table_search_sym_arity(PredTable0, is_fully_qualified,
- Name, Arity, PredIds)
- ->
- module_info_stratified_preds(!.ModuleInfo, StratPredIds0),
- set__insert_list(StratPredIds0, PredIds, StratPredIds),
- module_info_set_stratified_preds(StratPredIds, !ModuleInfo)
- ;
- string__append_list(["`:- pragma ", PragmaName, "' declaration"],
- Description),
- undefined_pred_or_func_error(Name, Arity, Context, Description, !IO),
- module_info_incr_errors(!ModuleInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
- % add_pred_marker(ModuleInfo0, PragmaName, Name, Arity, Status,
- % Context, Marker, ConflictMarkers, ModuleInfo, !IO):
- %
- % Adds Marker to the marker list of the pred(s) with give Name and
- % Arity, updating the ModuleInfo. If the named pred does not exist,
- % or the pred already has a marker in ConflictMarkers, report
- % an error.
- %
-:- pred add_pred_marker(string::in, sym_name::in, arity::in, import_status::in,
- prog_context::in, marker::in, list(marker)::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-add_pred_marker(PragmaName, Name, Arity, Status, Context, Marker,
- ConflictMarkers, !ModuleInfo, !IO) :-
- ( marker_must_be_exported(Marker) ->
- MustBeExported = yes
- ;
- MustBeExported = no
- ),
- do_add_pred_marker(PragmaName, Name, Arity, Status, MustBeExported,
- Context, add_marker_pred_info(Marker), !ModuleInfo, PredIds, !IO),
- module_info_preds(!.ModuleInfo, Preds),
- pragma_check_markers(Preds, PredIds, ConflictMarkers, Conflict),
- (
- Conflict = yes,
- pragma_conflict_error(Name, Arity, Context, PragmaName, !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- Conflict = no
- ).
-
-:- pred set_pred_owner(sym_name::in, arity::in, string::in, import_status::in,
- prog_context::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-set_pred_owner(Name, Arity, Owner, Status, Context, !ModuleInfo, !IO) :-
- SetOwner = (pred(PredInfo0::in, PredInfo::out) is det :-
- pred_info_set_aditi_owner(Owner, PredInfo0, PredInfo)
- ),
- MarkerMustBeExported = yes,
- do_add_pred_marker("owner", Name, Arity, Status, MarkerMustBeExported,
- Context, SetOwner, !ModuleInfo, _, !IO).
-
-:- pred add_base_relation_index(sym_name::in, arity::in, index_spec::in,
- import_status::in, prog_context::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-add_base_relation_index(Name, Arity, Index, Status, Context, !ModuleInfo,
- !IO) :-
- AddIndex = (pred(PredInfo0::in, PredInfo::out) is det :-
- pred_info_get_indexes(PredInfo0, Indexes0),
- Indexes = [Index | Indexes0],
- pred_info_set_indexes(Indexes, PredInfo0, PredInfo)
- ),
- MarkerMustBeExported = yes,
- do_add_pred_marker("aditi_index", Name, Arity, Status,
- MarkerMustBeExported, Context, AddIndex, !ModuleInfo, PredIds, !IO),
- Index = index_spec(_, Attrs),
- list__foldl(check_index_attribute(Name, Arity, Context), Attrs, !IO),
- list__foldl(
- check_index_attribute_pred(!.ModuleInfo, Name, Arity, Context, Attrs),
- PredIds, !IO).
-
- % Check that the index attributes are legal for the predicate's arity.
-:- pred check_index_attribute(sym_name::in, arity::in, term__context::in,
- int::in, io::di, io::uo) is det.
-
-check_index_attribute(Name, Arity, Context, Attr, !IO) :-
- (
- Attr > 0,
- Attr =< Arity
- ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("In `:- pragma aditi_index' declaration for `", !IO),
- prog_out__write_sym_name_and_arity(Name/Arity, !IO),
- io__write_string("':\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" attribute ", !IO),
- io__write_int(Attr, !IO),
- io__write_string(" is out of range.\n", !IO),
- io__set_exit_status(1, !IO)
- ).
-
- % Check that a relation with an index specified is a base relation
- % and that the indexed attributes do not include aditi__states.
-:- pred check_index_attribute_pred(module_info::in, sym_name::in, arity::in,
- term__context::in, list(int)::in, pred_id::in, io::di, io::uo) is det.
-
-check_index_attribute_pred(ModuleInfo, Name, Arity, Context, Attrs, PredId,
- !IO) :-
- module_info_pred_info(ModuleInfo, PredId, PredInfo),
- pred_info_get_markers(PredInfo, Markers),
- PredOrFunc = pred_info_is_pred_or_func(PredInfo),
- ( check_marker(Markers, base_relation) ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma aditi_index' declaration", !IO),
- io__nl(!IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" for ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, Name/Arity, !IO),
- io__write_string(" without preceding\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" `:- pragma base_relation' declaration.\n", !IO),
- io__set_exit_status(1, !IO)
- ),
-
- pred_info_arg_types(PredInfo, ArgTypes),
- AttrIsAditiState = (pred(Attr::in) is semidet :-
- list__index0(ArgTypes, Attr, ArgType),
- type_is_aditi_state(ArgType)
- ),
- list__filter(AttrIsAditiState, Attrs, AditiStateAttrs),
-
- ( AditiStateAttrs = [AditiStateAttr | _] ->
- % Indexing on aditi__state attributes is pretty silly,
- % since they're removed by magic.m.
- prog_out__write_context(Context, !IO),
- io__write_string("In `:- pragma aditi_index' declaration for ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, Name/Arity, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" attribute ", !IO),
- io__write_int(AditiStateAttr, !IO),
- io__write_string(" is an aditi__state.\n", !IO),
- io__set_exit_status(1, !IO)
- ;
- true
- ).
-
-:- type add_marker_pred_info == pred(pred_info, pred_info).
-:- inst add_marker_pred_info == (pred(in, out) is det).
-
-:- pred do_add_pred_marker(string::in, sym_name::in, arity::in,
- import_status::in, bool::in, term__context::in,
- add_marker_pred_info::in(add_marker_pred_info),
- module_info::in, module_info::out, list(pred_id)::out,
- io::di, io::uo) is det.
-
-do_add_pred_marker(PragmaName, Name, Arity, Status, MustBeExported, Context,
- UpdatePredInfo, !ModuleInfo, PredIds, !IO) :-
- ( get_matching_pred_ids(!.ModuleInfo, Name, Arity, PredIds0) ->
- PredIds = PredIds0,
- module_info_get_predicate_table(!.ModuleInfo, PredTable0),
- predicate_table_get_preds(PredTable0, Preds0),
-
- pragma_add_marker(PredIds, UpdatePredInfo, Status,
- MustBeExported, Preds0, Preds, WrongStatus),
- (
- WrongStatus = yes,
- pragma_status_error(Name, Arity, Context, PragmaName,
- !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- WrongStatus = no
- ),
-
- predicate_table_set_preds(Preds, PredTable0, PredTable),
- module_info_set_predicate_table(PredTable, !ModuleInfo)
- ;
- PredIds = [],
- string__append_list(["`:- pragma ", PragmaName, "' declaration"],
- Description),
- undefined_pred_or_func_error(Name, Arity, Context, Description, !IO),
- module_info_incr_errors(!ModuleInfo)
- ).
-
-:- pred get_matching_pred_ids(module_info::in, sym_name::in, arity::in,
- list(pred_id)::out) is semidet.
-
-get_matching_pred_ids(Module0, Name, Arity, PredIds) :-
- module_info_get_predicate_table(Module0, PredTable0),
- % check that the pragma is module qualified.
- (
- Name = unqualified(_),
- error("get_matching_pred_ids: unqualified name")
- ;
- Name = qualified(_, _),
- predicate_table_search_sym_arity(PredTable0, is_fully_qualified,
- Name, Arity, PredIds)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred module_mark_as_external(sym_name::in, int::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_mark_as_external(PredName, Arity, Context, !ModuleInfo, !IO) :-
- % `external' declarations can only apply to things defined
- % in this module, since everything else is already external.
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- (
- predicate_table_search_sym_arity(PredicateTable0, is_fully_qualified,
- PredName, Arity, PredIdList)
- ->
- module_mark_preds_as_external(PredIdList, !ModuleInfo)
- ;
- undefined_pred_or_func_error(PredName, Arity, Context,
- "`:- external' declaration", !IO),
- module_info_incr_errors(!ModuleInfo)
- ).
-
-:- pred module_mark_preds_as_external(list(pred_id)::in,
- module_info::in, module_info::out) is det.
-
-module_mark_preds_as_external([], !ModuleInfo).
-module_mark_preds_as_external([PredId | PredIds], !ModuleInfo) :-
- module_info_preds(!.ModuleInfo, Preds0),
- map__lookup(Preds0, PredId, PredInfo0),
- pred_info_mark_as_external(PredInfo0, PredInfo),
- map__det_update(Preds0, PredId, PredInfo, Preds),
- module_info_set_preds(Preds, !ModuleInfo),
- module_mark_preds_as_external(PredIds, !ModuleInfo).
-
-%-----------------------------------------------------------------------------%
-
-:- pred module_add_inst_defn(inst_varset::in, sym_name::in, list(inst_var)::in,
- inst_defn::in, condition::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
-
-module_add_inst_defn(VarSet, Name, Args, InstDefn, Cond, Context,
- item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !IO) :-
- %
- % add the definition of this inst to the HLDS inst table
- %
- module_info_insts(!.ModuleInfo, InstTable0),
- inst_table_get_user_insts(InstTable0, Insts0),
- insts_add(VarSet, Name, Args, InstDefn, Cond, Context, Status,
- Insts0, Insts, !IO),
- inst_table_set_user_insts(Insts, InstTable0, InstTable),
- module_info_set_insts(InstTable, !ModuleInfo),
- %
- % check if the inst is infinitely recursive (at the top level)
- %
- Arity = list__length(Args),
- InstId = Name - Arity,
- TestArgs = list__duplicate(Arity, not_reached),
- check_for_cyclic_inst(Insts, InstId, InstId, TestArgs, [], Context,
- InvalidMode, !IO).
-
-:- pred insts_add(inst_varset::in, sym_name::in,
- list(inst_var)::in, inst_defn::in, condition::in, prog_context::in,
- import_status::in, user_inst_table::in, user_inst_table::out,
- io::di, io::uo) is det.
-
- % XXX handle abstract insts
-insts_add(_, _, _, abstract_inst, _, _, _, !Insts, !IO) :-
- error("sorry, abstract insts not implemented").
-insts_add(VarSet, Name, Args, eqv_inst(Body), _Cond, Context, Status, !Insts,
- !IO) :-
- list__length(Args, Arity),
- (
- I = hlds_inst_defn(VarSet, Args, eqv_inst(Body), Context, Status),
- user_inst_table_insert(Name - Arity, I, !Insts)
- ->
- true
- ;
- % If abstract insts are implemented, this will need to change
- % to update the hlds_inst_defn to the non-abstract inst.
-
- % XXX we should record each error using
- % module_info_incr_errors
- user_inst_table_get_inst_defns(!.Insts, InstDefns),
- map__lookup(InstDefns, Name - Arity, OrigI),
- OrigI = hlds_inst_defn(_, _, _, OrigContext, _),
- multiple_def_error(Status, Name, Arity, "inst", Context, OrigContext,
- _, !IO)
- ).
-
- %
- % check if the inst is infinitely recursive (at the top level)
- %
-:- pred check_for_cyclic_inst(user_inst_table::in, inst_id::in, inst_id::in,
- list(inst)::in, list(inst_id)::in, prog_context::in, bool::out,
- io::di, io::uo) is det.
-
-check_for_cyclic_inst(UserInstTable, OrigInstId, InstId0, Args0, Expansions0,
- Context, InvalidMode, !IO) :-
- ( list__member(InstId0, Expansions0) ->
- report_circular_equiv_error("inst", OrigInstId, InstId0, Expansions0,
- Context, !IO),
- InvalidMode = yes
- ;
- user_inst_table_get_inst_defns(UserInstTable, InstDefns),
- (
- map__search(InstDefns, InstId0, InstDefn),
- InstDefn = hlds_inst_defn(_, Params, Body, _, _),
- Body = eqv_inst(EqvInst0),
- inst_substitute_arg_list(EqvInst0, Params, Args0, EqvInst),
- EqvInst = defined_inst(user_inst(Name, Args))
- ->
- Arity = list__length(Args),
- InstId = Name - Arity,
- Expansions = [InstId0 | Expansions0],
- check_for_cyclic_inst(UserInstTable, OrigInstId, InstId, Args,
- Expansions, Context, InvalidMode, !IO)
- ;
- InvalidMode = no
- )
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred module_add_mode_defn(inst_varset::in, sym_name::in, list(inst_var)::in,
- mode_defn::in, condition::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, bool::out, io::di, io::uo) is det.
-
-module_add_mode_defn(VarSet, Name, Params, ModeDefn, Cond, Context,
- item_status(Status, _NeedQual), !ModuleInfo, InvalidMode, !IO) :-
- module_info_modes(!.ModuleInfo, Modes0),
- modes_add(VarSet, Name, Params, ModeDefn, Cond, Context, Status,
- Modes0, Modes, InvalidMode, !IO),
- module_info_set_modes(Modes, !ModuleInfo).
-
-:- pred modes_add(inst_varset::in, sym_name::in, list(inst_var)::in,
- mode_defn::in, condition::in, prog_context::in, import_status::in,
- mode_table::in, mode_table::out, bool::out, io::di, io::uo) is det.
-
-modes_add(VarSet, Name, Args, eqv_mode(Body), _Cond, Context, Status,
- !Modes, InvalidMode, !IO) :-
- list__length(Args, Arity),
- ModeId = Name - Arity,
- (
- I = hlds_mode_defn(VarSet, Args, eqv_mode(Body), Context, Status),
- mode_table_insert(ModeId, I, !Modes)
- ->
- true
- ;
- mode_table_get_mode_defns(!.Modes, ModeDefns),
- map__lookup(ModeDefns, ModeId, OrigI),
- OrigI = hlds_mode_defn(_, _, _, OrigContext, _),
- % XXX we should record each error using
- % module_info_incr_errors
- multiple_def_error(Status, Name, Arity, "mode", Context, OrigContext,
- _, !IO)
- ),
- check_for_cyclic_mode(!.Modes, ModeId, ModeId, [], Context, InvalidMode,
- !IO).
-
- %
- % check if the mode is infinitely recursive at the top level
- %
-:- pred check_for_cyclic_mode(mode_table::in, mode_id::in, mode_id::in,
- list(mode_id)::in, prog_context::in, bool::out, io::di, io::uo) is det.
-
-check_for_cyclic_mode(ModeTable, OrigModeId, ModeId0, Expansions0, Context,
- InvalidMode, !IO) :-
- ( list__member(ModeId0, Expansions0) ->
- report_circular_equiv_error("mode", OrigModeId, ModeId0,
- Expansions0, Context, !IO),
- InvalidMode = yes
- ;
- mode_table_get_mode_defns(ModeTable, ModeDefns),
- (
- map__search(ModeDefns, ModeId0, ModeDefn),
- ModeDefn = hlds_mode_defn(_, _, Body, _, _),
- Body = eqv_mode(EqvMode),
- EqvMode = user_defined_mode(Name, Args)
- ->
- Arity = list__length(Args),
- ModeId = Name - Arity,
- Expansions = [ModeId0 | Expansions0],
- check_for_cyclic_mode(ModeTable, OrigModeId, ModeId, Expansions,
- Context, InvalidMode, !IO)
- ;
- InvalidMode = no
- )
- ).
-
-:- type id == pair(sym_name, arity).
-
-:- pred report_circular_equiv_error(string::in, id::in, id::in, list(id)::in,
- prog_context::in, io::di, io::uo) is det.
-
-report_circular_equiv_error(Kind, OrigId, Id, Expansions, Context, !IO) :-
- ( Id = OrigId ->
- %
- % Report an error message of the form
- % Error: circular equivalence <kind> foo/0.
- % or
- % Error: circular equivalence <kind>s foo/0 and bar/1.
- % or
- % Error: circular equivalence <kind>s foo/0, bar/1,
- % and baz/2.
- % where <kind> is either "inst" or "mode".
- %
- Kinds = (if Expansions = [_] then Kind else Kind ++ "s"),
- Pieces0 = list__map(
- (func(SymName - Arity) =
- error_util__describe_sym_name_and_arity(
- SymName / Arity)),
- Expansions),
- Pieces1 = error_util__list_to_pieces(Pieces0),
- Pieces = append_punctuation([words("Error: circular equivalence"),
- fixed(Kinds) | Pieces1], '.'),
- error_util__write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO)
- ;
- % We have an inst `OrigId' which is not itself circular,
- % but which is defined in terms of `Id' which is circular.
- % Don't bother reporting it now -- it have already been
- % reported when we processed the definition of Id.
- true
- ).
-
-%-----------------------------------------------------------------------------%
-
- % We allow more than one "definition" for a given type so
- % long all of them except one are actually just declarations,
- % e.g. `:- type t.', which is parsed as an type definition for
- % t which defines t as an abstract_type.
-
-:- pred module_add_type_defn(tvarset::in, sym_name::in, list(type_param)::in,
- type_defn::in, condition::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
- item_status(Status0, NeedQual), !ModuleInfo, !IO) :-
- globals__io_get_globals(Globals, !IO),
- list__length(Args, Arity),
- TypeCtor = Name - Arity,
- convert_type_defn(TypeDefn, TypeCtor, Globals, Body0),
- module_info_types(!.ModuleInfo, Types0),
- (
- (
- Body0 = abstract_type(_)
- ;
- Body0 = du_type(_, _, _, _, _, _),
- string__suffix(term__context_file(Context), ".int2")
- % If the type definition comes from a .int2 file then
- % we need to treat it as abstract. The constructors
- % may only be used by the mode system for comparing
- % `bound' insts to `ground'.
- )
- ->
- make_status_abstract(Status0, Status1)
- ;
- Status1 = Status0
- ),
- (
- % the type is exported if *any* occurrence is exported,
- % even a previous abstract occurrence
- map__search(Types0, TypeCtor, OldDefn0)
- ->
- hlds_data__get_type_defn_status(OldDefn0, OldStatus),
- combine_status(Status1, OldStatus, Status),
- hlds_data__get_type_defn_body(OldDefn0, OldBody0),
- combine_is_solver_type(OldBody0, OldBody, Body0, Body),
- ( is_solver_type_is_inconsistent(OldBody, Body) ->
- % The existing definition has an is_solver_type
- % annotation which is different to the current
- % definition.
- module_info_incr_errors(!ModuleInfo),
- Pieces0 = [words("In definition of type"),
- fixed(describe_sym_name_and_arity(Name / Arity) ++ ":"), nl,
- words("error: all definitions of a type must"),
- words("have consistent `solver'"),
- words("annotations")],
- error_util__write_error_pieces(Context, 0, Pieces0,
- !IO),
- MaybeOldDefn = no
- ;
- hlds_data__set_type_defn_body(OldBody, OldDefn0, OldDefn),
- MaybeOldDefn = yes(OldDefn)
- )
- ;
- MaybeOldDefn = no,
- Status = Status1,
- Body = Body0
- ),
- hlds_data__set_type_defn(TVarSet, Args, Body, Status, no, NeedQual,
- Context, T),
- (
- MaybeOldDefn = no,
- Body = foreign_type(_)
- ->
- TypeStr = error_util__describe_sym_name_and_arity(Name / Arity),
- ErrorPieces = [
- words("Error: type "),
- fixed(TypeStr),
- words("defined as foreign_type without being declared.")
- ],
- error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- MaybeOldDefn = yes(OldDefn1),
- Body = foreign_type(_),
- hlds_data__get_type_defn_status(OldDefn1, OldStatus1),
- hlds_data__get_type_defn_body(OldDefn1, OldBody1),
- OldBody1 = abstract_type(_),
- status_is_exported_to_non_submodules(OldStatus1, no),
- status_is_exported_to_non_submodules(Status0, yes)
- ->
- TypeStr = error_util__describe_sym_name_and_arity(
- Name / Arity),
- ErrorPieces = [
- words("Error: pragma foreign_type "),
- fixed(TypeStr),
- words("must have the same visibility as the type declaration.")
- ],
- error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
-
- % if there was an existing non-abstract definition for the type
- MaybeOldDefn = yes(T2),
- hlds_data__get_type_defn_tvarset(T2, TVarSet_2),
- hlds_data__get_type_defn_tparams(T2, Params_2),
- hlds_data__get_type_defn_body(T2, Body_2),
- hlds_data__get_type_defn_context(T2, OrigContext),
- hlds_data__get_type_defn_status(T2, OrigStatus),
- hlds_data__get_type_defn_in_exported_eqv(T2, OrigInExportedEqv),
- hlds_data__get_type_defn_need_qualifier(T2, OrigNeedQual),
- Body_2 \= abstract_type(_)
- ->
- globals__io_get_target(Target, !IO),
- globals__io_lookup_bool_option(make_optimization_interface,
- MakeOptInt, !IO),
- ( Body = foreign_type(_) ->
- module_info_contains_foreign_type(!ModuleInfo)
- ;
- true
- ),
- (
- % then if this definition was abstract, ignore it
- % (but update the status of the old defn if necessary)
- Body = abstract_type(_)
- ->
- ( Status = OrigStatus ->
- true
- ;
- hlds_data__set_type_defn(TVarSet_2, Params_2, Body_2, Status,
- OrigInExportedEqv, OrigNeedQual, OrigContext, T3),
- map__det_update(Types0, TypeCtor, T3, Types),
- module_info_set_types(Types, !ModuleInfo)
- )
- ;
- merge_foreign_type_bodies(Target, MakeOptInt, Body, Body_2,
- NewBody)
- ->
- ( check_foreign_type_visibility(OrigStatus, Status1) ->
- hlds_data__set_type_defn(TVarSet_2, Params_2, NewBody, Status,
- OrigInExportedEqv, NeedQual, Context, T3),
- map__det_update(Types0, TypeCtor, T3, Types),
- module_info_set_types(Types, !ModuleInfo)
- ;
- module_info_incr_errors(!ModuleInfo),
- Pieces = [words("In definition of type"),
- fixed(describe_sym_name_and_arity(Name / Arity) ++ ":"),
- nl,
- words("error: all definitions of a"),
- words("type must have the same"),
- words("visibility")],
- error_util__write_error_pieces(Context, 0,
- Pieces, !IO)
- )
- ;
- % otherwise issue an error message if the second
- % definition wasn't read while reading .opt files.
- Status = opt_imported
- ->
- true
- ;
- module_info_incr_errors(!ModuleInfo),
- multiple_def_error(Status, Name, Arity, "type", Context,
- OrigContext, _, !IO)
- )
- ;
- map__set(Types0, TypeCtor, T, Types),
- module_info_set_types(Types, !ModuleInfo),
- (
- % XXX we can't handle abstract exported
- % polymorphic equivalence types with monomorphic
- % bodies, because the compiler stuffs up the
- % type_info handling -- the caller passes type_infos,
- % but the callee expects no type_infos
- Body = eqv_type(EqvType),
- Status = abstract_exported,
- term__contains_var_list(Args, Var),
- \+ term__contains_var(EqvType, Var)
- ->
- Pieces = [words("Sorry, not implemented:"),
- words("polymorphic equivalence type,"),
- words("with monomorphic definition,"),
- words("exported as abstract type.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- globals__io_lookup_bool_option(verbose_errors,
- VerboseErrors, !IO),
- (
- VerboseErrors = yes,
- write_error_pieces(Context, 0, abstract_monotype_workaround,
- !IO)
- ;
- VerboseErrors = no
- ),
- io__set_exit_status(1, !IO)
- ;
- true
- )
- ).
-
-:- func abstract_monotype_workaround = list(format_component).
-
-abstract_monotype_workaround = [
- words("A quick work-around is to just export the type as a concrete,"),
- words("type by putting the type definition in the interface section."),
- words("A better work-around is to use a ""wrapper"" type, with just one"),
- words("functor that has just one arg, instead of an equivalence type."),
- words("(There's no performance penalty for this -- the compiler will"),
- words("optimize the wrapper away.)")
- ].
-
-%-----------------------------------------------------------------------------%
-
- % We do not have syntax for adding `solver' annotations to
- % `:- pragma foreign_type' declarations, so foreign_type bodies
- % default to having an is_solver_type field of `non_solver_type'.
- % If another declaration for the type has a `solver' annotation then
- % we must update the foreign_type body to reflect this.
- %
- % rafe: XXX think it should be an error for foreign types to
- % be solver types.
- %
-:- pred combine_is_solver_type(hlds_type_body::in, hlds_type_body::out,
- hlds_type_body::in, hlds_type_body::out) is det.
-
-combine_is_solver_type(OldBody, OldBody, Body, Body).
-
- % Succeed iff the two type bodies have inconsistent is_solver_type
- % annotations.
-:- pred is_solver_type_is_inconsistent(hlds_type_body::in, hlds_type_body::in)
- is semidet.
-
-is_solver_type_is_inconsistent(OldBody, Body) :-
- maybe_get_body_is_solver_type(OldBody, OldIsSolverType),
- maybe_get_body_is_solver_type(Body, IsSolverType),
- OldIsSolverType \= IsSolverType.
-
-:- pred maybe_get_body_is_solver_type(hlds_type_body::in, is_solver_type::out)
- is semidet.
-
-maybe_get_body_is_solver_type(abstract_type(IsSolverType), IsSolverType).
-maybe_get_body_is_solver_type(solver_type(_, _), solver_type).
-
- % check_foreign_type_visibility(OldStatus, NewDefnStatus).
- %
- % Check that the visibility of the new definition for
- % a foreign type matches that of previous definitions.
-:- pred check_foreign_type_visibility(import_status::in,
- import_status::in) is semidet.
-
-check_foreign_type_visibility(OldStatus, NewDefnStatus) :-
- ( OldStatus = abstract_exported ->
- % If OldStatus is abstract_exported, the previous
- % definitions were local.
- status_is_exported_to_non_submodules(NewDefnStatus, no)
- ; OldStatus = exported ->
- NewDefnStatus = exported
- ;
- status_is_exported_to_non_submodules(OldStatus, no),
- status_is_exported_to_non_submodules(NewDefnStatus, no)
- ).
-
- % Add the constructors and special preds for a type to the HLDS.
-:- pred process_type_defn(type_ctor::in, hlds_type_defn::in,
- bool::in, bool::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !IO) :-
- hlds_data__get_type_defn_context(TypeDefn, Context),
- hlds_data__get_type_defn_tvarset(TypeDefn, TVarSet),
- hlds_data__get_type_defn_tparams(TypeDefn, Args),
- hlds_data__get_type_defn_body(TypeDefn, Body),
- hlds_data__get_type_defn_status(TypeDefn, Status),
- hlds_data__get_type_defn_need_qualifier(TypeDefn, NeedQual),
- (
- ConsList = Body ^ du_type_ctors,
- ReservedTag = Body ^ du_type_reserved_tag,
- module_info_ctors(!.ModuleInfo, Ctors0),
- module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
- check_for_errors(
- (pred(M0::in, M::out, IO0::di, IO::uo) is det :-
- module_info_ctor_field_table(M0, CtorFields0),
- ctors_add(ConsList, TypeCtor, TVarSet, NeedQual, PQInfo,
- Context, Status, CtorFields0, CtorFields, Ctors0, Ctors,
- IO0, IO),
- module_info_set_ctors(Ctors, M0, M1),
- module_info_set_ctor_field_table(CtorFields, M1, M)
- ), NewFoundError, !ModuleInfo, !IO),
-
- globals__io_get_globals(Globals, !IO),
- (
- type_constructors_should_be_no_tag(ConsList, ReservedTag, Globals,
- Name, CtorArgType, _)
- ->
- NoTagType = no_tag_type(Args, Name, CtorArgType),
- module_info_no_tag_types(!.ModuleInfo, NoTagTypes0),
- map__set(NoTagTypes0, TypeCtor, NoTagType, NoTagTypes),
- module_info_set_no_tag_types(NoTagTypes, !ModuleInfo)
- ;
- true
- )
- ;
- Body = abstract_type(_),
- NewFoundError = no
- ;
- Body = solver_type(_, _),
- NewFoundError = no
- ;
- Body = eqv_type(_),
- NewFoundError = no
- ;
- Body = foreign_type(ForeignTypeBody),
- check_foreign_type(TypeCtor, ForeignTypeBody, Context,
- NewFoundError, !ModuleInfo, !IO)
- ),
- !:FoundError = !.FoundError `and` NewFoundError,
- (
- !.FoundError = yes
- ->
- true
- ;
- % Equivalence types are fully expanded on the IL and Java
- % backends, so the special predicates aren't required.
- are_equivalence_types_expanded(!.ModuleInfo),
- Body = eqv_type(_)
- ->
- true
- ;
- construct_type(TypeCtor, Args, Type),
- add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
- !ModuleInfo)
- ).
-
- % check_foreign_type ensures that if we are generating code for
- % a specific backend that the foreign type has a representation
- % on that backend.
-:- pred check_foreign_type(type_ctor::in, foreign_type_body::in,
- prog_context::in, bool::out, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-check_foreign_type(TypeCtor, ForeignTypeBody, Context, FoundError, !ModuleInfo,
- !IO) :-
- TypeCtor = Name - Arity,
- module_info_globals(!.ModuleInfo, Globals),
- generating_code(GeneratingCode, !IO),
- globals__get_target(Globals, Target),
- ( have_foreign_type_for_backend(Target, ForeignTypeBody, yes) ->
- FoundError = no
- ; GeneratingCode = yes ->
- %
- % If we're not generating code the error may only have
- % occurred because the grade options weren't passed.
- %
- io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
- ( VeryVerbose = yes ->
- VerboseErrorPieces = [
- nl,
- words("There are representations for"),
- words("this type on other back-ends,"),
- words("but none for this back-end.")
- ]
- ;
- VerboseErrorPieces = []
- ),
- ( Target = c, LangStr = "C"
- ; Target = il, LangStr = "IL"
- ; Target = java, LangStr = "Java"
- ; Target = asm, LangStr = "C"
- ),
- TypeStr = error_util__describe_sym_name_and_arity(Name/Arity),
- ErrorPieces = [
- words("Error: no"), words(LangStr),
- words("`pragma foreign_type' declaration for"),
- fixed(TypeStr) | VerboseErrorPieces
- ],
- error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
- FoundError = yes,
- module_info_incr_errors(!ModuleInfo)
- ;
- FoundError = yes
- ).
-
- % Do the options imply that we will generate code for a specific
- % back-end?
-:- pred generating_code(bool::out, io::di, io::uo) is det.
-
-generating_code(bool__not(NotGeneratingCode), !IO) :-
- io_lookup_bool_option(make_short_interface, MakeShortInterface, !IO),
- io_lookup_bool_option(make_interface, MakeInterface, !IO),
- io_lookup_bool_option(make_private_interface, MakePrivateInterface, !IO),
- io_lookup_bool_option(make_transitive_opt_interface,
- MakeTransOptInterface, !IO),
- io_lookup_bool_option(generate_source_file_mapping, GenSrcFileMapping, !IO),
- io_lookup_bool_option(generate_dependencies, GenDepends, !IO),
- io_lookup_bool_option(convert_to_mercury, ConvertToMercury, !IO),
- io_lookup_bool_option(typecheck_only, TypeCheckOnly, !IO),
- io_lookup_bool_option(errorcheck_only, ErrorCheckOnly, !IO),
- io_lookup_bool_option(output_grade_string, OutputGradeString, !IO),
- bool__or_list([MakeShortInterface, MakeInterface,
- MakePrivateInterface, MakeTransOptInterface,
- GenSrcFileMapping, GenDepends, ConvertToMercury,
- TypeCheckOnly, ErrorCheckOnly, OutputGradeString],
- NotGeneratingCode).
-
-:- pred merge_foreign_type_bodies(compilation_target::in, bool::in,
- hlds_type_body::in, hlds_type_body::in, hlds_type_body::out)
- is semidet.
-
- % Ignore Mercury definitions if we've got a foreign type
- % declaration suitable for this back-end and we aren't making the
- % optimization interface. We need to keep the Mercury definition
- % if we are making the optimization interface so that it gets
- % output in the .opt file.
-merge_foreign_type_bodies(Target, MakeOptInterface,
- foreign_type(ForeignTypeBody0), Body1, Body) :-
- MaybeForeignTypeBody1 = Body1 ^ du_type_is_foreign_type,
- (
- MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
- ;
- MaybeForeignTypeBody1 = no,
- ForeignTypeBody1 = foreign_type_body(no, no, no)
- ),
- merge_foreign_type_bodies_2(ForeignTypeBody0, ForeignTypeBody1,
- ForeignTypeBody),
- (
- have_foreign_type_for_backend(Target, ForeignTypeBody, yes),
- MakeOptInterface = no
- ->
- Body = foreign_type(ForeignTypeBody)
- ;
- Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
- ).
-merge_foreign_type_bodies(Target, MakeOptInterface,
- Body0 @ du_type(_, _, _, _, _, _),
- Body1 @ foreign_type(_), Body) :-
- merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
-merge_foreign_type_bodies(_, _, foreign_type(Body0),
- foreign_type(Body1),
- foreign_type(Body)) :-
- merge_foreign_type_bodies_2(Body0, Body1, Body).
-
-:- pred merge_foreign_type_bodies_2(foreign_type_body::in,
- foreign_type_body::in, foreign_type_body::out) is semidet.
-
-merge_foreign_type_bodies_2(foreign_type_body(MaybeILA, MaybeCA, MaybeJavaA),
- foreign_type_body(MaybeILB, MaybeCB, MaybeJavaB),
- foreign_type_body(MaybeIL, MaybeC, MaybeJava)) :-
- merge_maybe(MaybeILA, MaybeILB, MaybeIL),
- merge_maybe(MaybeCA, MaybeCB, MaybeC),
- merge_maybe(MaybeJavaA, MaybeJavaB, MaybeJava).
-
-:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
-
-merge_maybe(no, no, no).
-merge_maybe(yes(T), no, yes(T)).
-merge_maybe(no, yes(T), yes(T)).
-
-:- pred make_status_abstract(import_status::in, import_status::out) is det.
-
-make_status_abstract(Status, AbstractStatus) :-
- ( Status = exported ->
- AbstractStatus = abstract_exported
- ; Status = imported(_) ->
- AbstractStatus = abstract_imported
- ;
- AbstractStatus = Status
- ).
-
-:- pred combine_status(import_status::in, import_status::in,
- import_status::out) is det.
-
-combine_status(StatusA, StatusB, Status) :-
- ( combine_status_2(StatusA, StatusB, CombinedStatus) ->
- Status = CombinedStatus
- ;
- error("unexpected status for type definition")
- ).
-
-:- pred combine_status_2(import_status::in, import_status::in,
- import_status::out) is semidet.
-
-combine_status_2(imported(_), Status2, Status) :-
- combine_status_imported(Status2, Status).
-combine_status_2(local, Status2, Status) :-
- combine_status_local(Status2, Status).
-combine_status_2(exported, _Status2, exported).
-combine_status_2(exported_to_submodules, Status2, Status) :-
- combine_status_local(Status2, Status3),
- ( Status3 = local ->
- Status = exported_to_submodules
- ;
- Status = Status3
- ).
-combine_status_2(opt_imported, _Status2, opt_imported).
-combine_status_2(abstract_imported, Status2, Status) :-
- combine_status_abstract_imported(Status2, Status).
-combine_status_2(abstract_exported, Status2, Status) :-
- combine_status_abstract_exported(Status2, Status).
-
-:- pred combine_status_imported(import_status::in, import_status::out)
- is semidet.
-
-combine_status_imported(imported(Section), imported(Section)).
-combine_status_imported(local, imported(implementation)).
-combine_status_imported(exported, exported).
-combine_status_imported(opt_imported, opt_imported).
-combine_status_imported(abstract_imported, imported(interface)).
-combine_status_imported(abstract_exported, abstract_exported).
-
-:- pred combine_status_local(import_status::in, import_status::out) is semidet.
-
-combine_status_local(exported_to_submodules, exported_to_submodules).
-combine_status_local(imported(_), local).
-combine_status_local(local, local).
-combine_status_local(exported, exported).
-combine_status_local(opt_imported, local).
-combine_status_local(abstract_imported, local).
-combine_status_local(abstract_exported, abstract_exported).
-
-:- pred combine_status_abstract_exported(import_status::in, import_status::out)
- is det.
-
-combine_status_abstract_exported(Status2, Status) :-
- ( Status2 = exported ->
- Status = exported
- ;
- Status = abstract_exported
- ).
-
-:- pred combine_status_abstract_imported(import_status::in, import_status::out)
- is det.
-
-combine_status_abstract_imported(Status2, Status) :-
- ( Status2 = imported(Section) ->
- Status = imported(Section)
- ;
- Status = abstract_imported
- ).
-
-:- pred convert_type_defn(type_defn::in, type_ctor::in, globals::in,
- hlds_type_body::out) is det.
-
-convert_type_defn(du_type(Body, MaybeUserEqComp), TypeCtor, Globals,
- HLDSBody) :-
- % Initially, when we first see the `:- type' definition,
- % we assign the constructor tags assuming that there is no
- % `:- pragma reserve_tag' declaration for this type.
- % (If it turns out that there was one, then we will recompute the
- % constructor tags by calling assign_constructor_tags again,
- % with ReservedTagPragma = yes, when processing the pragma.)
- ReservedTagPragma = no,
- assign_constructor_tags(Body, TypeCtor, ReservedTagPragma, Globals,
- CtorTags, IsEnum),
- IsForeign = no,
- HLDSBody = du_type(Body, CtorTags, IsEnum, MaybeUserEqComp,
- ReservedTagPragma, IsForeign).
-convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
-convert_type_defn(solver_type(SolverTypeDetails, MaybeUserEqComp), _, _,
- solver_type(SolverTypeDetails, MaybeUserEqComp)).
-convert_type_defn(abstract_type(IsSolverType), _, _,
- abstract_type(IsSolverType)).
-convert_type_defn(foreign_type(ForeignType, MaybeUserEqComp, Assertions),
- _, _, foreign_type(Body)) :-
- (
- ForeignType = il(ILForeignType),
- Data = foreign_type_lang_data(ILForeignType, MaybeUserEqComp,
- Assertions),
- Body = foreign_type_body(yes(Data), no, no)
- ;
- ForeignType = c(CForeignType),
- Data = foreign_type_lang_data(CForeignType, MaybeUserEqComp,
- Assertions),
- Body = foreign_type_body(no, yes(Data), no)
- ;
- ForeignType = java(JavaForeignType),
- Data = foreign_type_lang_data(JavaForeignType, MaybeUserEqComp,
- Assertions),
- Body = foreign_type_body(no, no, yes(Data))
- ).
-
-:- pred ctors_add(list(constructor)::in, type_ctor::in, tvarset::in,
- need_qualifier::in, partial_qualifier_info::in, prog_context::in,
- import_status::in, ctor_field_table::in, ctor_field_table::out,
- cons_table::in, cons_table::out, io::di, io::uo) is det.
-
-ctors_add([], _, _, _, _, _, _, !FieldNameTable, !Ctors, !IO).
-ctors_add([Ctor | Rest], TypeCtor, TVarSet, NeedQual, PQInfo, Context,
- ImportStatus, !FieldNameTable, !Ctors, !IO) :-
- Ctor = ctor(ExistQVars, Constraints, Name, Args),
- QualifiedConsId = make_cons_id(Name, Args, TypeCtor),
- ConsDefn = hlds_cons_defn(ExistQVars, Constraints, Args, TypeCtor,
- Context),
- %
- % Insert the fully-qualified version of this cons_id into the
- % cons_table.
- % Also check that there is at most one definition of a given
- % cons_id in each type.
- %
- ( map__search(!.Ctors, QualifiedConsId, QualifiedConsDefns0) ->
- QualifiedConsDefns1 = QualifiedConsDefns0
- ;
- QualifiedConsDefns1 = []
- ),
- (
- list__member(OtherConsDefn, QualifiedConsDefns1),
- OtherConsDefn = hlds_cons_defn(_, _, _, TypeCtor, _)
- ->
- % XXX we should record each error using module_info_incr_errors
- prog_out__write_context(Context, !IO),
- io__write_string("Error: constructor `", !IO),
- hlds_out__write_cons_id(QualifiedConsId, !IO),
- io__write_string("' for type `", !IO),
- hlds_out__write_type_ctor(TypeCtor, !IO),
- io__write_string("' multiply defined.\n", !IO),
- io__set_exit_status(1, !IO),
- QualifiedConsDefns = QualifiedConsDefns1
- ;
- QualifiedConsDefns = [ConsDefn | QualifiedConsDefns1]
- ),
- map__set(!.Ctors, QualifiedConsId, QualifiedConsDefns, !:Ctors),
-
- ( QualifiedConsId = cons(qualified(Module, ConsName), Arity) ->
- % Add unqualified version of the cons_id to the
- % cons_table, if appropriate.
- ( NeedQual = may_be_unqualified ->
- UnqualifiedConsId = cons(unqualified(ConsName), Arity),
- multi_map__set(!.Ctors, UnqualifiedConsId, ConsDefn, !:Ctors)
- ;
- true
- ),
-
- % Add partially qualified versions of the cons_id
- get_partial_qualifiers(Module, PQInfo, PartialQuals),
- list__map_foldl(add_ctor(ConsName, Arity, ConsDefn),
- PartialQuals, _PartiallyQualifiedConsIds, !Ctors),
-
- assoc_list__keys(Args, FieldNames),
- FirstField = 1,
-
- add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
- QualifiedConsId, Context, ImportStatus, FirstField,
- !FieldNameTable, !IO)
- ;
- error("ctors_add: cons_id not qualified")
- ),
- ctors_add(Rest, TypeCtor, TVarSet, NeedQual, PQInfo, Context,
- ImportStatus, !FieldNameTable, !Ctors, !IO).
-
-:- pred add_ctor(string::in, int::in, hlds_cons_defn::in, module_name::in,
- cons_id::out, cons_table::in, cons_table::out) is det.
-
-add_ctor(ConsName, Arity, ConsDefn, ModuleQual, ConsId, CtorsIn, CtorsOut) :-
- ConsId = cons(qualified(ModuleQual, ConsName), Arity),
- multi_map__set(CtorsIn, ConsId, ConsDefn, CtorsOut).
-
-:- pred add_ctor_field_names(list(maybe(ctor_field_name))::in,
- need_qualifier::in, list(module_name)::in, type_ctor::in, cons_id::in,
- prog_context::in, import_status::in, int::in,
- ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
-
-add_ctor_field_names([], _, _, _, _, _, _, _, !FieldNameTable, !IO).
-add_ctor_field_names([MaybeFieldName | FieldNames], NeedQual,
- PartialQuals, TypeCtor, ConsId, Context, ImportStatus,
- FieldNumber, !FieldNameTable, !IO) :-
- (
- MaybeFieldName = yes(FieldName),
- FieldDefn = hlds_ctor_field_defn(Context, ImportStatus, TypeCtor,
- ConsId, FieldNumber),
- add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
- !FieldNameTable, !IO)
- ;
- MaybeFieldName = no
- ),
- add_ctor_field_names(FieldNames, NeedQual, PartialQuals, TypeCtor,
- ConsId, Context, ImportStatus, FieldNumber + 1,
- !FieldNameTable, !IO).
-
-:- pred add_ctor_field_name(ctor_field_name::in, hlds_ctor_field_defn::in,
- need_qualifier::in, list(module_name)::in,
- ctor_field_table::in, ctor_field_table::out, io::di, io::uo) is det.
-
-add_ctor_field_name(FieldName, FieldDefn, NeedQual, PartialQuals,
- !FieldNameTable, !IO) :-
- ( FieldName = qualified(FieldModule0, _) ->
- FieldModule = FieldModule0
- ;
- error("add_ctor_field_name: unqualified field name")
- ),
- (
- %
- % Field names must be unique within a module, not
- % just within a type because the function names for
- % user-defined override functions for the builtin field
- % access functions must be unique within a module.
- %
- map__search(!.FieldNameTable, FieldName, ConflictingDefns)
- ->
- ( ConflictingDefns = [ConflictingDefn] ->
- ConflictingDefn = hlds_ctor_field_defn(OrigContext, _, _, _, _)
- ;
- error("add_ctor_field_name: multiple conflicting fields")
- ),
-
- % XXX we should record each error
- % using module_info_incr_errors
- FieldDefn = hlds_ctor_field_defn(Context, _, _, _, _),
- mdbcomp__prim_data__sym_name_to_string(FieldName, FieldString),
- ErrorPieces = [
- words("Error: field"),
- fixed(string__append_list(["`", FieldString, "'"])),
- words("multiply defined.")
- ],
- error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
-
- % This type of error doesn't fit well with
- % how error_util does things -- error_util.m
- % wants to write everything with a single context.
- prog_out__write_context(OrigContext, !IO),
- io__write_string(" Here is the previous definition of field `", !IO),
- io__write_string(FieldString, !IO),
- io__write_string("'.\n", !IO),
- io__set_exit_status(1, !IO)
- ;
- unqualify_name(FieldName, UnqualFieldName),
-
- % Add an unqualified version of the field name to the
- % table, if appropriate.
- ( NeedQual = may_be_unqualified ->
- multi_map__set(!.FieldNameTable, unqualified(UnqualFieldName),
- FieldDefn, !:FieldNameTable)
- ;
- true
- ),
-
- % Add partially qualified versions of the cons_id
- list__foldl(do_add_ctor_field(UnqualFieldName, FieldDefn),
- [FieldModule | PartialQuals], !FieldNameTable)
- ).
-
-:- pred do_add_ctor_field(string::in, hlds_ctor_field_defn::in,
- module_name::in, ctor_field_table::in, ctor_field_table::out) is det.
-
-do_add_ctor_field(FieldName, FieldNameDefn, ModuleName, !FieldNameTable) :-
- multi_map__set(!.FieldNameTable, qualified(ModuleName, FieldName),
- FieldNameDefn, !:FieldNameTable).
-
-%-----------------------------------------------------------------------------%
-
-:- pred module_add_pred_or_func(tvarset::in, inst_varset::in, existq_tvars::in,
- pred_or_func::in, sym_name::in, list(type_and_mode)::in,
- maybe(determinism)::in, purity::in,
- prog_constraints::in, pred_markers::in, prog_context::in,
- item_status::in, maybe(pair(pred_id, proc_id))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars,
- PredOrFunc, PredName, TypesAndModes, MaybeDet, Purity,
- ClassContext, Markers, Context, item_status(Status, NeedQual),
- MaybePredProcId, !ModuleInfo, !IO) :-
- split_types_and_modes(TypesAndModes, Types, MaybeModes0),
- add_new_pred(TypeVarSet, ExistQVars, PredName, Types, Purity,
- ClassContext, Markers, Context, Status, NeedQual, PredOrFunc,
- !ModuleInfo, !IO),
- (
- PredOrFunc = predicate,
- MaybeModes0 = yes(Modes0),
-
- % For predicates with no arguments, if the determinism
- % is not declared a mode is not added. The determinism
- % can be specified by a separate mode declaration.
- Modes0 = [],
- MaybeDet = no
- ->
- MaybeModes = no
- ;
- % Assume that a function with no modes but with a determinism
- % declared has the default modes.
- PredOrFunc = function,
- MaybeModes0 = no,
- MaybeDet = yes(_)
- ->
- list__length(Types, Arity),
- adjust_func_arity(function, FuncArity, Arity),
- in_mode(InMode),
- list__duplicate(FuncArity, InMode, InModes),
- out_mode(OutMode),
- list__append(InModes, [OutMode], ArgModes),
- MaybeModes = yes(ArgModes)
- ;
- MaybeModes = MaybeModes0
- ),
- (
- MaybeModes = yes(Modes),
- ( check_marker(Markers, class_method) ->
- IsClassMethod = yes
- ;
- IsClassMethod = no
- ),
- module_add_mode(InstVarSet, PredName, Modes, MaybeDet, Status, Context,
- PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !IO),
- MaybePredProcId = yes(PredProcId)
- ;
- MaybeModes = no,
- MaybePredProcId = no
- ).
-
-:- pred module_add_class_defn(list(prog_constraint)::in,
- list(prog_fundep)::in, sym_name::in, list(tvar)::in, class_interface::in,
- tvarset::in, prog_context::in, item_status::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface, VarSet,
- Context, Status, !ModuleInfo, !IO) :-
- module_info_classes(!.ModuleInfo, Classes0),
- module_info_superclasses(!.ModuleInfo, SuperClasses0),
- list__length(Vars, ClassArity),
- ClassId = class_id(Name, ClassArity),
- Status = item_status(ImportStatus0, _),
- ( Interface = abstract ->
- make_status_abstract(ImportStatus0, ImportStatus1)
- ;
- ImportStatus1 = ImportStatus0
- ),
- HLDSFunDeps = list__map(make_hlds_fundep(Vars), FunDeps),
- (
- % the typeclass is exported if *any* occurrence is exported,
- % even a previous abstract occurrence
- map__search(Classes0, ClassId, OldDefn)
- ->
- OldDefn = hlds_class_defn(OldStatus, OldConstraints, OldFunDeps,
- _OldAncestors, OldVars, OldInterface, OldMethods, OldVarSet,
- OldContext),
- combine_status(ImportStatus1, OldStatus, ImportStatus),
- (
- OldInterface = concrete(_),
- ClassMethods0 = OldMethods,
- ClassInterface = OldInterface
- ;
- OldInterface = abstract,
- ClassMethods0 = [],
- ClassInterface = Interface
- ),
- (
- \+ superclass_constraints_are_identical(OldVars, OldVarSet,
- OldConstraints, Vars, VarSet, Constraints)
- ->
- % Always report the error, even in `.opt' files.
- DummyStatus = local,
- multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
- Context, OldContext, _, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" The superclass constraints do not match.\n",
- !IO),
- io__set_exit_status(1, !IO),
- ErrorOrPrevDef = yes
- ;
- \+ class_fundeps_are_identical(OldFunDeps, HLDSFunDeps)
- ->
- % Always report the error, even in `.opt' files.
- DummyStatus = local,
- multiple_def_error(DummyStatus, Name, ClassArity, "typeclass",
- Context, OldContext, _, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" The functional dependencies do not match.\n",
- !IO),
- io__set_exit_status(1, !IO),
- ErrorOrPrevDef = yes
- ;
- Interface = concrete(_),
- OldInterface = concrete(_)
- ->
- multiple_def_error(ImportStatus, Name, ClassArity,
- "typeclass", Context, OldContext, _, !IO),
- ErrorOrPrevDef = yes
- ;
- ErrorOrPrevDef = no
- ),
-
- IsNewDefn = no
- ;
- IsNewDefn = yes `with_type` bool,
- ErrorOrPrevDef = no `with_type` bool,
- ClassMethods0 = [],
- ClassInterface = Interface,
- ImportStatus = ImportStatus1
- ),
- ( ErrorOrPrevDef = no ->
- (
- Interface = concrete(Methods),
- module_add_class_interface(Name, Vars, Methods,
- Status, PredProcIds0, !ModuleInfo, !IO),
- % Get rid of the `no's from the list of maybes
- IsYes = (pred(Maybe::in, PredProcId::out) is semidet :-
- Maybe = yes(Pred - Proc),
- PredProcId = hlds_class_proc(Pred, Proc)
- ),
- list__filter_map(IsYes, PredProcIds0, PredProcIds1),
-
- %
- % The list must be sorted on pred_id and then
- % proc_id -- check_typeclass.m assumes this
- % when it is generating the corresponding list
- % of pred_proc_ids for instance definitions.
- %
- list__sort(PredProcIds1, ClassMethods)
- ;
- Interface = abstract,
- ClassMethods = ClassMethods0
- ),
-
- % Ancestors is not set until check_typeclass.
- Ancestors = [],
- Defn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
- Ancestors, Vars, ClassInterface, ClassMethods, VarSet, Context),
- map__set(Classes0, ClassId, Defn, Classes),
- module_info_set_classes(Classes, !ModuleInfo),
-
- ( IsNewDefn = yes ->
- update_superclass_table(ClassId, Vars, VarSet, Constraints,
- SuperClasses0, SuperClasses),
-
- module_info_set_superclasses(SuperClasses, !ModuleInfo),
-
- % When we find the class declaration, make an
- % entry for the instances.
- module_info_instances(!.ModuleInfo, Instances0),
- map__det_insert(Instances0, ClassId, [], Instances),
- module_info_set_instances(Instances, !ModuleInfo)
- ;
- true
- )
- ;
- true
- ).
-
-:- func make_hlds_fundep(list(tvar), prog_fundep) = hlds_class_fundep.
-
-make_hlds_fundep(TVars, fundep(Domain0, Range0)) = fundep(Domain, Range) :-
- Domain = make_hlds_fundep_2(TVars, Domain0),
- Range = make_hlds_fundep_2(TVars, Range0).
-
-:- func make_hlds_fundep_2(list(tvar), list(tvar)) = set(hlds_class_argpos).
-
-make_hlds_fundep_2(TVars, List) = list.foldl(Func, List, set.init) :-
- Func = (func(TVar, Set0) = set.insert(Set0, N) :-
- N = get_list_index(TVars, 1, TVar)
- ).
-
-:- func get_list_index(list(T), hlds_class_argpos, T) = hlds_class_argpos.
-
-get_list_index([], _, _) = _ :-
- error("get_list_index: element not found").
-get_list_index([E | Es], N, X) =
- (
- X = E
- ->
- N
- ;
- get_list_index(Es, N + 1, X)
- ).
-
-:- pred superclass_constraints_are_identical(list(tvar)::in, tvarset::in,
- list(prog_constraint)::in, list(tvar)::in, tvarset::in,
- list(prog_constraint)::in) is semidet.
-
-superclass_constraints_are_identical(OldVars0, OldVarSet, OldConstraints0,
- Vars, VarSet, Constraints) :-
- varset__merge_subst(VarSet, OldVarSet, _, Subst),
- apply_subst_to_prog_constraint_list(Subst, OldConstraints0,
- OldConstraints1),
- OldVars = term__term_list_to_var_list(map__apply_to_list(OldVars0, Subst)),
-
- map__from_corresponding_lists(OldVars, Vars, VarRenaming),
- apply_variable_renaming_to_prog_constraint_list(VarRenaming,
- OldConstraints1, OldConstraints),
- OldConstraints = Constraints.
-
-:- pred class_fundeps_are_identical(hlds_class_fundeps::in,
- hlds_class_fundeps::in) is semidet.
-
-class_fundeps_are_identical(OldFunDeps0, FunDeps0) :-
- % Allow for the functional dependencies to be in a different order.
- % we rely on the fact that sets (ordered lists) have a canonical
- % representation.
- sort_and_remove_dups(OldFunDeps0, OldFunDeps),
- sort_and_remove_dups(FunDeps0, FunDeps),
- OldFunDeps = FunDeps.
-
-:- pred module_add_class_interface(sym_name::in, list(tvar)::in,
- list(class_method)::in, item_status::in,
- list(maybe(pair(pred_id, proc_id)))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_add_class_interface(Name, Vars, Methods, Status, PredProcIds,
- !ModuleInfo, !IO) :-
- module_add_class_interface_2(Name, Vars, Methods, Status, PredProcIds0,
- !ModuleInfo, !IO),
- check_method_modes(Methods, PredProcIds0, PredProcIds,
- !ModuleInfo, !IO).
-
-:- pred module_add_class_interface_2(sym_name::in, list(tvar)::in,
- list(class_method)::in, item_status::in,
- list(maybe(pair(pred_id, proc_id)))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_add_class_interface_2(_, _, [], _, [], !ModuleInfo, !IO).
-module_add_class_interface_2(Name, Vars, [M | Ms], Status, [P | Ps],
- !ModuleInfo, !IO) :-
- module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !IO),
- module_add_class_interface_2(Name, Vars, Ms, Status, Ps, !ModuleInfo, !IO).
-
-:- pred module_add_class_method(class_method::in, sym_name::in, list(tvar)::in,
- item_status::in, maybe(pair(pred_id, proc_id))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_add_class_method(Method, Name, Vars, Status, MaybePredIdProcId,
- !ModuleInfo, !IO) :-
- (
- Method = pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, _WithType, _WithInst, MaybeDet, _Cond,
- Purity, ClassContext, Context),
- term__var_list_to_term_list(Vars, VarTerms),
- ClassContext = constraints(UnivCnstrs, ExistCnstrs),
- NewUnivCnstrs = [constraint(Name, VarTerms) | UnivCnstrs],
- NewClassContext = constraints(NewUnivCnstrs, ExistCnstrs),
- init_markers(Markers0),
- add_marker(class_method, Markers0, Markers),
- module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
- PredName, TypesAndModes, MaybeDet, Purity, NewClassContext,
- Markers, Context, Status, MaybePredIdProcId, !ModuleInfo, !IO)
- ;
- Method = pred_or_func_mode(VarSet, MaybePredOrFunc, PredName,
- Modes, _WithInst, MaybeDet, _Cond, Context),
- (
- MaybePredOrFunc = yes(PredOrFunc),
- Status = item_status(ImportStatus, _),
- IsClassMethod = yes,
- module_add_mode(VarSet, PredName, Modes, MaybeDet, ImportStatus,
- Context, PredOrFunc, IsClassMethod, PredIdProcId, !ModuleInfo,
- !IO),
- MaybePredIdProcId = yes(PredIdProcId)
- ;
- MaybePredOrFunc = no,
- % equiv_type.m should have either set the
- % pred_or_func or removed the item from the list.
- unexpected(this_file, "module_add_class_method: " ++
- "no pred_or_func on mode declaration")
- )
- ).
-
- % Insert an entry into the super class table for each super class of
- % this class.
- %
-:- pred update_superclass_table(class_id::in, list(tvar)::in, tvarset::in,
- list(prog_constraint)::in, superclass_table::in, superclass_table::out)
- is det.
-
-update_superclass_table(ClassId, Vars, VarSet, Constraints, !Supers) :-
- list.foldl(update_superclass_table_2(ClassId, Vars, VarSet), Constraints,
- !Supers).
-
-:- pred update_superclass_table_2(class_id::in, list(tvar)::in, tvarset::in,
- prog_constraint::in, superclass_table::in, superclass_table::out) is det.
-
-update_superclass_table_2(ClassId, Vars, VarSet, Constraint, !Supers) :-
- Constraint = constraint(SuperName, SuperTypes),
- list__length(SuperTypes, SuperClassArity),
- SuperClassId = class_id(SuperName, SuperClassArity),
- SubClassDetails = subclass_details(SuperTypes, ClassId, Vars, VarSet),
- multi_map__set(!.Supers, SuperClassId, SubClassDetails, !:Supers).
-
- % Go through the list of class methods, looking for
- % - functions without mode declarations: add a default mode
- % - predicates without mode declarations: report an error
- % - mode declarations with no determinism: report an error
-:- pred check_method_modes(list(class_method)::in,
- list(maybe(pair(pred_id, proc_id)))::in,
- list(maybe(pair(pred_id, proc_id)))::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-check_method_modes([], !PredProcIds, !ModuleInfo, !IO).
-check_method_modes([Method | Methods], !PredProcIds, !ModuleInfo, !IO) :-
- (
- Method = pred_or_func(_, _, _, PorF, QualName, TypesAndModes,
- _WithType, _WithInst, _, _, _, _, _)
- ->
- (
- QualName = qualified(ModuleName0, Name0),
- ModuleName = ModuleName0,
- Name = Name0
- ;
- QualName = unqualified(_),
- % The class interface should be fully module qualified
- % by prog_io.m at the time it is read in.
- error("add_default_class_method_func_modes: unqualified func")
- ),
- list__length(TypesAndModes, PredArity),
- module_info_get_predicate_table(!.ModuleInfo, PredTable),
- (
- predicate_table_search_pf_m_n_a(PredTable, is_fully_qualified,
- PorF, ModuleName, Name, PredArity, [PredId])
- ->
- module_info_pred_info(!.ModuleInfo, PredId, PredInfo0),
- (
- PorF = function,
- maybe_add_default_func_mode(PredInfo0, PredInfo, MaybeProc),
- (
- MaybeProc = no
- ;
- MaybeProc = yes(ProcId),
- NewPredProc = yes(PredId - ProcId),
- !:PredProcIds = [NewPredProc | !.PredProcIds],
- module_info_set_pred_info(PredId, PredInfo, !ModuleInfo)
- )
- ;
- PorF = predicate,
- pred_info_procedures(PredInfo0, Procs),
- ( map__is_empty(Procs) ->
- pred_method_with_no_modes_error(PredInfo0, !IO)
- ;
- true
- )
- )
- ;
- error("handle_methods_with_no_modes")
- )
- ;
- true
- ),
- check_method_modes(Methods, !PredProcIds, !ModuleInfo, !IO).
-
-:- pred module_add_instance_defn(module_name::in, list(prog_constraint)::in,
- sym_name::in, list(type)::in, instance_body::in, tvarset::in,
- import_status::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-module_add_instance_defn(InstanceModuleName, Constraints, ClassName,
- Types, Body0, VarSet, Status, Context, !ModuleInfo, !IO) :-
- module_info_classes(!.ModuleInfo, Classes),
- module_info_instances(!.ModuleInfo, Instances0),
- list__length(Types, ClassArity),
- ClassId = class_id(ClassName, ClassArity),
- Body = expand_bang_state_var_args_in_instance_method_heads(Body0),
- (
- map__search(Classes, ClassId, _)
- ->
- map__init(Empty),
- NewInstanceDefn = hlds_instance_defn(InstanceModuleName, Status,
- Context, Constraints, Types, Body, no, VarSet, Empty),
- map__lookup(Instances0, ClassId, InstanceDefns),
- check_for_overlapping_instances(NewInstanceDefn, InstanceDefns,
- ClassId, !IO),
- map__det_update(Instances0, ClassId,
- [NewInstanceDefn | InstanceDefns], Instances),
- module_info_set_instances(Instances, !ModuleInfo)
- ;
- undefined_type_class_error(ClassName, ClassArity, Context,
- "instance declaration", !IO)
- ).
-
-:- pred check_for_overlapping_instances(hlds_instance_defn::in,
- list(hlds_instance_defn)::in, class_id::in, io::di, io::uo) is det.
-
-check_for_overlapping_instances(NewInstanceDefn, InstanceDefns, ClassId,
- !IO) :-
- IsOverlapping = (pred((Context - OtherContext)::out) is nondet :-
- NewInstanceDefn = hlds_instance_defn(_, _Status, Context,
- _, Types, Body, _, VarSet, _),
- Body \= abstract, % XXX
- list__member(OtherInstanceDefn, InstanceDefns),
- OtherInstanceDefn = hlds_instance_defn(_, _OtherStatus,
- OtherContext, _, OtherTypes, OtherBody,
- _, OtherVarSet, _),
- OtherBody \= abstract, % XXX
- varset__merge(VarSet, OtherVarSet, OtherTypes, _NewVarSet,
- NewOtherTypes),
- type_list_subsumes(Types, NewOtherTypes, _)
- ),
- aggregate(IsOverlapping, report_overlapping_instance_declaration(ClassId),
- !IO).
-
-:- pred report_overlapping_instance_declaration(class_id::in,
- pair(prog_context)::in, io::di, io::uo) is det.
-
-report_overlapping_instance_declaration(class_id(ClassName, ClassArity),
- Context - OtherContext, !IO) :-
- io__set_exit_status(1, !IO),
- Pieces1 = [words("Error: multiply defined (or overlapping)"),
- words("instance declarations for class"),
- sym_name_and_arity(ClassName / ClassArity),
- suffix("."), nl],
- Pieces2 = [words("Previous instance declaration was here.")],
- write_error_pieces(Context, 0, Pieces1, !IO),
- write_error_pieces(OtherContext, 0, Pieces2, !IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_new_pred(tvarset::in, existq_tvars::in, sym_name::in,
- list(type)::in, purity::in, prog_constraints::in,
- pred_markers::in, prog_context::in, import_status::in,
- need_qualifier::in, pred_or_func::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
- % NB. Predicates are also added in lambda.m, which converts
- % lambda expressions into separate predicates, so any changes may need
- % to be reflected there too.
-
-add_new_pred(TVarSet, ExistQVars, PredName, Types, Purity, ClassContext,
- Markers0, Context, ItemStatus, NeedQual, PredOrFunc, !ModuleInfo,
- !IO) :-
- % Only preds with opt_imported clauses are tagged as opt_imported, so
- % that the compiler doesn't look for clauses for other preds read in
- % from optimization interfaces.
- ( ItemStatus = opt_imported ->
- Status = imported(interface)
- ;
- Status = ItemStatus
- ),
- module_info_name(!.ModuleInfo, ModuleName),
- list__length(Types, Arity),
- (
- PredName = unqualified(_PName),
- module_info_incr_errors(!ModuleInfo),
- unqualified_pred_error(PredName, Arity, Context, !IO)
- % All predicate names passed into this predicate should have
- % been qualified by prog_io.m, when they were first read.
- ;
- PredName = qualified(MNameOfPred, PName),
- module_info_get_predicate_table(!.ModuleInfo, PredTable0),
- clauses_info_init(Arity, ClausesInfo),
- map__init(Proofs),
- map__init(ConstraintMap),
- purity_to_markers(Purity, PurityMarkers),
- markers_to_marker_list(PurityMarkers, MarkersList),
- list__foldl(add_marker, MarkersList, Markers0, Markers),
- globals__io_lookup_string_option(aditi_user, Owner, !IO),
- pred_info_init(ModuleName, PredName, Arity, PredOrFunc, Context,
- user(PredName), Status, none, Markers, Types, TVarSet, ExistQVars,
- ClassContext, Proofs, ConstraintMap, Owner, ClausesInfo,
- PredInfo0),
- (
- predicate_table_search_pf_m_n_a(PredTable0,
- is_fully_qualified, PredOrFunc, MNameOfPred,
- PName, Arity, [OrigPred|_])
- ->
- module_info_pred_info(!.ModuleInfo, OrigPred, OrigPredInfo),
- pred_info_context(OrigPredInfo, OrigContext),
- DeclString = pred_or_func_to_str(PredOrFunc),
- adjust_func_arity(PredOrFunc, OrigArity, Arity),
- multiple_def_error(ItemStatus, PredName, OrigArity, DeclString,
- Context, OrigContext, FoundError, !IO),
- (
- FoundError = yes,
- module_info_incr_errors(!ModuleInfo)
- ;
- FoundError = no
- )
- ;
- module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
- predicate_table_insert(PredInfo0, NeedQual, PQInfo, PredId,
- PredTable0, PredTable1),
- ( pred_info_is_builtin(PredInfo0) ->
- add_builtin(PredId, Types, PredInfo0, PredInfo),
- predicate_table_get_preds(PredTable1, Preds1),
- map__det_update(Preds1, PredId, PredInfo, Preds),
- predicate_table_set_preds(Preds, PredTable1, PredTable)
- ;
- PredTable = PredTable1
- ),
- module_info_set_predicate_table(PredTable, !ModuleInfo)
- )
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred maybe_check_field_access_function(sym_name::in, arity::in,
- import_status::in, prog_context::in, module_info::in,
- io::di, io::uo) is det.
-
-maybe_check_field_access_function(FuncName, FuncArity, Status, Context,
- Module, !IO) :-
- (
- is_field_access_function_name(Module, FuncName, FuncArity,
- AccessType, FieldName)
- ->
- check_field_access_function(AccessType, FieldName, FuncName,
- FuncArity, Status, Context, Module, !IO)
- ;
- true
- ).
-
-:- pred check_field_access_function(field_access_type::in, ctor_field_name::in,
- sym_name::in, arity::in, import_status::in, prog_context::in,
- module_info::in, io::di, io::uo) is det.
-
-check_field_access_function(_AccessType, FieldName, FuncName, FuncArity,
- FuncStatus, Context, Module, !IO) :-
- adjust_func_arity(function, FuncArity, PredArity),
- FuncCallId = function - FuncName/PredArity,
-
- %
- % Check that a function applied to an exported type
- % is also exported.
- %
- module_info_ctor_field_table(Module, CtorFieldTable),
- (
- % Abstract types have status `abstract_exported',
- % so errors won't be reported for local field
- % access functions for them.
- map__search(CtorFieldTable, FieldName, [FieldDefn]),
- FieldDefn = hlds_ctor_field_defn(_, DefnStatus, _, _, _),
- DefnStatus = exported, FuncStatus \= exported
- ->
- report_field_status_mismatch(Context, FuncCallId, !IO)
- ;
- true
- ).
-
-:- pred report_field_status_mismatch(prog_context::in, simple_call_id::in,
- io::di, io::uo) is det.
-
-report_field_status_mismatch(Context, CallId, !IO) :-
- CallIdString = hlds_out__simple_call_id_to_string(CallId),
- ErrorPieces = [
- words("In declaration of"),
- fixed(string__append(CallIdString, ":")),
- nl,
- words("error: a field access function for an"),
- words("exported field must also be exported.")
- ],
- error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
- io__set_exit_status(1, !IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_builtin(pred_id::in, list(type)::in, pred_info::in, pred_info::out)
- is det.
-
- % For a builtin predicate, say foo/2, we add a clause
- %
- % foo(H1, H2) :- foo(H1, H2).
- %
- % This does not generate an infinite loop!
- % Instead, the compiler will generate the usual builtin inline code
- % for foo/2 in the body. The reason for generating this
- % forwarding code stub is so that things work correctly if
- % you take the address of the predicate.
-
-add_builtin(PredId, Types, !PredInfo) :-
- %
- % lookup some useful info: Module, Name, Context, HeadVars
- %
- Module = pred_info_module(!.PredInfo),
- Name = pred_info_name(!.PredInfo),
- pred_info_context(!.PredInfo, Context),
- pred_info_clauses_info(!.PredInfo, ClausesInfo0),
- clauses_info_varset(ClausesInfo0, VarSet),
- clauses_info_headvars(ClausesInfo0, HeadVars),
-
- %
- % construct the pseudo-recursive call to Module:Name(HeadVars)
- %
- SymName = qualified(Module, Name),
- ModeId = invalid_proc_id, % mode checking will figure it out
- MaybeUnifyContext = no,
- Call = call(PredId, ModeId, HeadVars, inline_builtin, MaybeUnifyContext,
- SymName),
-
- %
- % construct a clause containing that pseudo-recursive call
- %
- goal_info_init(Context, GoalInfo0),
- set__list_to_set(HeadVars, NonLocals),
- goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
- Goal = Call - GoalInfo,
- Clause = clause([], Goal, mercury, Context),
-
- %
- % put the clause we just built into the pred_info,
- % annotateed with the appropriate types
- %
- map__from_corresponding_lists(HeadVars, Types, VarTypes),
- map__init(TVarNameMap),
- rtti_varmaps_init(RttiVarMaps),
- HasForeignClauses = no,
- set_clause_list([Clause], ClausesRep),
- ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
- HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses),
- pred_info_set_clauses_info(ClausesInfo, !PredInfo),
-
- %
- % It's pointless but harmless to inline these clauses.
- % The main purpose of the `no_inline' marker is to stop
- % constraint propagation creating real infinite loops in
- % the generated code when processing calls to these
- % predicates. The code generator will still generate
- % inline code for calls to these predicates.
- %
- pred_info_get_markers(!.PredInfo, Markers0),
- add_marker(no_inline, Markers0, Markers),
- pred_info_set_markers(Markers, !PredInfo).
-
-%-----------------------------------------------------------------------------%
-
-:- pred add_special_preds(tvarset::in, (type)::in, type_ctor::in,
- hlds_type_body::in, prog_context::in, import_status::in,
- module_info::in, module_info::out) is det.
-
- % The only place that the index predicate for a type can ever
- % be called from is the compare predicate for that type.
- % The only types whose compare predicates call the type's index
- % predicate are discriminated union types which
- %
- % - do not have user-defined equality (the compare predicates for
- % types with user-defined equality generate a runtime abort),
- %
- % - are not enums (comparison predicates for enums just do an integer
- % comparison), and
- %
- % - have more than one constructor (for types with only one
- % constructor, the comparison predicate just deconstructs the
- % arguments and compares them).
- %
- % The compare predicate for an equivalence type never calls the index
- % predicate for that type; it calls the compare predicate of the
- % expanded type instead.
- %
- % When we see an abstract type declaration, we do not declare an index
- % predicate for that type, since the actual type definition may later
- % turn out not to require one. If the type does turn out to need
- % an index predicate, its declaration will be generated together with
- % its implementation.
- %
- % We also do not declare index predicates for types with hand defined
- % RTTI, since such types do not have index predicates.
- %
- % What we do here for uu types does not matter much, since such types
- % are not yet supported.
- %
- % Note: this predicate should include index in the list of special
- % predicates to be defined only for the kinds of types which do not
- % lead unify_proc__generate_index_clauses to abort.
-
-add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
- !ModuleInfo) :-
- (
- special_pred_is_generated_lazily(!.ModuleInfo, TypeCtor, Body, Status)
- ->
- true
- ;
- can_generate_special_pred_clauses_for_type(!.ModuleInfo, TypeCtor,
- Body)
- ->
- add_special_pred(unify, TVarSet, Type, TypeCtor, Body, Context,
- Status, !ModuleInfo),
- status_defined_in_this_module(Status, ThisModule),
- (
- ThisModule = yes,
- (
- Ctors = Body ^ du_type_ctors,
- Body ^ du_type_is_enum = no,
- Body ^ du_type_usereq = no,
- module_info_globals(!.ModuleInfo, Globals),
- globals__lookup_int_option(Globals, compare_specialization,
- CompareSpec),
- list__length(Ctors, CtorCount),
- CtorCount > CompareSpec
- ->
- SpecialPredIds = [index, compare]
- ;
- SpecialPredIds = [compare]
- ),
- add_special_pred_list(SpecialPredIds, TVarSet, Type, TypeCtor,
- Body, Context, Status, !ModuleInfo)
- ;
- ThisModule = no,
- % Never add clauses for comparison predicates
- % for imported types -- they will never be used.
- module_info_get_special_pred_map(!.ModuleInfo, SpecialPreds),
- ( map__contains(SpecialPreds, compare - TypeCtor) ->
- true
- ;
- add_special_pred_decl(compare, TVarSet, Type, TypeCtor, Body,
- Context, Status, !ModuleInfo)
- )
- ),
- (
- type_util__type_body_is_solver_type(!.ModuleInfo, Body)
- ->
- add_special_pred(initialise, TVarSet, Type, TypeCtor, Body,
- Context, Status, !ModuleInfo)
- ;
- true
- )
- ;
- ( type_util__type_body_is_solver_type(!.ModuleInfo, Body) ->
- SpecialPredIds = [unify, compare, initialise]
- ;
- SpecialPredIds = [unify, compare]
- ),
- add_special_pred_decl_list(SpecialPredIds, TVarSet, Type,
- TypeCtor, Body, Context, Status, !ModuleInfo)
- ).
-
-:- pred add_special_pred_list(list(special_pred_id)::in, tvarset::in,
- (type)::in, type_ctor::in, hlds_type_body::in, prog_context::in,
- import_status::in, module_info::in, module_info::out) is det.
-
-add_special_pred_list([], _, _, _, _, _, _, !ModuleInfo).
-add_special_pred_list([SpecialPredId | SpecialPredIds], TVarSet, Type,
- TypeCtor, Body, Context, Status, !ModuleInfo) :-
- add_special_pred(SpecialPredId, TVarSet, Type,
- TypeCtor, Body, Context, Status, !ModuleInfo),
- add_special_pred_list(SpecialPredIds, TVarSet, Type,
- TypeCtor, Body, Context, Status, !ModuleInfo).
-
-:- pred add_special_pred(special_pred_id::in, tvarset::in, (type)::in,
- type_ctor::in, hlds_type_body::in, prog_context::in, import_status::in,
- module_info::in, module_info::out) is det.
-
-add_special_pred(SpecialPredId, TVarSet, Type, TypeCtor, TypeBody, Context,
- Status0, !ModuleInfo) :-
- module_info_globals(!.ModuleInfo, Globals),
- globals__lookup_bool_option(Globals, special_preds, GenSpecialPreds),
- (
- GenSpecialPreds = yes,
- add_special_pred_for_real(SpecialPredId, TVarSet, Type,
- TypeCtor, TypeBody, Context, Status0, !ModuleInfo)
- ;
- GenSpecialPreds = no,
- (
- SpecialPredId = unify,
- add_special_pred_unify_status(TypeBody, Status0, Status),
- add_special_pred_for_real(SpecialPredId, TVarSet, Type,
- TypeCtor, TypeBody, Context, Status, !ModuleInfo)
- ;
- SpecialPredId = index
- ;
- SpecialPredId = compare,
- ( TypeBody ^ du_type_usereq = yes(_) ->
- % The compiler generated comparison
- % procedure prints an error message,
- % since comparisons of types with
- % user-defined equality are not
- % allowed. We get the runtime system
- % invoke this procedure instead of
- % printing the error message itself,
- % because it is easier to generate
- % a good error message in Mercury code
- % than in C code.
- add_special_pred_for_real(SpecialPredId,
- TVarSet, Type, TypeCtor, TypeBody,
- Context, Status0, !ModuleInfo)
- ;
- true
- )
- ;
- SpecialPredId = initialise,
- ( type_is_solver_type(!.ModuleInfo, Type) ->
- add_special_pred_for_real(SpecialPredId,
- TVarSet, Type, TypeCtor, TypeBody,
- Context, Status0, !ModuleInfo)
- ;
- error("make_hlds.add_special_pred: " ++
- "attempt to add initialise pred " ++
- "for non-solver type")
- )
- )
- ).
-
-add_special_pred_for_real(SpecialPredId, TVarSet, Type0, TypeCtor,
- TypeBody, Context, Status0, !ModuleInfo) :-
- Type = adjust_types_with_special_preds_in_private_builtin(Type0),
- adjust_special_pred_status(SpecialPredId, Status0, Status),
- module_info_get_special_pred_map(!.ModuleInfo, SpecialPredMap0),
- ( map__contains(SpecialPredMap0, SpecialPredId - TypeCtor) ->
- true
- ;
- add_special_pred_decl_for_real(SpecialPredId, TVarSet,
- Type, TypeCtor, Context, Status, !ModuleInfo)
- ),
- module_info_get_special_pred_map(!.ModuleInfo, SpecialPredMap1),
- map__lookup(SpecialPredMap1, SpecialPredId - TypeCtor, PredId),
- module_info_preds(!.ModuleInfo, Preds0),
- map__lookup(Preds0, PredId, PredInfo0),
- % if the type was imported, then the special preds for that
- % type should be imported too
- (
- (Status = imported(_) ; Status = pseudo_imported)
- ->
- pred_info_set_import_status(Status, PredInfo0, PredInfo1)
- ;
- TypeBody ^ du_type_usereq = yes(_),
- pred_info_import_status(PredInfo0, OldStatus),
- OldStatus = pseudo_imported,
- status_is_imported(Status, no)
- ->
- % We can only get here with --no-special-preds if the old
- % status is from an abstract declaration of the type.
- % Since the compiler did not then know that the type definition
- % will specify a user-defined equality predicate, it set up
- % the status as pseudo_imported in order to prevent the
- % generation of code for mode 0 of the unify predicate
- % for the type. However, for types with user-defined equality,
- % we *do* want to generate code for mode 0 of unify,
- % so we fix the status.
- pred_info_set_import_status(Status, PredInfo0, PredInfo1)
- ;
- PredInfo1 = PredInfo0
- ),
- unify_proc__generate_clause_info(SpecialPredId, Type, TypeBody,
- Context, !.ModuleInfo, ClausesInfo),
- pred_info_set_clauses_info(ClausesInfo, PredInfo1, PredInfo2),
- pred_info_get_markers(PredInfo2, Markers2),
- add_marker(calls_are_fully_qualified, Markers2, Markers),
- pred_info_set_markers(Markers, PredInfo2, PredInfo3),
- pred_info_set_origin(special_pred(SpecialPredId - TypeCtor),
- PredInfo3, PredInfo),
- map__det_update(Preds0, PredId, PredInfo, Preds),
- module_info_set_preds(Preds, !ModuleInfo).
-
- % These types need to have the builtin qualifier removed
- % so that their special predicates type check.
-:- func adjust_types_with_special_preds_in_private_builtin(type) = (type).
-
-adjust_types_with_special_preds_in_private_builtin(Type) = NormalizedType :-
- ( type_to_ctor_and_args(Type, TypeCtor, []) ->
- ( is_builtin_types_special_preds_defined_in_mercury(TypeCtor, Name) ->
- construct_type(unqualified(Name) - 0, [], NormalizedType)
- ;
- NormalizedType = Type
- )
- ;
- NormalizedType = Type
- ).
-
-:- pred add_special_pred_decl_list(list(special_pred_id)::in, tvarset::in,
- (type)::in, type_ctor::in, hlds_type_body::in, prog_context::in,
- import_status::in, module_info::in, module_info::out) is det.
-
-add_special_pred_decl_list([], _, _, _, _, _, _, !ModuleInfo).
-add_special_pred_decl_list([SpecialPredId | SpecialPredIds], TVarSet, Type,
- TypeCtor, TypeBody, Context, Status, !ModuleInfo) :-
- add_special_pred_decl(SpecialPredId, TVarSet, Type,
- TypeCtor, TypeBody, Context, Status, !ModuleInfo),
- add_special_pred_decl_list(SpecialPredIds, TVarSet, Type,
- TypeCtor, TypeBody, Context, Status, !ModuleInfo).
-
-:- pred add_special_pred_decl(special_pred_id::in, tvarset::in, (type)::in,
- type_ctor::in, hlds_type_body::in, prog_context::in, import_status::in,
- module_info::in, module_info::out) is det.
-
-add_special_pred_decl(SpecialPredId, TVarSet, Type, TypeCtor, TypeBody,
- Context, Status0, !ModuleInfo) :-
- module_info_globals(!.ModuleInfo, Globals),
- globals__lookup_bool_option(Globals, special_preds, GenSpecialPreds),
- ( GenSpecialPreds = yes ->
- add_special_pred_decl_for_real(SpecialPredId,
- TVarSet, Type, TypeCtor, Context, Status0, !ModuleInfo)
- ; SpecialPredId = unify ->
- add_special_pred_unify_status(TypeBody, Status0, Status),
- add_special_pred_decl_for_real(SpecialPredId, TVarSet, Type,
- TypeCtor, Context, Status, !ModuleInfo)
- ;
- true
- ).
-
-add_special_pred_decl_for_real(SpecialPredId, TVarSet, Type, TypeCtor,
- Context, Status0, !ModuleInfo) :-
- module_info_name(!.ModuleInfo, ModuleName),
- special_pred_interface(SpecialPredId, Type, ArgTypes, ArgModes, Det),
- Name = special_pred_name(SpecialPredId, TypeCtor),
- ( SpecialPredId = initialise ->
- TypeCtor = TypeSymName - _TypeArity,
- sym_name_get_module_name(TypeSymName, ModuleName, TypeModuleName),
- PredName = qualified(TypeModuleName, Name)
- ;
- PredName = unqualified(Name)
- ),
- special_pred_name_arity(SpecialPredId, _, Arity),
- clauses_info_init(Arity, ClausesInfo0),
- Origin = special_pred(SpecialPredId - TypeCtor),
- adjust_special_pred_status(SpecialPredId, Status0, Status),
- map__init(Proofs),
- map__init(ConstraintMap),
- init_markers(Markers),
- % XXX If/when we have "comparable" or "unifiable" typeclasses,
- % XXX this context might not be empty
- ClassContext = constraints([], []),
- ExistQVars = [],
- module_info_globals(!.ModuleInfo, Globals),
- globals__lookup_string_option(Globals, aditi_user, Owner),
- pred_info_init(ModuleName, PredName, Arity, predicate, Context,
- Origin, Status, none, Markers, ArgTypes, TVarSet, ExistQVars,
- ClassContext, Proofs, ConstraintMap, Owner, ClausesInfo0, PredInfo0),
- ArgLives = no,
- varset__init(InstVarSet),
- % Should not be any inst vars here so it's ok to use a
- % fresh inst_varset.
- add_new_proc(InstVarSet, Arity, ArgModes, yes(ArgModes), ArgLives,
- yes(Det), Context, address_is_not_taken, PredInfo0, PredInfo, _),
-
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- predicate_table_insert(PredInfo, PredId, PredicateTable0, PredicateTable),
- module_info_set_predicate_table(PredicateTable, !ModuleInfo),
- module_info_get_special_pred_map(!.ModuleInfo, SpecialPredMap0),
- map__set(SpecialPredMap0, SpecialPredId - TypeCtor, PredId,
- SpecialPredMap),
- module_info_set_special_pred_map(SpecialPredMap, !ModuleInfo).
-
-:- pred add_special_pred_unify_status(hlds_type_body::in, import_status::in,
- import_status::out) is det.
-
-add_special_pred_unify_status(TypeBody, Status0, Status) :-
- ( TypeBody ^ du_type_usereq = yes(_) ->
- % If the type has user-defined equality,
- % then we create a real unify predicate
- % for it, whose body calls the user-specified
- % predicate. The compiler's usual type checking
- % algorithm will handle any necessary
- % disambiguation from predicates with the same
- % name but different argument types, and the
- % usual mode checking algorithm will select
- % the right mode of the chosen predicate.
- Status = Status0
- ;
- Status = pseudo_imported
- ).
-
-:- pred adjust_special_pred_status(special_pred_id::in,
- import_status::in, import_status::out) is det.
-
-adjust_special_pred_status(SpecialPredId, !Status) :-
- ( ( !.Status = opt_imported ; !.Status = abstract_imported ) ->
- !:Status = imported(interface)
- ; !.Status = abstract_exported ->
- !:Status = exported
- ;
- true
- ),
-
- % unification predicates are special - they are
- % "pseudo"-imported/exported (only mode 0 is imported/exported).
- ( SpecialPredId = unify ->
- ( !.Status = imported(_) ->
- !:Status = pseudo_imported
- ; !.Status = exported ->
- !:Status = pseudo_exported
- ;
- true
- )
- ;
- true
- ).
-
-add_new_proc(InstVarSet, Arity, ArgModes, MaybeDeclaredArgModes, MaybeArgLives,
- MaybeDet, Context, IsAddressTaken, PredInfo0, PredInfo, ModeId) :-
- pred_info_procedures(PredInfo0, Procs0),
- pred_info_arg_types(PredInfo0, ArgTypes),
- next_mode_id(Procs0, MaybeDet, ModeId),
- proc_info_init(Context, Arity, ArgTypes, MaybeDeclaredArgModes,
- ArgModes, MaybeArgLives, MaybeDet, IsAddressTaken, NewProc0),
- proc_info_set_inst_varset(InstVarSet, NewProc0, NewProc),
- map__det_insert(Procs0, ModeId, NewProc, Procs),
- pred_info_set_procedures(Procs, PredInfo0, PredInfo).
-
-%-----------------------------------------------------------------------------%
-
- % Add a mode declaration for a predicate.
-
-:- pred module_add_mode(inst_varset::in, sym_name::in, list(mode)::in,
- maybe(determinism)::in, import_status::in, prog_context::in,
- pred_or_func::in, bool::in, pair(pred_id, proc_id)::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
- % We should store the mode varset and the mode condition
- % in the hlds - at the moment we just ignore those two arguments.
-
-module_add_mode(InstVarSet, PredName, Modes, MaybeDet, Status, MContext,
- PredOrFunc, IsClassMethod, PredProcId, !ModuleInfo, !IO) :-
-
- % Lookup the pred or func declaration in the predicate table.
- % If it's not there (or if it is ambiguous), optionally print a
- % warning message and insert an implicit definition for the
- % predicate; it is presumed to be local, and its type
- % will be inferred automatically.
-
- module_info_name(!.ModuleInfo, ModuleName0),
- sym_name_get_module_name(PredName, ModuleName0, ModuleName),
- list__length(Modes, Arity),
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- (
- predicate_table_search_pf_sym_arity(PredicateTable0,
- is_fully_qualified, PredOrFunc, PredName, Arity, [PredId0])
- ->
- PredId = PredId0
- ;
- preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName,
- Arity, Status, IsClassMethod, MContext, user(PredName),
- "mode declaration", PredId, !ModuleInfo, !IO)
- ),
-
- % Lookup the pred_info for this predicate
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable1),
- predicate_table_get_preds(PredicateTable1, Preds0),
- map__lookup(Preds0, PredId, PredInfo0),
-
- module_do_add_mode(InstVarSet, Arity, Modes, MaybeDet, IsClassMethod,
- MContext, PredInfo0, PredInfo, ProcId, !IO),
- map__det_update(Preds0, PredId, PredInfo, Preds),
- predicate_table_set_preds(Preds, PredicateTable1, PredicateTable),
- module_info_set_predicate_table(PredicateTable, !ModuleInfo),
- PredProcId = PredId - ProcId.
-
-:- pred module_do_add_mode(inst_varset::in, arity::in, list(mode)::in,
- maybe(determinism)::in, bool::in, prog_context::in,
- pred_info::in, pred_info::out, proc_id::out, io::di, io::uo) is det.
-
-module_do_add_mode(InstVarSet, Arity, Modes, MaybeDet, IsClassMethod, MContext,
- !PredInfo, ProcId, !IO) :-
- % check that the determinism was specified
- (
- MaybeDet = no,
- pred_info_import_status(!.PredInfo, ImportStatus),
- PredOrFunc = pred_info_is_pred_or_func(!.PredInfo),
- PredModule = pred_info_module(!.PredInfo),
- PredName = pred_info_name(!.PredInfo),
- PredSymName = qualified(PredModule, PredName),
- ( IsClassMethod = yes ->
- unspecified_det_for_method(PredSymName, Arity, PredOrFunc,
- MContext, !IO)
- ; status_is_exported(ImportStatus, yes) ->
- unspecified_det_for_exported(PredSymName, Arity, PredOrFunc,
- MContext, !IO)
- ;
- globals__io_lookup_bool_option(infer_det, InferDet, !IO),
- (
- InferDet = no,
- unspecified_det_for_local(PredSymName, Arity,
- PredOrFunc, MContext, !IO)
- ;
- InferDet = yes
- )
- )
- ;
- MaybeDet = yes(_)
- ),
-
- % add the mode declaration to the pred_info for this procedure.
- ArgLives = no,
- add_new_proc(InstVarSet, Arity, Modes, yes(Modes), ArgLives, MaybeDet,
- MContext, address_is_not_taken, !PredInfo, ProcId).
-
- % Whenever there is a clause or mode declaration for an undeclared
- % predicate, we add an implicit declaration
- % :- pred p(T1, T2, ..., Tn).
- % for that predicate; the real types will be inferred by
- % type inference.
-
-:- pred preds_add_implicit_report_error(module_name::in, pred_or_func::in,
- sym_name::in, arity::in, import_status::in, bool::in, prog_context::in,
- pred_origin::in, string::in, pred_id::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName, Arity,
- Status, IsClassMethod, Context, Origin, Description, PredId,
- !ModuleInfo, !IO) :-
- maybe_undefined_pred_error(PredName, Arity, PredOrFunc, Status,
- IsClassMethod, Context, Description, !IO),
- (
- PredOrFunc = function,
- adjust_func_arity(function, FuncArity, Arity),
- maybe_check_field_access_function(PredName, FuncArity, Status, Context,
- !.ModuleInfo, !IO)
- ;
- PredOrFunc = predicate
- ),
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- preds_add_implicit(!.ModuleInfo, ModuleName, PredName, Arity, Status,
- Context, Origin, PredOrFunc, PredId, PredicateTable0, PredicateTable),
- module_info_set_predicate_table(PredicateTable, !ModuleInfo).
-
-:- pred preds_add_implicit(module_info::in, module_name::in, sym_name::in,
- arity::in, import_status::in, prog_context::in, pred_origin::in,
- pred_or_func::in, pred_id::out,
- predicate_table::in, predicate_table::out) is det.
-
-preds_add_implicit(ModuleInfo, ModuleName, PredName, Arity, Status, Context,
- Origin, PredOrFunc, PredId, !PredicateTable) :-
- clauses_info_init(Arity, ClausesInfo),
- preds_add_implicit_2(ClausesInfo, ModuleInfo, ModuleName, PredName,
- Arity, Status, Context, Origin, PredOrFunc, PredId, !PredicateTable).
-
-:- pred preds_add_implicit_for_assertion(prog_vars::in, module_info::in,
- module_name::in, sym_name::in, arity::in, import_status::in,
- prog_context::in, pred_or_func::in, pred_id::out,
- predicate_table::in, predicate_table::out) is det.
-
-preds_add_implicit_for_assertion(HeadVars, ModuleInfo, ModuleName, PredName,
- Arity, Status, Context, PredOrFunc, PredId, !PredicateTable) :-
- clauses_info_init_for_assertion(HeadVars, ClausesInfo),
- term__context_file(Context, FileName),
- term__context_line(Context, LineNum),
- preds_add_implicit_2(ClausesInfo, ModuleInfo, ModuleName, PredName,
- Arity, Status, Context, assertion(FileName, LineNum),
- PredOrFunc, PredId, !PredicateTable).
-
-:- pred preds_add_implicit_2(clauses_info::in, module_info::in,
- module_name::in, sym_name::in, arity::in, import_status::in,
- prog_context::in, pred_origin::in, pred_or_func::in, pred_id::out,
- predicate_table::in, predicate_table::out) is det.
-
-preds_add_implicit_2(ClausesInfo, ModuleInfo, ModuleName, PredName, Arity,
- Status, Context, Origin, PredOrFunc, PredId, !PredicateTable) :-
- varset__init(TVarSet0),
- make_n_fresh_vars("T", Arity, TypeVars, TVarSet0, TVarSet),
- term__var_list_to_term_list(TypeVars, Types),
- map__init(Proofs),
- map__init(ConstraintMap),
- % The class context is empty since this is an implicit
- % definition. Inference will fill it in.
- ClassContext = constraints([], []),
- % We assume none of the arguments are existentially typed.
- % Existential types must be declared, they won't be inferred.
- ExistQVars = [],
- init_markers(Markers0),
- module_info_globals(ModuleInfo, Globals),
- globals__lookup_string_option(Globals, aditi_user, Owner),
- pred_info_init(ModuleName, PredName, Arity, PredOrFunc, Context,
- Origin, Status, none, Markers0, Types, TVarSet, ExistQVars,
- ClassContext, Proofs, ConstraintMap, Owner, ClausesInfo, PredInfo0),
- add_marker(infer_type, Markers0, Markers),
- pred_info_set_markers(Markers, PredInfo0, PredInfo),
- (
- \+ predicate_table_search_pf_sym_arity(!.PredicateTable,
- is_fully_qualified, PredOrFunc, PredName, Arity, _)
- ->
- module_info_get_partial_qualifier_info(ModuleInfo, MQInfo),
- predicate_table_insert(PredInfo, may_be_unqualified, MQInfo, PredId,
- !PredicateTable)
- ;
- error("preds_add_implicit")
- ).
-
- % This is a quick hack, efficiency could be improved --
- % we should probably store the next available ModeId rather
- % than recomputing it all the time.
- % The unused second argument is there for obsolete historical reasons.
-
-next_mode_id(Procs, _MaybeDet, ModeId) :-
- map__to_assoc_list(Procs, List),
- list__length(List, ModeInt),
- proc_id_to_int(ModeId, ModeInt).
-
-%-----------------------------------------------------------------------------%
-
-:- pred module_add_clause(prog_varset::in, pred_or_func::in, sym_name::in,
- list(prog_term)::in, goal::in, import_status::in, prog_context::in,
- goal_type::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-module_add_clause(ClauseVarSet, PredOrFunc, PredName, Args0, Body, Status,
- Context, GoalType, !ModuleInfo, !QualInfo, !IO) :-
- ( illegal_state_var_func_result(PredOrFunc, Args0, SVar) ->
- IllegalSVarResult = yes(SVar)
- ;
- IllegalSVarResult = no
- ),
- ArityAdjustment = ( if IllegalSVarResult = yes(_) then -1 else 0 ),
- Args = expand_bang_state_var_args(Args0),
- globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
- (
- VeryVerbose = yes,
- io__write_string("% Processing clause for ", !IO),
- write_pred_or_func(PredOrFunc, !IO),
- io__write_string(" `", !IO),
- list__length(Args, PredArity0),
- PredArity = PredArity0 + ArityAdjustment,
- adjust_func_arity(PredOrFunc, OrigArity, PredArity),
- prog_out__write_sym_name_and_arity(PredName/OrigArity, !IO),
- io__write_string("'...\n", !IO)
- ;
- VeryVerbose = no
- ),
-
- % Lookup the pred declaration in the predicate table.
- % (If it's not there, call maybe_undefined_pred_error
- % and insert an implicit declaration for the predicate.)
- module_info_name(!.ModuleInfo, ModuleName),
- list__length(Args, Arity0),
- Arity = Arity0 + ArityAdjustment,
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- (
- predicate_table_search_pf_sym_arity(PredicateTable0,
- is_fully_qualified, PredOrFunc, PredName, Arity, [PredId0])
- ->
- PredId = PredId0,
- ( GoalType = promise(_) ->
- mdbcomp__prim_data__sym_name_to_string(PredName, NameString),
- string__format("%s %s %s (%s).\n",
- [s("Attempted to introduce a predicate"),
- s("for a promise with an identical"),
- s("name to an existing predicate"),
- s(NameString)], String),
- error(String)
- ;
- true
- )
- ;
- % A promise will not have a corresponding pred declaration.
- (
- GoalType = promise(_)
- ->
- term__term_list_to_var_list(Args, HeadVars),
- preds_add_implicit_for_assertion(HeadVars, !.ModuleInfo,
- ModuleName, PredName, Arity, Status, Context, PredOrFunc,
- PredId, PredicateTable0, PredicateTable1),
- module_info_set_predicate_table(PredicateTable1, !ModuleInfo)
- ;
- preds_add_implicit_report_error(ModuleName, PredOrFunc, PredName,
- Arity, Status, no, Context, user(PredName), "clause", PredId,
- !ModuleInfo, !IO)
- )
- ),
- % Lookup the pred_info for this pred,
- % add the clause to the clauses_info in the pred_info,
- % if there are no modes add an `infer_modes' marker,
- % and then save the pred_info.
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable2),
- predicate_table_get_preds(PredicateTable2, Preds0),
- map__lookup(Preds0, PredId, PredInfo0),
- % opt_imported preds are initially tagged as imported and are
- % tagged as opt_imported only if/when we see a clause for them
- ( Status = opt_imported ->
- pred_info_set_import_status(opt_imported, PredInfo0, PredInfo0a),
- pred_info_get_markers(PredInfo0a, Markers0),
- add_marker(calls_are_fully_qualified, Markers0, Markers1),
- pred_info_set_markers(Markers1, PredInfo0a, PredInfo1)
- ;
- PredInfo1 = PredInfo0
- ),
- (
- IllegalSVarResult = yes(StateVar)
- ->
- report_illegal_func_svar_result(Context, ClauseVarSet, StateVar, !IO)
- ;
- %
- % User-supplied clauses for field access functions are
- % not allowed -- the clauses are always generated by the
- % compiler.
- %
- PredOrFunc = function,
- adjust_func_arity(function, FuncArity, Arity),
- is_field_access_function_name(!.ModuleInfo, PredName, FuncArity, _, _),
-
- % Don't report errors for clauses for field access
- % function clauses in `.opt' files.
- Status \= opt_imported
- ->
- module_info_incr_errors(!ModuleInfo),
- CallIdString0 = hlds_out__simple_call_id_to_string(
- PredOrFunc - PredName/Arity),
- string__append(CallIdString0, ".", CallIdString),
- ErrorPieces0 = [
- words("Error: clause for automatically generated"),
- words("field access"),
- fixed(CallIdString),
- nl
- ],
- globals__io_lookup_bool_option(verbose_errors, Verbose, !IO),
- (
- Verbose = yes,
- ErrorPieces1 = [
- words("Clauses for field access functions"),
- words("are automatically generated by the"),
- words("compiler. To supply your own"),
- words("definition for a field access"),
- words("function, for example to check"),
- words("the input to a field update,"),
- words("give the field of the constructor a"),
- words("different name.")
- ],
- list__append(ErrorPieces0, ErrorPieces1, ErrorPieces)
- ;
- Verbose = no,
- ErrorPieces = ErrorPieces0
- ),
- error_util__write_error_pieces(Context, 0, ErrorPieces, !IO)
- ;
- % Ignore clauses for builtins. This makes bootstrapping
- % easier when redefining builtins to use normal Mercury code.
- pred_info_is_builtin(PredInfo1)
- ->
- prog_out__write_context(Context, !IO),
- report_warning("Warning: clause for builtin.\n", !IO)
- ;
- pred_info_clauses_info(PredInfo1, Clauses0),
- pred_info_typevarset(PredInfo1, TVarSet0),
- maybe_add_default_func_mode(PredInfo1, PredInfo2, _),
- select_applicable_modes(Args, ClauseVarSet, Status, Context,
- PredId, PredInfo2, ArgTerms, ProcIdsForThisClause,
- !ModuleInfo, !QualInfo, !IO),
- clauses_info_add_clause(ProcIdsForThisClause, ClauseVarSet, TVarSet0,
- ArgTerms, Body, Context, Status, PredOrFunc, Arity, GoalType, Goal,
- VarSet, TVarSet, Clauses0, Clauses, Warnings, !ModuleInfo,
- !QualInfo, !IO),
- pred_info_set_clauses_info(Clauses, PredInfo2, PredInfo3),
- ( GoalType = promise(PromiseType) ->
- pred_info_set_goal_type(promise(PromiseType), PredInfo3, PredInfo4)
- ;
- pred_info_update_goal_type(clauses, PredInfo3, PredInfo4)
- ),
- pred_info_set_typevarset(TVarSet, PredInfo4, PredInfo5),
- pred_info_arg_types(PredInfo5, _ArgTVarSet, ExistQVars, ArgTypes),
- pred_info_set_arg_types(TVarSet, ExistQVars, ArgTypes,
- PredInfo5, PredInfo6),
-
- %
- % check if there are still no modes for the predicate,
- % and if so, set the `infer_modes' flag for that predicate
- %
- ProcIds = pred_info_all_procids(PredInfo6),
- ( ProcIds = [] ->
- pred_info_get_markers(PredInfo6, Markers6),
- add_marker(infer_modes, Markers6, Markers),
- pred_info_set_markers(Markers, PredInfo6, PredInfo)
- ;
- PredInfo = PredInfo6
- ),
- map__det_update(Preds0, PredId, PredInfo, Preds),
- predicate_table_set_preds(Preds,
- PredicateTable2, PredicateTable),
- module_info_set_predicate_table(PredicateTable, !ModuleInfo),
- ( Status \= opt_imported ->
- % warn about singleton variables
- maybe_warn_singletons(VarSet,
- PredOrFunc - PredName/Arity, !.ModuleInfo,
- Goal, !IO),
- % warn about variables with overlapping scopes
- maybe_warn_overlap(Warnings, VarSet,
- PredOrFunc - PredName/Arity, !IO)
- ;
- true
- )
- ).
-
- % Extract the mode annotations (if any) from the clause arguments,
- % and determine which mode(s) this clause should apply to.
-
-:- pred select_applicable_modes(list(prog_term)::in, prog_varset::in,
- import_status::in, prog_context::in, pred_id::in, pred_info::in,
- list(prog_term)::out, list(proc_id)::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-select_applicable_modes(Args0, VarSet, Status, Context, PredId, PredInfo,
- Args, ProcIds, !ModuleInfo, !QualInfo, !IO) :-
- get_mode_annotations(Args0, Args, empty, ModeAnnotations),
- (
- ModeAnnotations = modes(ModeList0),
-
- %
- % The user specified some mode annotations on this clause.
- % First module-qualify the mode annotations. The annotations
- % on clauses from `.opt' files will already be fully module
- % qualified.
- %
- ( Status = opt_imported ->
- ModeList = ModeList0
- ;
- qual_info_get_mq_info(!.QualInfo, MQInfo0),
- module_qual__qualify_clause_mode_list(ModeList0, ModeList, Context,
- MQInfo0, MQInfo, !IO),
- qual_info_set_mq_info(MQInfo, !QualInfo)
- ),
-
- %
- % Now find the procedure which matches these mode annotations.
- %
- pred_info_procedures(PredInfo, Procs),
- map__to_assoc_list(Procs, ExistingProcs),
- (
- get_procedure_matching_declmodes(ExistingProcs, ModeList,
- !.ModuleInfo, ProcId)
- ->
- ProcIds = [ProcId]
- ;
- module_info_incr_errors(!ModuleInfo),
- undeclared_mode_error(ModeList, VarSet, PredId, PredInfo,
- !.ModuleInfo, Context, !IO),
- % apply the clause to all modes
- % XXX would it be better to apply it to none?
- ProcIds = pred_info_all_procids(PredInfo)
- )
- ;
- ModeAnnotations = empty,
- ( pred_info_pragma_goal_type(PredInfo) ->
- % We are only allowed to mix foreign procs and
- % mode specific clauses, so make this clause
- % mode specific but apply to all modes.
- ProcIds = pred_info_all_procids(PredInfo)
- ;
- % this means the clauses applies to all modes
- ProcIds = []
- )
- ;
- ModeAnnotations = none,
- ( pred_info_pragma_goal_type(PredInfo) ->
- % We are only allowed to mix foreign procs and
- % mode specific clauses, so make this clause
- % mode specific but apply to all modes.
- ProcIds = pred_info_all_procids(PredInfo)
- ;
- % this means the clauses applies to all modes
- ProcIds = []
- )
- ;
- ModeAnnotations = mixed,
- module_info_incr_errors(!ModuleInfo),
- io__set_exit_status(1, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string("In clause for ", !IO),
- hlds_out__write_pred_id(!.ModuleInfo, PredId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" syntax error: some but not all " ++
- "arguments have mode annotations.\n", !IO),
- % apply the clause to all modes
- % XXX would it be better to apply it to none?
- ProcIds = pred_info_all_procids(PredInfo)
- ).
-
- % Clauses can have mode annotations on them, to indicate that the
- % clause should only be used for particular modes of a predicate.
- % This type specifies the mode annotations on a clause.
-:- type mode_annotations
- ---> empty % No arguments.
-
- ; none % One or more arguments,
- % each without any mode annotations.
-
- ; modes(list(mode))
- % One or more arguments, each with a mode annotation.
-
- ; mixed. % Two or more arguments, including some with mode
- % annotations and some without. (This is not allowed.)
-
- % Extract the mode annotations (if any) from a list of arguments.
-:- pred get_mode_annotations(list(prog_term)::in, list(prog_term)::out,
- mode_annotations::in, mode_annotations::out) is det.
-
-get_mode_annotations([], [], !Annotations).
-get_mode_annotations([Arg0 | Args0], [Arg | Args], !Annotations) :-
- get_mode_annotation(Arg0, Arg, MaybeAnnotation),
- add_annotation(MaybeAnnotation, !Annotations),
- get_mode_annotations(Args0, Args, !Annotations).
-
-:- pred add_annotation(maybe(mode)::in,
- mode_annotations::in, mode_annotations::out) is det.
-
-add_annotation(no, empty, none).
-add_annotation(yes(Mode), empty, modes([Mode])).
-add_annotation(no, modes(_ `with_type` list(mode)), mixed).
-add_annotation(yes(Mode), modes(Modes), modes(Modes ++ [Mode])).
-add_annotation(no, none, none).
-add_annotation(yes(_), none, mixed).
-add_annotation(_, mixed, mixed).
-
- % Extract the mode annotations (if any) from a single argument.
-:- pred get_mode_annotation(prog_term::in, prog_term::out, maybe(mode)::out)
- is det.
-
-get_mode_annotation(Arg0, Arg, MaybeAnnotation) :-
- (
- Arg0 = term__functor(term__atom("::"), [Arg1, ModeTerm], _),
- convert_mode(allow_constrained_inst_var, term__coerce(ModeTerm), Mode)
- ->
- Arg = Arg1,
- MaybeAnnotation = yes(Mode)
- ;
- Arg = Arg0,
- MaybeAnnotation = no
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Generate the clauses_info for the introduced predicate that we generate
-% for each method in a type class instance declaration.
-%
-
- % handle the `pred(<MethodName>/<Arity>) is <ImplName>' syntax
-produce_instance_method_clauses(name(InstancePredName), PredOrFunc, PredArity,
- ArgTypes, Markers, Context, _Status, ClausesInfo,
- !ModuleInfo, !QualInfo, !IO) :-
-
- % Add the body of the introduced pred
-
- % First the goal info
- goal_info_init(GoalInfo0),
- goal_info_set_context(GoalInfo0, Context, GoalInfo1),
- set__list_to_set(HeadVars, NonLocals),
- goal_info_set_nonlocals(GoalInfo1, NonLocals, GoalInfo2),
- ( check_marker(Markers, (impure)) ->
- goal_info_add_feature(GoalInfo2, (impure), GoalInfo)
- ; check_marker(Markers, (semipure)) ->
- goal_info_add_feature(GoalInfo2, (semipure), GoalInfo)
- ;
- GoalInfo = GoalInfo2
- ),
-
- % Then the goal itself
- varset__init(VarSet0),
- make_n_fresh_vars("HeadVar__", PredArity, HeadVars, VarSet0, VarSet),
- construct_pred_or_func_call(invalid_pred_id, PredOrFunc,
- InstancePredName, HeadVars, GoalInfo, IntroducedGoal, !QualInfo),
- IntroducedClause = clause([], IntroducedGoal, mercury, Context),
-
- map__from_corresponding_lists(HeadVars, ArgTypes, VarTypes),
- map__init(TVarNameMap),
- rtti_varmaps_init(RttiVarMaps),
- HasForeignClauses = no,
- set_clause_list([IntroducedClause], ClausesRep),
- ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
- HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses).
-
- % handle the arbitrary clauses syntax
-produce_instance_method_clauses(clauses(InstanceClauses), PredOrFunc,
- PredArity, _ArgTypes, _Markers, Context, Status, ClausesInfo,
- !ModuleInfo, !QualInfo, !IO) :-
- clauses_info_init(PredArity, ClausesInfo0),
- list__foldl4(produce_instance_method_clause(PredOrFunc, Context, Status),
- InstanceClauses, !ModuleInfo, !QualInfo,
- ClausesInfo0, ClausesInfo, !IO).
-
-:- pred produce_instance_method_clause(pred_or_func::in,
- prog_context::in, import_status::in, item::in,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- clauses_info::in, clauses_info::out, io::di, io::uo) is det.
-
-produce_instance_method_clause(PredOrFunc, Context, Status, InstanceClause,
- !ModuleInfo, !QualInfo, !ClausesInfo, !IO) :-
- (
- InstanceClause = clause(CVarSet, PredOrFunc, PredName,
- HeadTerms0, Body)
- ->
- ( illegal_state_var_func_result(PredOrFunc, HeadTerms0, StateVar) ->
- report_illegal_func_svar_result(Context, CVarSet, StateVar, !IO)
- ;
- HeadTerms = expand_bang_state_var_args(HeadTerms0),
- PredArity = list__length(HeadTerms),
- adjust_func_arity(PredOrFunc, Arity, PredArity),
- % The tvarset argument is only used for explicit type
- % qualifications, of which there are none in this
- % clause, so it is set to a dummy value.
- varset__init(TVarSet0),
-
- ProcIds = [],
- % means this clause applies to _every_ mode of the procedure
- GoalType = none, % goal is not a promise
- clauses_info_add_clause(ProcIds, CVarSet, TVarSet0, HeadTerms,
- Body, Context, Status, PredOrFunc, Arity, GoalType, Goal,
- VarSet, _TVarSet, !ClausesInfo, Warnings, !ModuleInfo,
- !QualInfo, !IO),
-
- % warn about singleton variables
- maybe_warn_singletons(VarSet, PredOrFunc - PredName/Arity,
- !.ModuleInfo, Goal, !IO),
-
- % warn about variables with overlapping scopes
- maybe_warn_overlap(Warnings, VarSet, PredOrFunc - PredName/Arity,
- !IO)
- )
- ;
- error("produce_clause: invalid instance item")
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% module_add_pragma_import:
-% Handles `pragma import' declarations, by figuring out which predicate
-% the `pragma import' declaration applies to, and adding a clause
-% for that predicate containing an appropriate HLDS `pragma_c_code'
-% instruction.
-%
-% NB. Any changes here might also require similar changes to the
-% handling of `pragma export' declarations, in export.m.
-
-:- pred module_add_pragma_import(sym_name::in, pred_or_func::in,
- list(mode)::in, pragma_foreign_proc_attributes::in, string::in,
- import_status::in, prog_context::in,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-module_add_pragma_import(PredName, PredOrFunc, Modes, Attributes, C_Function,
- Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- module_info_name(!.ModuleInfo, ModuleName),
- list__length(Modes, Arity),
-
- %
- % print out a progress message
- %
- globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
- ( VeryVerbose = yes ->
- io__write_string("% Processing `:- pragma import' for ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity,
- !IO),
- io__write_string("...\n", !IO)
- ;
- true
- ),
-
- %
- % Lookup the pred declaration in the predicate table.
- % (If it's not there, print an error message and insert
- % a dummy declaration for the predicate.)
- %
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- (
- predicate_table_search_pf_sym_arity(PredicateTable0,
- is_fully_qualified, PredOrFunc, PredName,
- Arity, [PredId0])
- ->
- PredId = PredId0
- ;
- preds_add_implicit_report_error(ModuleName, PredOrFunc,
- PredName, Arity, Status, no, Context, user(PredName),
- "`:- pragma import' declaration", PredId,
- !ModuleInfo, !IO)
- ),
- %
- % Lookup the pred_info for this pred,
- % and check that it is valid.
- %
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable2),
- predicate_table_get_preds(PredicateTable2, Preds0),
- map__lookup(Preds0, PredId, PredInfo0),
- % opt_imported preds are initially tagged as imported and are
- % tagged as opt_imported only if/when we see a clause (including
- % a `pragma import' clause) for them
- ( Status = opt_imported ->
- pred_info_set_import_status(opt_imported, PredInfo0, PredInfo1)
- ;
- PredInfo1 = PredInfo0
- ),
- ( pred_info_is_imported(PredInfo1) ->
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma import' ", !IO),
- io__write_string("declaration for imported ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
- io__write_string(".\n", !IO)
- ; pred_info_clause_goal_type(PredInfo1) ->
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma import' declaration ", !IO),
- io__write_string("for ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
- io__write_string("\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" with preceding clauses.\n", !IO)
- ;
- pred_info_update_goal_type(pragmas, PredInfo1, PredInfo2),
- %
- % add the pragma declaration to the proc_info for this procedure
- %
- pred_info_procedures(PredInfo2, Procs),
- map__to_assoc_list(Procs, ExistingProcs),
- (
- get_procedure_matching_argmodes(ExistingProcs, Modes,
- !.ModuleInfo, ProcId)
- ->
- pred_add_pragma_import(PredId, ProcId, Attributes,
- C_Function, Context, PredInfo2, PredInfo,
- !ModuleInfo, !QualInfo, !IO),
- map__det_update(Preds0, PredId, PredInfo, Preds),
- predicate_table_set_preds(Preds,
- PredicateTable2, PredicateTable),
- module_info_set_predicate_table(PredicateTable,
- !ModuleInfo)
- ;
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma import' ", !IO),
- io__write_string("declaration for undeclared mode ",
- !IO),
- io__write_string("of ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc,
- PredName/Arity, !IO),
- io__write_string(".\n", !IO)
- )
- ).
-
-% pred_add_pragma_import:
-% This is a subroutine of module_add_pragma_import which adds
-% the c_code for a `pragma import' declaration to a pred_info.
-
-:- pred pred_add_pragma_import(pred_id::in, proc_id::in,
- pragma_foreign_proc_attributes::in, string::in, prog_context::in,
- pred_info::in, pred_info::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-pred_add_pragma_import(PredId, ProcId, Attributes, C_Function, Context,
- !PredInfo, !ModuleInfo, !QualInfo, !IO) :-
- pred_info_procedures(!.PredInfo, Procs),
- map__lookup(Procs, ProcId, ProcInfo),
- foreign__make_pragma_import(!.PredInfo, ProcInfo, C_Function, Context,
- PragmaImpl, VarSet, PragmaVars, ArgTypes,
- Arity, PredOrFunc, !ModuleInfo, !IO),
-
- %
- % lookup some information we need from the pred_info and proc_info
- %
- PredName = pred_info_name(!.PredInfo),
- PredModule = pred_info_module(!.PredInfo),
- pred_info_clauses_info(!.PredInfo, Clauses0),
- pred_info_get_purity(!.PredInfo, Purity),
-
- %
- % Add the code for this `pragma import' to the clauses_info
- %
- clauses_info_add_pragma_foreign_proc(Purity, Attributes,
- PredId, ProcId, VarSet, PragmaVars, ArgTypes, PragmaImpl,
- Context, PredOrFunc, qualified(PredModule, PredName),
- Arity, Clauses0, Clauses, !ModuleInfo, !IO),
-
- %
- % Store the clauses_info etc. back into the pred_info
- %
- pred_info_set_clauses_info(Clauses, !PredInfo).
-
-%-----------------------------------------------------------------------------%
-
-:- pred module_add_pragma_foreign_proc(pragma_foreign_proc_attributes::in,
- sym_name::in, pred_or_func::in, list(pragma_var)::in, prog_varset::in,
- pragma_foreign_code_impl::in, import_status::in, prog_context::in,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-module_add_pragma_foreign_proc(Attributes0, PredName, PredOrFunc, PVars, VarSet,
- PragmaImpl, Status, Context, !ModuleInfo, !QualInfo, !IO) :-
- %
- % Begin by replacing any maybe_thread_safe foreign_proc attributes
- % with the actual thread safety attributes which we get from the
- % `--maybe-thread-safe' option.
- %
- globals__io_get_globals(Globals, !IO),
- globals__get_maybe_thread_safe(Globals, MaybeThreadSafe),
- ThreadSafe = Attributes0 ^ thread_safe,
- ( ThreadSafe = maybe_thread_safe ->
- (
- MaybeThreadSafe = yes,
- set_thread_safe(thread_safe, Attributes0, Attributes)
- ;
- MaybeThreadSafe = no,
- set_thread_safe(not_thread_safe, Attributes0, Attributes)
- )
- ;
- Attributes = Attributes0
- ),
- module_info_name(!.ModuleInfo, ModuleName),
- PragmaForeignLanguage = foreign_language(Attributes),
- list__length(PVars, Arity),
- % print out a progress message
- globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
- (
- VeryVerbose = yes,
- io__write_string("% Processing `:- pragma foreign_proc' for ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
- io__write_string("...\n", !IO)
- ;
- VeryVerbose = no
- ),
-
- globals__io_get_backend_foreign_languages(BackendForeignLangs, !IO),
-
- % Lookup the pred declaration in the predicate table.
- % (If it's not there, print an error message and insert
- % a dummy declaration for the predicate.)
- module_info_get_predicate_table(!.ModuleInfo, PredTable0),
- (
- predicate_table_search_pf_sym_arity(PredTable0, is_fully_qualified,
- PredOrFunc, PredName, Arity, [PredId0])
- ->
- PredId = PredId0
- ;
- preds_add_implicit_report_error(ModuleName, PredOrFunc,
- PredName, Arity, Status, no, Context, user(PredName),
- "`:- pragma foreign_proc' declaration",
- PredId, !ModuleInfo, !IO)
- ),
-
- % Lookup the pred_info for this pred, add the pragma to the proc_info
- % in the proc_table in the pred_info, and save the pred_info.
- module_info_get_predicate_table(!.ModuleInfo, PredTable1),
- predicate_table_get_preds(PredTable1, Preds0),
- some [!PredInfo] (
- map__lookup(Preds0, PredId, !:PredInfo),
- PredInfo0 = !.PredInfo,
-
- % opt_imported preds are initially tagged as imported and are
- % tagged as opt_imported only if/when we see a clause (including
- % a `pragma c_code' clause) for them
- ( Status = opt_imported ->
- pred_info_set_import_status(opt_imported, !PredInfo)
- ;
- true
- ),
- (
- % If this procedure was previously defined as clauses only
- % then we need to turn all the non mode-specific clauses
- % into mode-specific clauses.
- pred_info_clause_goal_type(!.PredInfo)
- ->
- pred_info_clauses_info(!.PredInfo, CInfo0),
- clauses_info_clauses_only(CInfo0, ClauseList0),
- ClauseList = list__map(
- (func(C) = Res :-
- AllProcIds = pred_info_all_procids(!.PredInfo),
- ( C = clause([], Goal, mercury, Ctxt) ->
- Res = clause(AllProcIds, Goal, mercury, Ctxt)
- ;
- Res = C
- )
- ), ClauseList0),
- clauses_info_set_clauses(ClauseList, CInfo0, CInfo),
- pred_info_set_clauses_info(CInfo, !PredInfo)
- ;
- true
- ),
- lookup_current_backend(CurrentBackend, !IO),
- (
- ExtraAttrs = extra_attributes(Attributes),
- is_applicable_for_current_backend(CurrentBackend, ExtraAttrs) = no
- ->
- % Ignore this foreign_proc.
- true
- ;
- pred_info_is_imported(!.PredInfo)
- ->
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma foreign_proc' " ++
- "(or `pragma c_code')\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string("declaration for imported ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
- io__write_string(".\n", !IO)
- ;
- % Don't add clauses for foreign languages other
- % than the ones we can generate code for.
- not list__member(PragmaForeignLanguage, BackendForeignLangs)
- ->
- pred_info_update_goal_type(pragmas, PredInfo0, !:PredInfo),
- module_info_set_pred_info(PredId, !.PredInfo, !ModuleInfo)
- ;
- % add the pragma declaration to the proc_info for this procedure
- pred_info_procedures(!.PredInfo, Procs),
- map__to_assoc_list(Procs, ExistingProcs),
- pragma_get_modes(PVars, Modes),
- (
- get_procedure_matching_argmodes(ExistingProcs, Modes,
- !.ModuleInfo, ProcId)
- ->
- pred_info_clauses_info(!.PredInfo, Clauses0),
- pred_info_arg_types(!.PredInfo, ArgTypes),
- pred_info_get_purity(!.PredInfo, Purity),
- clauses_info_add_pragma_foreign_proc(Purity, Attributes,
- PredId, ProcId, VarSet, PVars, ArgTypes, PragmaImpl,
- Context, PredOrFunc, PredName, Arity, Clauses0, Clauses,
- !ModuleInfo, !IO),
- pred_info_set_clauses_info(Clauses, !PredInfo),
- pred_info_update_goal_type(pragmas, !PredInfo),
- map__det_update(Preds0, PredId, !.PredInfo, Preds),
- predicate_table_set_preds(Preds, PredTable1, PredTable),
- module_info_set_predicate_table(PredTable, !ModuleInfo),
- pragma_get_var_infos(PVars, ArgInfo),
- maybe_warn_pragma_singletons(PragmaImpl, PragmaForeignLanguage,
- ArgInfo, Context, PredOrFunc - PredName/Arity,
- !.ModuleInfo, !IO)
- ;
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma foreign_proc' ", !IO),
- io__write_string("declaration for undeclared mode ", !IO),
- io__write_string("of ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity,
- !IO),
- io__write_string(".\n", !IO)
- )
- )
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred module_add_pragma_tabled(eval_method::in, sym_name::in, int::in,
- maybe(pred_or_func)::in, maybe(list(mode))::in, import_status::in,
- prog_context::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-module_add_pragma_tabled(EvalMethod, PredName, Arity, MaybePredOrFunc,
- MaybeModes, Status, Context, !ModuleInfo, !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
- EvalMethodS = eval_method_to_string(EvalMethod),
-
- % Find out if we are tabling a predicate or a function
- (
- MaybePredOrFunc = yes(PredOrFunc0),
- PredOrFunc = PredOrFunc0,
-
- % Lookup the pred declaration in the predicate table.
- % (If it's not there, print an error message and insert
- % a dummy declaration for the predicate.)
- (
- predicate_table_search_pf_sym_arity(PredicateTable0,
- is_fully_qualified, PredOrFunc,
- PredName, Arity, PredIds0)
- ->
- PredIds = PredIds0
- ;
- module_info_name(!.ModuleInfo, ModuleName),
- string__format("`:- pragma %s' declaration",
- [s(EvalMethodS)], Message1),
-
- preds_add_implicit_report_error(ModuleName, PredOrFunc,
- PredName, Arity, Status, no, Context,
- user(PredName), Message1, PredId, !ModuleInfo,
- !IO),
- PredIds = [PredId]
- )
- ;
- MaybePredOrFunc = no,
- (
- predicate_table_search_sym_arity(PredicateTable0,
- is_fully_qualified, PredName,
- Arity, PredIds0)
- ->
- PredIds = PredIds0
- ;
- module_info_name(!.ModuleInfo, ModuleName),
- string__format("`:- pragma %s' declaration",
- [s(EvalMethodS)], Message1),
-
- preds_add_implicit_report_error(ModuleName,
- predicate, PredName, Arity, Status, no,
- Context, user(PredName), Message1, PredId,
- !ModuleInfo, !IO),
- PredIds = [PredId]
- )
- ),
- list__foldl2(module_add_pragma_tabled_2(EvalMethod, PredName,
- Arity, MaybePredOrFunc, MaybeModes, Context),
- PredIds, !ModuleInfo, !IO).
-
-:- pred module_add_pragma_tabled_2(eval_method::in, sym_name::in, int::in,
- maybe(pred_or_func)::in, maybe(list(mode))::in, prog_context::in,
- pred_id::in, module_info::in, module_info::out,
- io::di, io::uo) is det.
-
-module_add_pragma_tabled_2(EvalMethod0, PredName, Arity0, MaybePredOrFunc,
- MaybeModes, Context, PredId, !ModuleInfo, !IO) :-
-
- ( EvalMethod0 = eval_minimal(_) ->
- globals__io_lookup_bool_option(use_minimal_model_own_stacks,
- OwnStacks, !IO),
- (
- OwnStacks = yes,
- EvalMethod = eval_minimal(own_stacks)
- ;
- OwnStacks = no,
- EvalMethod = eval_minimal(stack_copy)
- )
- ;
- EvalMethod = EvalMethod0
- ),
-
- % Lookup the pred_info for this pred,
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable),
- predicate_table_get_preds(PredicateTable, Preds),
- map__lookup(Preds, PredId, PredInfo0),
-
- % Find out if we are tabling a predicate or a function
- (
- MaybePredOrFunc = yes(PredOrFunc0),
- PredOrFunc = PredOrFunc0
- ;
- MaybePredOrFunc = no,
- PredOrFunc = pred_info_is_pred_or_func(PredInfo0)
- ),
- adjust_func_arity(PredOrFunc, Arity0, Arity),
-
- % print out a progress message
- EvalMethodS = eval_method_to_string(EvalMethod),
- globals__io_lookup_bool_option(very_verbose, VeryVerbose, !IO),
- ( VeryVerbose = yes ->
- io__write_string("% Processing `:- pragma ", !IO),
- io__write_string(EvalMethodS, !IO),
- io__write_string("' for ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
- io__write_string("...\n", !IO)
- ;
- true
- ),
-
- % Issue a warning if this predicate/function has a pragma inline
- % declaration. Tabled procedures cannot be inlined.
- pred_info_get_markers(PredInfo0, Markers),
- globals.io_lookup_bool_option(warn_table_with_inline, WarnInline, !IO),
- ( check_marker(Markers, inline), WarnInline = yes ->
- PredNameStr = hlds_out.simple_call_id_to_string(PredOrFunc,
- PredName/Arity),
- TablePragmaStr = string.format("`:- pragma %s'",
- [s(EvalMethodS)]),
- InlineWarning = [
- words("Warning: "), fixed(PredNameStr),
- words("has a"), nl, fixed(TablePragmaStr),
- words("declaration but also has a"),
- fixed("`:- pragma inline'"),
- words("declaration."), nl,
- words("This inline pragma will be ignored"),
- words("since tabled predicates cannot be inlined."), nl,
- words("You can use the"),
- fixed("`--no-warn-table-with-inline'"),
- words("option to suppress this warning.")
- ],
- error_util.report_warning(Context, 0, InlineWarning, !IO)
- ;
- true
- ),
- ( pred_info_is_imported(PredInfo0) ->
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma ", !IO),
- io__write_string(EvalMethodS, !IO),
- io__write_string("' declaration for imported ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc, PredName/Arity, !IO),
- io__write_string(".\n", !IO)
- ;
- % do we have to make sure the tabled preds are stratified?
- (
- eval_method_needs_stratification(EvalMethod) = yes
- ->
- module_info_stratified_preds(!.ModuleInfo,
- StratPredIds0),
- set__insert(StratPredIds0, PredId, StratPredIds),
- module_info_set_stratified_preds(StratPredIds,
- !ModuleInfo)
- ;
- true
- ),
-
- % add the eval model to the proc_info for this procedure
- pred_info_procedures(PredInfo0, Procs0),
- map__to_assoc_list(Procs0, ExistingProcs),
- ( MaybeModes = yes(Modes) ->
- (
- get_procedure_matching_argmodes(ExistingProcs,
- Modes, !.ModuleInfo, ProcId)
- ->
- map__lookup(Procs0, ProcId, ProcInfo0),
- proc_info_set_eval_method(EvalMethod,
- ProcInfo0, ProcInfo),
- map__det_update(Procs0, ProcId, ProcInfo,
- Procs),
- pred_info_set_procedures(Procs,
- PredInfo0, PredInfo),
- module_info_set_pred_info(PredId, PredInfo,
- !ModuleInfo)
- ;
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma ", !IO),
- io__write_string(EvalMethodS, !IO),
- io__write_string("' declaration for " ++
- "undeclared mode of ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc,
- PredName/Arity, !IO),
- io__write_string(".\n", !IO)
- )
- ; ExistingProcs = [] ->
- module_info_incr_errors(!ModuleInfo),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: `:- pragma ", !IO),
- io__write_string(EvalMethodS, !IO),
- io__write_string("' declaration for\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" ", !IO),
- hlds_out__write_simple_call_id(PredOrFunc,
- PredName/Arity, !IO),
- io__write_string(" with no declared modes.\n", !IO)
- ;
- set_eval_method_list(ExistingProcs, Context,
- PredOrFunc, PredName/Arity, EvalMethod,
- Procs0, Procs, !ModuleInfo, !IO),
- pred_info_set_procedures(Procs,
- PredInfo0, PredInfo),
- module_info_set_pred_info(PredId, PredInfo,
- !ModuleInfo)
- )
- ).
-
-:- pred set_eval_method_list(assoc_list(proc_id, proc_info)::in,
- prog_context::in, pred_or_func::in, sym_name_and_arity::in,
- eval_method::in, proc_table::in, proc_table::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-set_eval_method_list([], _, _, _, _, !Procs, !ModuleInfo, !IO).
-set_eval_method_list([ProcId - ProcInfo0 | Rest], Context, PredOrFunc,
- PredNameAndArity, EvalMethod, !Procs, !ModuleInfo, !IO) :-
- proc_info_eval_method(ProcInfo0, OldEvalMethod),
- % NOTE: We don't bother detecting multiple tabling pragmas
- % of the same type here.
- (
- OldEvalMethod \= eval_normal,
- OldEvalMethod \= EvalMethod
- ->
- % If there are conflicting tabling pragmas then
- % emit an error message and do not bother changing
- % the evaluation method.
- OldEvalMethodStr = eval_method_to_string(OldEvalMethod),
- EvalMethodStr = eval_method_to_string(EvalMethod),
- Name = hlds_out.simple_call_id_to_string(PredOrFunc,
- PredNameAndArity),
- ErrorMsg = [
- words("Error:"),
- fixed(Name),
- words("has both"),
- fixed(OldEvalMethodStr),
- words("and"),
- fixed(EvalMethodStr),
- words("pragmas specified."),
- words("Only one kind of"),
- words("tabling pragma may be applied to it.")
- ],
- module_info_incr_errors(!ModuleInfo),
- error_util.write_error_pieces(Context, 0, ErrorMsg, !IO)
- ;
- proc_info_set_eval_method(EvalMethod, ProcInfo0, ProcInfo),
- map__det_update(!.Procs, ProcId, ProcInfo, !:Procs)
- ),
- set_eval_method_list(Rest, Context, PredOrFunc, PredNameAndArity,
- EvalMethod, !Procs, !ModuleInfo, !IO).
-
-%-----------------------------------------------------------------------------%
-
- % from the list of pragma_vars extract the modes.
-:- pred pragma_get_modes(list(pragma_var)::in, list(mode)::out) is det.
-
-pragma_get_modes([], []).
-pragma_get_modes([PragmaVar | Vars], [Mode | Modes]) :-
- PragmaVar = pragma_var(_Var, _Name, Mode),
- pragma_get_modes(Vars, Modes).
-
-%-----------------------------------------------------------------------------%
-
- % from the list of pragma_vars , extract the vars.
-:- pred pragma_get_vars(list(pragma_var)::in, list(prog_var)::out) is det.
-
-pragma_get_vars([], []).
-pragma_get_vars([PragmaVar | PragmaVars], [Var | Vars]) :-
- PragmaVar = pragma_var(Var, _Name, _Mode),
- pragma_get_vars(PragmaVars, Vars).
-
-%---------------------------------------------------------------------------%
-
- % from the list of pragma_vars, extract the names.
-
-:- pred pragma_get_var_infos(list(pragma_var)::in,
- list(maybe(pair(string, mode)))::out) is det.
-
-pragma_get_var_infos([], []).
-pragma_get_var_infos([PragmaVar | PragmaVars], [yes(Name - Mode) | Info]) :-
- PragmaVar = pragma_var(_Var, Name, Mode),
- pragma_get_var_infos(PragmaVars, Info).
-
-%---------------------------------------------------------------------------%
-
- % For each pred_id in the list, check whether markers
- % present in the list of conflicting markers are
- % also present in the corresponding pred_info.
- % The bool indicates whether there was a conflicting marker
- % present.
-
-:- pred pragma_check_markers(pred_table::in, list(pred_id)::in,
- list(marker)::in, bool::out) is det.
-
-pragma_check_markers(_, [], _, no).
-pragma_check_markers(PredTable, [PredId | PredIds], ConflictList,
- WasConflict) :-
- map__lookup(PredTable, PredId, PredInfo),
- pred_info_get_markers(PredInfo, Markers),
- (
- list__member(Marker, ConflictList),
- check_marker(Markers, Marker)
- ->
- WasConflict = yes
- ;
- pragma_check_markers(PredTable, PredIds, ConflictList,
- WasConflict)
- ).
-
- % For each pred_id in the list, add the given markers to the
- % list of markers in the corresponding pred_info.
-
-:- pred pragma_add_marker(list(pred_id)::in,
- add_marker_pred_info::in(add_marker_pred_info), import_status::in,
- bool::in, pred_table::in, pred_table::out, bool::out) is det.
-
-pragma_add_marker([], _, _, _, !PredTable, no).
-pragma_add_marker([PredId | PredIds], UpdatePredInfo, Status, MustBeExported,
- !PredTable, WrongStatus) :-
- map__lookup(!.PredTable, PredId, PredInfo0),
- call(UpdatePredInfo, PredInfo0, PredInfo),
- (
- pred_info_is_exported(PredInfo),
- MustBeExported = yes,
- Status \= exported
- ->
- WrongStatus0 = yes
- ;
- WrongStatus0 = no
- ),
- map__det_update(!.PredTable, PredId, PredInfo, !:PredTable),
- pragma_add_marker(PredIds, UpdatePredInfo, Status,
- MustBeExported, !PredTable, WrongStatus1),
- bool__or(WrongStatus0, WrongStatus1, WrongStatus).
-
-:- pred add_marker_pred_info(marker::in, pred_info::in, pred_info::out)
- is det.
-
-add_marker_pred_info(Marker, !PredInfo) :-
- pred_info_get_markers(!.PredInfo, Markers0),
- add_marker(Marker, Markers0, Markers),
- pred_info_set_markers(Markers, !PredInfo).
-
- % Succeed if a marker for an exported procedure must also
- % be exported.
-:- pred marker_must_be_exported(marker::in) is semidet.
-
-marker_must_be_exported(aditi).
-marker_must_be_exported(base_relation).
-
-%---------------------------------------------------------------------------%
-
- % Find the procedure with argmodes which match the ones we want.
-
-:- pred get_procedure_matching_argmodes(assoc_list(proc_id, proc_info)::in,
- list(mode)::in, module_info::in, proc_id::out) is semidet.
-
-get_procedure_matching_argmodes(Procs, Modes0, ModuleInfo, ProcId) :-
- list__map(constrain_inst_vars_in_mode, Modes0, Modes),
- get_procedure_matching_argmodes_2(Procs, Modes, ModuleInfo, ProcId).
-
-:- pred get_procedure_matching_argmodes_2(assoc_list(proc_id, proc_info)::in,
- list(mode)::in, module_info::in, proc_id::out) is semidet.
-
-get_procedure_matching_argmodes_2([P|Procs], Modes, ModuleInfo, OurProcId) :-
- P = ProcId - ProcInfo,
- proc_info_argmodes(ProcInfo, ArgModes),
- ( mode_list_matches(Modes, ArgModes, ModuleInfo) ->
- OurProcId = ProcId
- ;
- get_procedure_matching_argmodes_2(Procs, Modes, ModuleInfo,
- OurProcId)
- ).
-
- % Find the procedure with declared argmodes which match the ones
- % we want. If there was no mode declaration, then use the inferred
- % argmodes.
-:- pred get_procedure_matching_declmodes(assoc_list(proc_id, proc_info)::in,
- list(mode)::in, module_info::in, proc_id::out) is semidet.
-
-get_procedure_matching_declmodes(Procs, Modes0, ModuleInfo, ProcId) :-
- list__map(constrain_inst_vars_in_mode, Modes0, Modes),
- get_procedure_matching_declmodes_2(Procs, Modes, ModuleInfo, ProcId).
-
-:- pred get_procedure_matching_declmodes_2(assoc_list(proc_id, proc_info)::in,
- list(mode)::in, module_info::in, proc_id::out) is semidet.
-
-get_procedure_matching_declmodes_2([P|Procs], Modes, ModuleInfo, OurProcId) :-
- P = ProcId - ProcInfo,
- proc_info_declared_argmodes(ProcInfo, ArgModes),
- ( mode_list_matches(Modes, ArgModes, ModuleInfo) ->
- OurProcId = ProcId
- ;
- get_procedure_matching_declmodes_2(Procs, Modes, ModuleInfo,
- OurProcId)
- ).
-
-:- pred mode_list_matches(list(mode)::in, list(mode)::in, module_info::in)
- is semidet.
-
-mode_list_matches([], [], _).
-mode_list_matches([Mode1 | Modes1], [Mode2 | Modes2], ModuleInfo) :-
- % Use mode_get_insts_semidet instead of mode_get_insts to avoid
- % aborting if there are undefined modes.
- mode_get_insts_semidet(ModuleInfo, Mode1, Inst1, Inst2),
- mode_get_insts_semidet(ModuleInfo, Mode2, Inst1, Inst2),
- mode_list_matches(Modes1, Modes2, ModuleInfo).
-
-%-----------------------------------------------------------------------------%
-
- % Warn about variables which occur only once but don't start with
- % an underscore, or about variables which do start with an underscore
- % but occur more than once.
- %
-:- pred maybe_warn_overlap(list(quant_warning)::in, prog_varset::in,
- simple_call_id::in, io::di, io::uo) is det.
-
-maybe_warn_overlap(Warnings, VarSet, PredCallId, !IO) :-
- globals__io_lookup_bool_option(warn_overlapping_scopes,
- WarnOverlappingScopes, !IO),
- (
- WarnOverlappingScopes = yes,
- warn_overlap(Warnings, VarSet, PredCallId, !IO)
- ;
- WarnOverlappingScopes = no
- ).
-
-:- pred warn_overlap(list(quant_warning)::in, prog_varset::in,
- simple_call_id::in, io::di, io::uo) is det.
-
-warn_overlap([], _, _, !IO).
-warn_overlap([Warn | Warns], VarSet, PredCallId, !IO) :-
- Warn = warn_overlap(Vars, Context),
- Part1 = [words("In clause for"),
- words(simple_call_id_to_string(PredCallId)), suffix(":"), nl],
- ( Vars = [Var] ->
- Part2 = [words("warning: variable"),
- words("`" ++ mercury_var_to_string(Var, VarSet, no) ++ "'"),
- words("has overlapping scopes.")]
- ;
- Part2 = [words("warning: variables"),
- words("`" ++ mercury_vars_to_string(Vars, VarSet, no) ++ "'"),
- words("each have overlapping scopes.")]
- ),
- write_error_pieces(Context, 0, Part1 ++ Part2, !IO),
- record_warning(!IO),
- warn_overlap(Warns, VarSet, PredCallId, !IO).
-
-%-----------------------------------------------------------------------------%
-
- % Warn about variables which occur only once but don't start with
- % an underscore, or about variables which do start with an underscore
- % but occur more than once, or about variables that do not occur in
- % C code strings when they should.
- %
-:- pred maybe_warn_singletons(prog_varset::in, simple_call_id::in,
- module_info::in, hlds_goal::in, io::di, io::uo) is det.
-
-maybe_warn_singletons(VarSet, PredCallId, ModuleInfo, Body, !IO) :-
- globals__io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars,
- !IO),
- (
- WarnSingletonVars = yes,
- set__init(QuantVars),
- warn_singletons_in_goal(Body, QuantVars, VarSet, PredCallId,
- ModuleInfo, !IO)
- ;
- WarnSingletonVars = no
- ).
-
-:- pred warn_singletons_in_goal(hlds_goal::in, set(prog_var)::in,
- prog_varset::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
-
-warn_singletons_in_goal(Goal - GoalInfo, QuantVars, VarSet, PredCallId, MI,
- !IO) :-
- warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet,
- PredCallId, MI, !IO).
-
-:- pred warn_singletons_in_goal_2(hlds_goal_expr::in, hlds_goal_info::in,
- set(prog_var)::in, prog_varset::in, simple_call_id::in,
- module_info::in, io::di, io::uo) is det.
-
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = conj(Goals),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI,
- !IO).
-
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = par_conj(Goals),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI,
- !IO).
-
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = disj(Goals),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI, !IO).
-
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = switch(_Var, _CanFail, Cases),
- warn_singletons_in_cases(Cases, QuantVars, VarSet, PredCallId, MI, !IO).
-
-warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = not(SubGoal),
- warn_singletons_in_goal(SubGoal, QuantVars, VarSet, PredCallId, MI, !IO).
-
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = scope(Reason, SubGoal),
- %
- % warn if any quantified variables occur only in the quantifier
- %
- (
- ( Reason = exist_quant(Vars)
- ; Reason = promise_equivalent_solutions(Vars)
- ),
- Vars = [_ | _]
- ->
- quantification__goal_vars(SubGoal, SubGoalVars),
- goal_info_get_context(GoalInfo, Context),
- set__init(EmptySet),
- warn_singletons(Vars, GoalInfo, EmptySet, SubGoalVars, VarSet,
- Context, PredCallId, !IO),
- set__insert_list(QuantVars, Vars, SubQuantVars)
- ;
- SubQuantVars = QuantVars
- ),
- warn_singletons_in_goal(SubGoal, SubQuantVars, VarSet, PredCallId, MI,
- !IO).
-
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = if_then_else(Vars, Cond, Then, Else),
- %
- % warn if any quantified variables do not occur in the condition
- % or the "then" part of the if-then-else
- %
- (
- Vars = [_ | _],
- quantification__goal_vars(Cond, CondVars),
- quantification__goal_vars(Then, ThenVars),
- set__union(CondVars, ThenVars, CondThenVars),
- goal_info_get_context(GoalInfo, Context),
- set__init(EmptySet),
- warn_singletons(Vars, GoalInfo, EmptySet, CondThenVars, VarSet,
- Context, PredCallId, !IO)
- ;
- Vars = []
- ),
-
- set__insert_list(QuantVars, Vars, QuantVars1),
- warn_singletons_in_goal(Cond, QuantVars1, VarSet, PredCallId, MI, !IO),
- warn_singletons_in_goal(Then, QuantVars1, VarSet, PredCallId, MI, !IO),
- warn_singletons_in_goal(Else, QuantVars, VarSet, PredCallId, MI, !IO).
-
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- _, !IO) :-
- Goal = call(_, _, Args, _, _, _),
- goal_info_get_nonlocals(GoalInfo, NonLocals),
- goal_info_get_context(GoalInfo, Context),
- warn_singletons(Args, GoalInfo, NonLocals, QuantVars, VarSet, Context,
- PredCallId, !IO).
-
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- _, !IO) :-
- Goal = generic_call(GenericCall, Args0, _, _),
- goal_util__generic_call_vars(GenericCall, Args1),
- list__append(Args0, Args1, Args),
- goal_info_get_nonlocals(GoalInfo, NonLocals),
- goal_info_get_context(GoalInfo, Context),
- warn_singletons(Args, GoalInfo, NonLocals, QuantVars, VarSet, Context,
- PredCallId, !IO).
-
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = unify(Var, RHS, _, _, _),
- warn_singletons_in_unify(Var, RHS, GoalInfo, QuantVars, VarSet,
- PredCallId, MI, !IO).
-
-warn_singletons_in_goal_2(Goal, GoalInfo, _QuantVars, _VarSet, PredCallId,
- MI, !IO) :-
- Goal = foreign_proc(Attrs, _, _, Args, _, PragmaImpl),
- goal_info_get_context(GoalInfo, Context),
- Lang = foreign_language(Attrs),
- NamesModes = list__map(foreign_arg_maybe_name_mode, Args),
- warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang,
- NamesModes, Context, PredCallId, MI, !IO).
-
-warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
- MI, !IO) :-
- Goal = shorthand(ShorthandGoal),
- warn_singletons_in_goal_2_shorthand(ShorthandGoal, GoalInfo,
- QuantVars, VarSet, PredCallId, MI, !IO).
-
-:- pred warn_singletons_in_goal_2_shorthand(shorthand_goal_expr::in,
- hlds_goal_info::in, set(prog_var)::in, prog_varset::in,
- simple_call_id::in, module_info::in, io::di, io::uo) is det.
-
-warn_singletons_in_goal_2_shorthand(bi_implication(LHS, RHS), _GoalInfo,
- QuantVars, VarSet, PredCallId, MI, !IO) :-
- warn_singletons_in_goal_list([LHS, RHS], QuantVars, VarSet,
- PredCallId, MI, !IO).
-
-:- pred warn_singletons_in_goal_list(list(hlds_goal)::in, set(prog_var)::in,
- prog_varset::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
-
-warn_singletons_in_goal_list([], _, _, _, _, !IO).
-warn_singletons_in_goal_list([Goal | Goals], QuantVars, VarSet, CallPredId,
- MI, !IO) :-
- warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI, !IO),
- warn_singletons_in_goal_list(Goals, QuantVars, VarSet, CallPredId, MI,
- !IO).
-
-:- pred warn_singletons_in_cases(list(case)::in, set(prog_var)::in,
- prog_varset::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
-
-warn_singletons_in_cases([], _, _, _, _, !IO).
-warn_singletons_in_cases([Case | Cases], QuantVars, VarSet, CallPredId, MI,
- !IO) :-
- Case = case(_ConsId, Goal),
- warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI, !IO),
- warn_singletons_in_cases(Cases, QuantVars, VarSet, CallPredId, MI, !IO).
-
-:- pred warn_singletons_in_unify(prog_var::in, unify_rhs::in,
- hlds_goal_info::in, set(prog_var)::in, prog_varset::in,
- simple_call_id::in, module_info::in, io::di, io::uo) is det.
-
-warn_singletons_in_unify(X, var(Y), GoalInfo, QuantVars, VarSet, CallPredId, _,
- !IO) :-
- goal_info_get_nonlocals(GoalInfo, NonLocals),
- goal_info_get_context(GoalInfo, Context),
- warn_singletons([X, Y], GoalInfo, NonLocals, QuantVars, VarSet,
- Context, CallPredId, !IO).
-
-warn_singletons_in_unify(X, functor(_ConsId, _, Vars), GoalInfo,
- QuantVars, VarSet, CallPredId, _, !IO) :-
- goal_info_get_nonlocals(GoalInfo, NonLocals),
- goal_info_get_context(GoalInfo, Context),
- warn_singletons([X | Vars], GoalInfo, NonLocals, QuantVars, VarSet,
- Context, CallPredId, !IO).
-
-warn_singletons_in_unify(X, lambda_goal(_Purity, _PredOrFunc, _Eval, _Fix,
- _NonLocals, LambdaVars, _Modes, _Det, LambdaGoal),
- GoalInfo, QuantVars, VarSet, CallPredId, MI, !IO) :-
- %
- % warn if any lambda-quantified variables occur only in the quantifier
- %
- LambdaGoal = _ - LambdaGoalInfo,
- goal_info_get_nonlocals(LambdaGoalInfo, LambdaNonLocals),
- goal_info_get_context(GoalInfo, Context),
- warn_singletons(LambdaVars, GoalInfo, LambdaNonLocals, QuantVars,
- VarSet, Context, CallPredId, !IO),
-
- %
- % warn if X (the variable we're unifying the lambda expression with)
- % is singleton
- %
- goal_info_get_nonlocals(GoalInfo, NonLocals),
- warn_singletons([X], GoalInfo, NonLocals, QuantVars, VarSet, Context,
- CallPredId, !IO),
-
- %
- % warn if the lambda-goal contains singletons
- %
- warn_singletons_in_goal(LambdaGoal, QuantVars, VarSet, CallPredId, MI, !IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred maybe_warn_pragma_singletons(pragma_foreign_code_impl::in,
- foreign_language::in, list(maybe(pair(string, mode)))::in,
- prog_context::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
-
-maybe_warn_pragma_singletons(PragmaImpl, Lang, ArgInfo, Context, CallId, MI,
- !IO) :-
- globals__io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars,
- !IO),
- ( WarnSingletonVars = yes ->
- warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang,
- ArgInfo, Context, CallId, MI, !IO)
- ;
- true
- ).
-
- % warn_singletons_in_pragma_foreign_proc checks to see if each
- % variable is mentioned at least once in the foreign code
- % fragments that ought to mention it. If not, it gives a
- % warning.
- % (Note that for some foreign languages it might not be
- % appropriate to do this check, or you may need to add a
- % transformation to map Mercury variable names into identifiers
- % for that foreign language).
-:- pred warn_singletons_in_pragma_foreign_proc(pragma_foreign_code_impl::in,
- foreign_language::in, list(maybe(pair(string, mode)))::in,
- prog_context::in, simple_call_id::in, module_info::in,
- io::di, io::uo) is det.
-
-warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang, Args, Context,
- PredOrFuncCallId, ModuleInfo, !IO) :-
- LangStr = foreign_language_string(Lang),
- (
- PragmaImpl = ordinary(C_Code, _),
- c_code_to_name_list(C_Code, C_CodeList),
- Filter = (pred(Name::out) is nondet :-
- list__member(yes(Name - _), Args),
- \+ string__prefix(Name, "_"),
- \+ list__member(Name, C_CodeList)
- ),
- solutions(Filter, UnmentionedVars),
- ( UnmentionedVars = [] ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("In the " ++ LangStr ++ " code for ",
- !IO),
- hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- write_variable_warning_start(UnmentionedVars, !IO),
- io__write_string("not occur in the " ++
- LangStr ++ " code.\n", !IO)
- )
- ;
- PragmaImpl = nondet(_, _, FirstCode, _,
- LaterCode, _, _, SharedCode, _),
- c_code_to_name_list(FirstCode, FirstCodeList),
- c_code_to_name_list(LaterCode, LaterCodeList),
- c_code_to_name_list(SharedCode, SharedCodeList),
- InputFilter = (pred(Name::out) is nondet :-
- list__member(yes(Name - Mode), Args),
- mode_is_input(ModuleInfo, Mode),
- \+ string__prefix(Name, "_"),
- \+ list__member(Name, FirstCodeList)
- ),
- solutions(InputFilter, UnmentionedInputVars),
- ( UnmentionedInputVars = [] ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("In the " ++ LangStr ++ " code for ",
- !IO),
- hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- write_variable_warning_start(UnmentionedInputVars, !IO),
- io__write_string("not occur in the first " ++
- LangStr ++ " code.\n ", !IO)
- ),
- FirstOutputFilter = (pred(Name::out) is nondet :-
- list__member(yes(Name - Mode), Args),
- mode_is_output(ModuleInfo, Mode),
- \+ string__prefix(Name, "_"),
- \+ list__member(Name, FirstCodeList),
- \+ list__member(Name, SharedCodeList)
- ),
- solutions(FirstOutputFilter, UnmentionedFirstOutputVars),
- ( UnmentionedFirstOutputVars = [] ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("In the " ++ LangStr ++ " code for ",
- !IO),
- hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- write_variable_warning_start(
- UnmentionedFirstOutputVars, !IO),
- io__write_string("not occur in the first " ++
- LangStr ++ " code or the shared " ++ LangStr ++
- " code.\n ", !IO)
- ),
- LaterOutputFilter = (pred(Name::out) is nondet :-
- list__member(yes(Name - Mode), Args),
- mode_is_output(ModuleInfo, Mode),
- \+ string__prefix(Name, "_"),
- \+ list__member(Name, LaterCodeList),
- \+ list__member(Name, SharedCodeList)
- ),
- solutions(LaterOutputFilter, UnmentionedLaterOutputVars),
- ( UnmentionedLaterOutputVars = [] ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("In the " ++ LangStr ++ " code for ",
- !IO),
- hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- write_variable_warning_start(
- UnmentionedLaterOutputVars, !IO),
- io__write_string("not occur in the retry " ++
- LangStr ++ " code or the shared " ++ LangStr ++
- " code.\n ", !IO)
- )
- ;
- PragmaImpl = import(_, _, _, _)
- ).
-
-:- pred write_variable_warning_start(list(string)::in, io::di, io::uo) is det.
-
-write_variable_warning_start(UnmentionedVars, !IO) :-
- ( UnmentionedVars = [_] ->
- io__write_string(" warning: variable `", !IO),
- write_string_list(UnmentionedVars, !IO),
- io__write_string("' does ", !IO)
- ;
- io__write_string(" warning: variables `", !IO),
- write_string_list(UnmentionedVars, !IO),
- io__write_string("' do ", !IO)
- ).
-
-%-----------------------------------------------------------------------------%
-
- % c_code_to_name_list(Code, List) is true iff List is a list of the
- % identifiers used in the C code in Code.
-:- pred c_code_to_name_list(string::in, list(string)::out) is det.
-
-c_code_to_name_list(Code, List) :-
- string__to_char_list(Code, CharList),
- c_code_to_name_list_2(CharList, List).
-
-:- pred c_code_to_name_list_2(list(char)::in, list(string)::out) is det.
-
-c_code_to_name_list_2(C_Code, List) :-
- get_first_c_name(C_Code, NameCharList, TheRest),
- ( NameCharList = [] ->
- % no names left
- List = []
- ;
- c_code_to_name_list_2(TheRest, Names),
- string__from_char_list(NameCharList, Name),
- List = [Name|Names]
- ).
-
-:- pred get_first_c_name(list(char)::in, list(char)::out, list(char)::out)
- is det.
-
-get_first_c_name([], [], []).
-get_first_c_name([C | CodeChars], NameCharList, TheRest) :-
- ( char__is_alnum_or_underscore(C) ->
- get_first_c_name_in_word(CodeChars, NameCharList0, TheRest),
- NameCharList = [C | NameCharList0]
- ;
- % strip off any characters in the C code which
- % don't form part of an identifier.
- get_first_c_name(CodeChars, NameCharList, TheRest)
- ).
-
-:- pred get_first_c_name_in_word(list(char)::in, list(char)::out,
- list(char)::out) is det.
-
-get_first_c_name_in_word([], [], []).
-get_first_c_name_in_word([C | CodeChars], NameCharList, TheRest) :-
- ( char__is_alnum_or_underscore(C) ->
- % There are more characters in the word
- get_first_c_name_in_word(CodeChars, NameCharList0, TheRest),
- NameCharList = [C|NameCharList0]
- ;
- % The word is finished
- NameCharList = [],
- TheRest = CodeChars
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred write_string_list(list(string)::in, io::di, io::uo) is det.
-
-write_string_list([], !IO).
-write_string_list([X | Xs], !IO) :-
- io__write_string(X, !IO),
- (
- Xs = []
- ;
- Xs = [_ | _],
- io__write_string(", ", !IO),
- write_string_list(Xs, !IO)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred generate_singleton_vars(list(prog_var)::in, set(prog_var)::in,
- set(prog_var)::in, prog_varset::in, prog_var::out) is nondet.
-
-generate_singleton_vars(GoalVars, NonLocals, QuantVars, VarSet, Var) :-
- list__member(Var, GoalVars),
- \+ set__member(Var, NonLocals),
- varset__search_name(VarSet, Var, Name),
- \+ string__prefix(Name, "_"),
- \+ string__prefix(Name, "DCG_"),
- \+ (
- set__member(QuantVar, QuantVars),
- varset__search_name(VarSet, QuantVar, Name)
- ).
-
-:- pred generate_multi_vars(list(prog_var)::in, set(prog_var)::in,
- prog_varset::in, prog_var::out) is nondet.
-
-generate_multi_vars(GoalVars, NonLocals, VarSet, Var) :-
- list__member(Var, GoalVars),
- set__member(Var, NonLocals),
- varset__search_name(VarSet, Var, Name),
- string__prefix(Name, "_").
-
- % warn_singletons(Vars, GoalInfo, NonLocals, QuantVars, ...):
- % Warn if any of the non-underscore variables in Vars don't
- % occur in NonLocals and don't have the same name as any variable
- % in QuantVars, or if any of the underscore variables
- % in Vars do occur in NonLocals.
- % Omit the warning if GoalInfo says we should.
-
-:- pred warn_singletons(list(prog_var)::in, hlds_goal_info::in,
- set(prog_var)::in, set(prog_var)::in, prog_varset::in,
- prog_context::in, simple_call_id::in, io::di, io::uo) is det.
-
-warn_singletons(GoalVars, GoalInfo, NonLocals, QuantVars, VarSet, Context,
- PredOrFuncCallId, !IO) :-
- % find all the variables in the goal that don't occur outside the
- % goal (i.e. are singleton), have a variable name that doesn't
- % start with "_" or "DCG_", and don't have the same name as any
- % variable in QuantVars (i.e. weren't explicitly quantified).
-
- solutions(generate_singleton_vars(GoalVars, NonLocals, QuantVars, VarSet),
- SingletonVars),
-
- % if there were any such variables, issue a warning
-
- (
- (
- SingletonVars = []
- ;
- goal_info_has_feature(GoalInfo, dont_warn_singleton)
- )
- ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("In clause for ", !IO),
- hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- ( SingletonVars = [_] ->
- io__write_string(" warning: variable `", !IO),
- mercury_output_vars(SingletonVars, VarSet, no, !IO),
- report_warning("' occurs only once in this scope.\n", !IO)
- ;
- io__write_string(" warning: variables `", !IO),
- mercury_output_vars(SingletonVars, VarSet, no, !IO),
- report_warning("' occur only once in this scope.\n", !IO)
- )
- ),
-
- % Find all the variables in the goal that do occur outside the goal
- % (i.e. are not singleton) and have a variable name that starts
- % with "_". If there were any such variables, issue a warning.
-
- solutions(generate_multi_vars(GoalVars, NonLocals, VarSet), MultiVars),
- (
- MultiVars = []
- ;
- MultiVars = [_ | _],
- prog_out__write_context(Context, !IO),
- io__write_string("In clause for ", !IO),
- hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- ( MultiVars = [_] ->
- io__write_string(" warning: variable `", !IO),
- mercury_output_vars(MultiVars, VarSet, no, !IO),
- report_warning("' occurs more than once in this scope.\n", !IO)
- ;
- io__write_string(" warning: variables `", !IO),
- mercury_output_vars(MultiVars, VarSet, no, !IO),
- report_warning("' occur more than once in this scope.\n", !IO)
- )
- ).
-
-%-----------------------------------------------------------------------------
-
-:- pred clauses_info_init_for_assertion(prog_vars::in, clauses_info::out)
- is det.
-
-clauses_info_init_for_assertion(HeadVars, ClausesInfo) :-
- map__init(VarTypes),
- map__init(TVarNameMap),
- varset__init(VarSet),
- rtti_varmaps_init(RttiVarMaps),
- HasForeignClauses = no,
- set_clause_list([], ClausesRep),
- ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
- HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses).
-
-:- pred clauses_info_init(int::in, clauses_info::out) is det.
-
-clauses_info_init(Arity, ClausesInfo) :-
- map__init(VarTypes),
- map__init(TVarNameMap),
- varset__init(VarSet0),
- make_n_fresh_vars("HeadVar__", Arity, HeadVars, VarSet0, VarSet),
- rtti_varmaps_init(RttiVarMaps),
- HasForeignClauses = no,
- set_clause_list([], ClausesRep),
- ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap, VarTypes,
- HeadVars, ClausesRep, RttiVarMaps, HasForeignClauses).
-
-:- pred clauses_info_add_clause(list(proc_id)::in,
- prog_varset::in, tvarset::in, list(prog_term)::in, goal::in,
- prog_context::in, import_status::in, pred_or_func::in, arity::in,
- goal_type::in, hlds_goal::out, prog_varset::out, tvarset::out,
- clauses_info::in, clauses_info::out, list(quant_warning)::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-clauses_info_add_clause(ModeIds0, CVarSet, TVarSet0, Args, Body, Context,
- Status, PredOrFunc, Arity, GoalType, Goal, VarSet, TVarSet,
- !ClausesInfo, Warnings, !ModuleInfo, !QualInfo, !IO) :-
- !.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes0,
- TVarNameMap0, InferredVarTypes, HeadVars, ClausesRep0,
- RttiVarMaps, HasForeignClauses),
- IsEmpty = clause_list_is_empty(ClausesRep0),
- (
- IsEmpty = yes,
- % Create the mapping from type variable name, used to
- % rename type variables occurring in explicit type
- % qualifications. The version of this mapping stored
- % in the clauses_info should only contain type variables
- % which occur in the argument types of the predicate.
- % Type variables which only occur in explicit type
- % qualifications are local to the clause in which they appear.
- varset__create_name_var_map(TVarSet0, TVarNameMap)
- ;
- IsEmpty = no,
- TVarNameMap = TVarNameMap0
- ),
- update_qual_info(TVarNameMap, TVarSet0, ExplicitVarTypes0, Status,
- !QualInfo),
- varset__merge_subst(VarSet0, CVarSet, VarSet1, Subst),
- add_clause_transform(Subst, HeadVars, Args, Body, Context, PredOrFunc,
- Arity, GoalType, Goal0, VarSet1, VarSet, Warnings, !ModuleInfo,
- !QualInfo, !IO),
- TVarSet = !.QualInfo ^ tvarset,
- qual_info_get_found_syntax_error(!.QualInfo, FoundError),
- qual_info_set_found_syntax_error(no, !QualInfo),
- (
- FoundError = yes,
- % Don't insert clauses containing syntax errors into
- % the clauses_info, because doing that would cause
- % typecheck.m to report spurious type errors.
- % Don't report singleton variable warnings if there
- % were syntax errors.
- true_goal(Goal)
- ;
- FoundError = no,
- Goal = Goal0,
-
- % If we have foreign clauses, we should only add this clause
- % for modes *not* covered by the foreign clauses.
- (
- HasForeignClauses = yes,
- get_clause_list_any_order(ClausesRep0, AnyOrderClauseList),
- ForeignModeIds = list__condense(list__filter_map(
- (func(C) = ProcIds is semidet :-
- C = clause(ProcIds, _, ClauseLang, _),
- not ClauseLang = mercury
- ),
- AnyOrderClauseList)),
- ModeIds = list__delete_elems(ModeIds0, ForeignModeIds),
- (
- ModeIds = [],
- ClausesRep = ClausesRep0
- ;
- ModeIds = [_ | _],
- Clause = clause(ModeIds, Goal, mercury, Context),
- add_clause(Clause, ClausesRep0, ClausesRep)
- )
- ;
- HasForeignClauses = no,
- Clause = clause(ModeIds0, Goal, mercury, Context),
- add_clause(Clause, ClausesRep0, ClausesRep)
- ),
- qual_info_get_var_types(!.QualInfo, ExplicitVarTypes),
- !:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
- InferredVarTypes, HeadVars, ClausesRep, RttiVarMaps,
- HasForeignClauses)
- ).
-
-%-----------------------------------------------------------------------------
-
- % Add the pragma_foreign_proc goal to the clauses_info for this procedure.
- % To do so, we must also insert unifications between the variables in the
- % pragma foreign_proc declaration and the head vars of the pred. Also
- % return the hlds_goal.
-
-:- pred clauses_info_add_pragma_foreign_proc(purity::in,
- pragma_foreign_proc_attributes::in, pred_id::in, proc_id::in,
- prog_varset::in, list(pragma_var)::in, list(type)::in,
- pragma_foreign_code_impl::in, prog_context::in, pred_or_func::in,
- sym_name::in, arity::in, clauses_info::in, clauses_info::out,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-clauses_info_add_pragma_foreign_proc(Purity, Attributes0, PredId, ProcId,
- PVarSet, PVars, OrigArgTypes, PragmaImpl0, Context, PredOrFunc,
- PredName, Arity, !ClausesInfo, !ModuleInfo, !IO) :-
-
- !.ClausesInfo = clauses_info(VarSet0, ExplicitVarTypes, TVarNameMap,
- InferredVarTypes, HeadVars, ClauseRep, RttiVarMaps,
- _HasForeignClauses),
- get_clause_list(ClauseRep, ClauseList),
-
- % Find all the existing clauses for this mode, and
- % extract their implementation language and clause number
- % (that is, their index in the list).
- globals__io_get_globals(Globals, !IO),
- globals__io_get_target(Target, !IO),
- NewLang = foreign_language(Attributes0),
- list__foldl2(decide_action(Globals, Target, NewLang, ProcId), ClauseList,
- add, FinalAction, 1, _),
-
- globals__io_get_backend_foreign_languages(BackendForeignLanguages, !IO),
- pragma_get_vars(PVars, Args0),
- pragma_get_var_infos(PVars, ArgInfo),
-
- %
- % If the foreign language not one of the backend languages, we will
- % have to generate an interface to it in a backend language.
- %
- foreign__extrude_pragma_implementation(BackendForeignLanguages,
- PVars, PredName, PredOrFunc, Context, !ModuleInfo,
- Attributes0, Attributes, PragmaImpl0, PragmaImpl),
-
- %
- % Check for arguments occurring multiple times.
- %
- bag__init(ArgBag0),
- bag__insert_list(ArgBag0, Args0, ArgBag),
- bag__to_assoc_list(ArgBag, ArgBagAL0),
- list__filter(
- (pred(Arg::in) is semidet :-
- Arg = _ - Occurrences,
- Occurrences > 1
- ), ArgBagAL0, ArgBagAL),
- assoc_list__keys(ArgBagAL, MultipleArgs),
-
- (
- MultipleArgs = [_ | _],
- prog_out__write_context(Context, !IO),
- io__write_string(
- "In `:- pragma foreign_proc' declaration for ", !IO),
- adjust_func_arity(PredOrFunc, OrigArity, Arity),
- hlds_out__write_simple_call_id(
- PredOrFunc - PredName/OrigArity, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" error: ", !IO),
- (
- MultipleArgs = [MultipleArg],
- io__write_string("variable `", !IO),
- mercury_output_var(MultipleArg, PVarSet, no, !IO),
- io__write_string("' occurs multiple times\n", !IO)
- ;
- MultipleArgs = [_, _ | _],
- io__write_string("variables `", !IO),
- mercury_output_vars(MultipleArgs, PVarSet, no, !IO),
- io__write_string("' occur multiple times\n", !IO)
- ),
- prog_out__write_context(Context, !IO),
- io__write_string(" in the argument list.\n", !IO),
- io__set_exit_status(1, !IO)
- ;
- MultipleArgs = [],
- % build the pragma_c_code
- goal_info_init(GoalInfo0),
- goal_info_set_context(GoalInfo0, Context, GoalInfo1),
- % Put the purity in the goal_info in case this foreign code is inlined.
- add_goal_info_purity_feature(GoalInfo1, Purity, GoalInfo),
- make_foreign_args(HeadVars, ArgInfo, OrigArgTypes,
- ForeignArgs),
- HldsGoal0 = foreign_proc(Attributes, PredId, ProcId,
- ForeignArgs, [], PragmaImpl) - GoalInfo,
- map__init(EmptyVarTypes),
- implicitly_quantify_clause_body(HeadVars, _Warnings,
- HldsGoal0, HldsGoal, VarSet0, VarSet, EmptyVarTypes, _),
- NewClause = clause([ProcId], HldsGoal, foreign_language(NewLang),
- Context),
- (
- FinalAction = ignore,
- NewClauseList = ClauseList
- ;
- FinalAction = add,
- NewClauseList = [NewClause | ClauseList]
- ;
- FinalAction = replace(N),
- list__replace_nth_det(ClauseList, N, NewClause, NewClauseList)
- ;
- FinalAction = split_add(N, Clause),
- list__replace_nth_det(ClauseList, N, Clause, NewClauseListTail),
- NewClauseList = [NewClause | NewClauseListTail]
- ),
- HasForeignClauses = yes,
- set_clause_list(NewClauseList, NewClauseRep),
- !:ClausesInfo = clauses_info(VarSet, ExplicitVarTypes, TVarNameMap,
- InferredVarTypes, HeadVars, NewClauseRep, RttiVarMaps,
- HasForeignClauses)
- ).
-
-:- func is_applicable_for_current_backend(backend,
- list(pragma_foreign_proc_extra_attribute)) = bool.
-
-is_applicable_for_current_backend(_CurrentBackend, []) = yes.
-is_applicable_for_current_backend(CurrentBackend, [Attr | Attrs]) = Result :-
- (
- Attr = max_stack_size(_),
- Result = is_applicable_for_current_backend(CurrentBackend, Attrs)
- ;
- Attr = backend(Backend),
- ( Backend = CurrentBackend ->
- Result = is_applicable_for_current_backend(CurrentBackend, Attrs)
- ;
- Result = no
- )
- ).
-
-:- pred lookup_current_backend(backend::out, io::di, io::uo) is det.
-
-lookup_current_backend(CurrentBackend, !IO) :-
- globals__io_lookup_bool_option(highlevel_code, HighLevel, !IO),
- (
- HighLevel = yes,
- CurrentBackend = high_level_backend
- ;
- HighLevel= no,
- CurrentBackend = low_level_backend
- ).
-
- % As we traverse the clauses, at each one decide which action to perform.
- %
- % If there are no clauses, we will simply add this clause.
- %
- % If there are matching foreign_proc clauses for this proc_id,
- % we will either replace them or ignore the new clause
- % (depending on the preference of the two foreign languages).
- %
- % If there is a matching Mercury clause for this proc_id, we will either
- % - replace it if there is only one matching mode in its proc_id list.
- % - remove the matching proc_id from its proc_id list, and add this
- % clause as a new clause for this mode.
-
-:- type foreign_proc_action
- ---> ignore
- ; add
- ; split_add(int, clause)
- ; replace(int).
-
-:- pred decide_action(globals::in, compilation_target::in,
- foreign_language::in, proc_id::in, clause::in,
- foreign_proc_action::in, foreign_proc_action::out,
- int::in, int::out) is det.
-
-decide_action(Globals, Target, NewLang, ProcId, Clause, !Action, !ClauseNum) :-
- Clause = clause(ProcIds, Body, ClauseLang, Context),
- (
- ClauseLang = mercury,
- ( ProcIds = [ProcId] ->
- !:Action = replace(!.ClauseNum)
- ; list__delete_first(ProcIds, ProcId, MercuryProcIds) ->
- NewMercuryClause = clause(MercuryProcIds, Body, ClauseLang,
- Context),
- !:Action = split_add(!.ClauseNum, NewMercuryClause)
- ;
- true
- )
- ;
- ClauseLang = foreign_language(OldLang),
- ( list__member(ProcId, ProcIds) ->
- (
- yes = prefer_foreign_language(Globals, Target,
- OldLang, NewLang)
- ->
- % This language is preferred to the old
- % language, so we should replace it
- !:Action = replace(!.ClauseNum)
- ;
- % Just ignore it.
- !:Action = ignore
- )
- ;
- true
- )
- ),
- !:ClauseNum = !.ClauseNum + 1.
-
-:- pred allocate_vars_for_saved_vars(list(string)::in,
- list(pair(prog_var, string))::out,
- prog_varset::in, prog_varset::out) is det.
-
-allocate_vars_for_saved_vars([], [], !VarSet).
-allocate_vars_for_saved_vars([Name | Names], [Var - Name | VarNames],
- !VarSet) :-
- varset__new_var(!.VarSet, Var, !:VarSet),
- allocate_vars_for_saved_vars(Names, VarNames, !VarSet).
-
-%-----------------------------------------------------------------------------
-
-:- pred add_clause_transform(prog_substitution::in, list(prog_var)::in,
- list(prog_term)::in, goal::in, prog_context::in, pred_or_func::in,
- arity::in, goal_type::in, hlds_goal::out,
- prog_varset::in, prog_varset::out, list(quant_warning)::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-add_clause_transform(Subst, HeadVars, Args0, Body0, Context, PredOrFunc, Arity,
- GoalType, Goal, !VarSet, Warnings, !ModuleInfo, !QualInfo, !IO) :-
- some [!SInfo] (
- prepare_for_head(!:SInfo),
- term__apply_substitution_to_list(Args0, Subst, Args1),
- substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !IO),
- hlds_goal__true_goal(HeadGoal0),
- ( GoalType = promise(_) ->
- HeadGoal = HeadGoal0
- ;
- ArgContext = head(PredOrFunc, Arity),
- insert_arg_unifications(HeadVars, Args, Context, ArgContext,
- HeadGoal0, HeadGoal1, !VarSet, !ModuleInfo, !QualInfo, !SInfo,
- !IO),
- attach_features_to_all_goals([from_head], HeadGoal1, HeadGoal)
- ),
- prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
- transform_goal(Body0, Subst, Body, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- finish_head_and_body(Context, FinalSVarMap, HeadGoal, Body, Goal0,
- !.SInfo),
- VarTypes0 = !.QualInfo ^ vartypes,
- implicitly_quantify_clause_body(HeadVars, Warnings, Goal0, Goal,
- !VarSet, VarTypes0, VarTypes),
- !:QualInfo = !.QualInfo ^ vartypes := VarTypes
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Convert goals from the prog_data `goal' structure into the
- % hlds `hlds_goal' structure. At the same time, convert
- % it to super-homogeneous form by unravelling all the complex
- % unifications, and annotate those unifications with a unify_context
- % so that we can still give good error messages.
- % And also at the same time, apply the given substitution to
- % the goal, to rename it apart from the other clauses.
-
-:- pred transform_goal(goal::in, prog_substitution::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-transform_goal(Goal0 - Context, Subst, Goal1 - GoalInfo1, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- transform_goal_2(Goal0, Context, Subst, Goal1 - GoalInfo0,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_set_context(GoalInfo0, Context, GoalInfo1).
-
-:- pred transform_goal_2(goal_expr::in, prog_context::in,
- prog_substitution::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-transform_goal_2(fail, _, _, disj([]) - GoalInfo, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- goal_info_init(GoalInfo),
- prepare_for_next_conjunct(set__init, !VarSet, !SInfo).
-
-transform_goal_2(true, _, _, conj([]) - GoalInfo, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- goal_info_init(GoalInfo),
- prepare_for_next_conjunct(set__init, !VarSet, !SInfo).
-
- % Convert `all [Vars] Goal' into `not some [Vars] not Goal'.
-transform_goal_2(all(Vars0, Goal0), Context, Subst, Goal, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- TransformedGoal = not(some(Vars0, not(Goal0) - Context) - Context),
- transform_goal_2(TransformedGoal, Context, Subst, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO).
-
-transform_goal_2(all_state_vars(StateVars, Goal0), Context, Subst,
- Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- transform_goal_2(
- not(some_state_vars(StateVars, not(Goal0) - Context) - Context),
- Context, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
-
-transform_goal_2(some(Vars0, Goal0), _, Subst,
- scope(exist_quant(Vars), Goal) - GoalInfo,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- substitute_vars(Vars0, Subst, Vars),
- transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- goal_info_init(GoalInfo).
-
-transform_goal_2(some_state_vars(StateVars0, Goal0), _, Subst,
- scope(exist_quant(Vars), Goal) - GoalInfo,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- BeforeSInfo = !.SInfo,
- substitute_vars(StateVars0, Subst, StateVars),
- prepare_for_local_state_vars(StateVars, !VarSet, !SInfo),
- transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- finish_local_state_vars(StateVars, Vars, BeforeSInfo, !SInfo),
- goal_info_init(GoalInfo).
-
-transform_goal_2(promise_purity(Implicit, Purity, Goal0), _, Subst,
- scope(promise_purity(Implicit, Purity), Goal) - GoalInfo,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- goal_info_init(GoalInfo).
-
-transform_goal_2(
- promise_equivalent_solutions(Vars0, DotSVars0, ColonSVars0, Goal0),
- Context, Subst,
- scope(promise_equivalent_solutions(Vars), Goal) - GoalInfo,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- substitute_vars(Vars0, Subst, Vars1),
- substitute_vars(DotSVars0, Subst, DotSVars1),
- convert_dot_state_vars(Context, DotSVars1, DotSVars, !VarSet, !SInfo, !IO),
- transform_goal(Goal0, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- goal_info_init(GoalInfo),
- substitute_vars(ColonSVars0, Subst, ColonSVars1),
- convert_dot_state_vars(Context, ColonSVars1, ColonSVars, !VarSet,
- !SInfo, !IO),
- Vars = Vars1 ++ DotSVars ++ ColonSVars.
-
-transform_goal_2(if_then_else(Vars0, StateVars0, Cond0, Then0, Else0), Context,
- Subst, if_then_else(Vars, Cond, Then, Else) - GoalInfo,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- BeforeSInfo = !.SInfo,
- substitute_vars(Vars0, Subst, Vars),
- substitute_vars(StateVars0, Subst, StateVars),
- prepare_for_if_then_else_goal(StateVars, !VarSet, !SInfo),
- transform_goal(Cond0, Subst, Cond, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- finish_if_then_else_goal_condition(StateVars,
- BeforeSInfo, !.SInfo, AfterCondSInfo, !:SInfo),
- transform_goal(Then0, Subst, Then1, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- finish_if_then_else_goal_then_goal(StateVars, BeforeSInfo, !SInfo),
- AfterThenSInfo = !.SInfo,
- transform_goal(Else0, Subst, Else1, !VarSet, !ModuleInfo, !QualInfo,
- BeforeSInfo, !:SInfo, !IO),
- goal_info_init(Context, GoalInfo),
- finish_if_then_else(Context, Then1, Then, Else1, Else,
- BeforeSInfo, AfterCondSInfo, AfterThenSInfo, !SInfo, !VarSet).
-
-transform_goal_2(if_then(Vars0, StateVars, A0, B0), Context, Subst,
- Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- transform_goal_2(
- if_then_else(Vars0, StateVars, A0, B0, true - Context),
- Context, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
-
-transform_goal_2(not(A0), _, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
- BeforeSInfo = !.SInfo,
- transform_goal(A0, Subst, A, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_init(GoalInfo),
- Goal = not(A) - GoalInfo,
- finish_negation(BeforeSInfo, !SInfo).
-
-transform_goal_2((A0, B0), _, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
- get_rev_conj(A0, Subst, [], R0, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- get_rev_conj(B0, Subst, R0, R, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- L = list__reverse(R),
- goal_info_init(GoalInfo),
- conj_list_to_goal(L, GoalInfo, Goal).
-
-transform_goal_2((A0 & B0), _, Subst, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
- get_rev_par_conj(B0, Subst, [], R0, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- get_rev_par_conj(A0, Subst, R0, R, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- L = list__reverse(R),
- goal_info_init(GoalInfo),
- par_conj_list_to_goal(L, GoalInfo, Goal).
-
-transform_goal_2((A0 ; B0), Context, Subst, Goal, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- get_disj(B0, Subst, [], L0, !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
- get_disj(A0, Subst, L0, L1, !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
- finish_disjunction(Context, !.VarSet, L1, L, !:SInfo),
- goal_info_init(Context, GoalInfo),
- disj_list_to_goal(L, GoalInfo, Goal).
-
-transform_goal_2(implies(P, Q), Context, Subst, Goal, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- % `P => Q' is defined as `not (P, not Q)'
- TransformedGoal = not( (P, not(Q) - Context) - Context ),
- transform_goal_2(TransformedGoal, Context, Subst, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO).
-
-transform_goal_2(equivalent(P0, Q0), _, Subst, Goal, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- %
- % `P <=> Q' is defined as `(P => Q), (Q => P)',
- % but that transformation must not be done until
- % after quantification analysis, lest the duplication of
- % the goals concerned affect the implicit quantification
- % of the variables inside them.
- %
- BeforeSInfo = !.SInfo,
- goal_info_init(GoalInfo),
- transform_goal(P0, Subst, P, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- transform_goal(Q0, Subst, Q, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- Goal = shorthand(bi_implication(P, Q)) - GoalInfo,
- finish_equivalence(BeforeSInfo, !SInfo).
-
-transform_goal_2(call(Name, Args0, Purity), Context, Subst, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- Args1 = expand_bang_state_var_args(Args0),
- (
- Name = unqualified("\\="),
- Args1 = [LHS, RHS]
- ->
- prepare_for_call(!SInfo),
- % `LHS \= RHS' is defined as `not (LHS = RHS)'
- transform_goal_2(not(unify(LHS, RHS, Purity) - Context), Context,
- Subst, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- finish_call(!VarSet, !SInfo)
- ;
- % check for a DCG field access goal:
- % get: Field =^ field
- % set: ^ field := Field
- ( Name = unqualified(Operator) ),
- ( Operator = "=^"
- ; Operator = ":="
- )
- ->
- prepare_for_call(!SInfo),
- term__apply_substitution_to_list(Args1, Subst, Args2),
- transform_dcg_record_syntax(Operator, Args2, Context,
- Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- finish_call(!VarSet, !SInfo)
- ;
- % check for an Aditi builtin
- Purity = pure,
- Name = unqualified(Name1),
- ( Name1 = "aditi_insert"
- ; Name1 = "aditi_delete"
- ; Name1 = "aditi_bulk_insert"
- ; Name1 = "aditi_bulk_delete"
- ; Name1 = "aditi_bulk_modify"
- )
- ->
- term__apply_substitution_to_list(Args1, Subst, Args2),
- transform_aditi_builtin(Name1, Args2, Context, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- prepare_for_call(!SInfo),
- term__apply_substitution_to_list(Args1, Subst, Args),
- make_fresh_arg_vars(Args, HeadVars, !VarSet, !SInfo, !IO),
- list__length(Args, Arity),
- (
- % check for a higher-order call,
- % i.e. a call to either call/N or ''/N.
- ( Name = unqualified("call")
- ; Name = unqualified("")
- ),
- HeadVars = [PredVar | RealHeadVars]
- ->
- % initialize some fields to junk
- Modes = [],
- Det = erroneous,
-
- GenericCall = higher_order(PredVar, Purity, predicate, Arity),
- Call = generic_call(GenericCall, RealHeadVars, Modes, Det),
-
- hlds_goal__generic_call_id(GenericCall, CallId)
- ;
- % initialize some fields to junk
- PredId = invalid_pred_id,
- ModeId = invalid_proc_id,
-
- MaybeUnifyContext = no,
- Call = call(PredId, ModeId, HeadVars, not_builtin,
- MaybeUnifyContext, Name),
- CallId = call(predicate - Name/Arity)
- ),
- goal_info_init(Context, GoalInfo0),
- add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo),
- Goal0 = Call - GoalInfo,
-
- record_called_pred_or_func(predicate, Name, Arity, !QualInfo),
- insert_arg_unifications(HeadVars, Args, Context, call(CallId),
- Goal0, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- finish_call(!VarSet, !SInfo)
- ).
-
-transform_goal_2(unify(A0, B0, Purity), Context, Subst, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- % It is an error for the left or right hand side of a
- % unification to be !X (it may be !.X or !:X, however).
- %
- ( A0 = functor(atom("!"), [variable(StateVarA)], _) ->
- report_svar_unify_error(Context, !.VarSet, StateVarA, !IO),
- true_goal(Goal)
- ; B0 = functor(atom("!"), [variable(StateVarB)], _) ->
- report_svar_unify_error(Context, !.VarSet, StateVarB, !IO),
- true_goal(Goal)
- ;
- prepare_for_call(!SInfo),
- term__apply_substitution(A0, Subst, A),
- term__apply_substitution(B0, Subst, B),
- unravel_unification(A, B, Context, explicit, [], Purity, Goal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- finish_call(!VarSet, !SInfo)
- ).
-
-
-:- pred convert_dot_state_vars(prog_context::in, prog_vars::in, prog_vars::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
-
-convert_dot_state_vars(_Context, [], [], !VarSet, !SInfo, !IO).
-
-convert_dot_state_vars(Context, [Dot0 | Dots0], [Dot | Dots],
- !VarSet, !SInfo, !IO) :-
- dot(Context, Dot0, Dot, !VarSet, !SInfo, !IO),
- convert_dot_state_vars(Context, Dots0, Dots, !VarSet, !SInfo, !IO).
-
-
-:- pred convert_colon_state_vars(prog_context::in,
- prog_vars::in, prog_vars::out, prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-convert_colon_state_vars(_Context, [], [], !VarSet, !SInfo, !IO).
-
-convert_colon_state_vars(Context, [Colon0 | Colons0], [Colon | Colons],
- !VarSet, !SInfo, !IO) :-
- colon(Context, Colon0, Colon, !VarSet, !SInfo, !IO),
- convert_colon_state_vars(Context, Colons0, Colons, !VarSet, !SInfo, !IO).
-
-
-:- pred report_svar_unify_error(prog_context::in, prog_varset::in, svar::in,
- io::di, io::uo) is det.
-
-report_svar_unify_error(Context, VarSet, StateVar, !IO) :-
- Name = varset__lookup_name(VarSet, StateVar),
- Pieces = [nl, words("Error:"), fixed("!" ++ Name),
- words("cannot appear as a unification argument."), nl,
- words("You probably meant"), fixed("!." ++ Name),
- words("or"), fixed("!:" ++ Name), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO).
-
-:- inst dcg_record_syntax_op == bound("=^"; ":=").
-
-:- pred transform_dcg_record_syntax(string::in(dcg_record_syntax_op),
- list(prog_term)::in, prog_context::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-transform_dcg_record_syntax(Operator, ArgTerms0, Context, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- goal_info_init(Context, GoalInfo),
- (
- ArgTerms0 = [LHSTerm, RHSTerm, TermInputTerm, TermOutputTerm],
- (
- Operator = "=^",
- AccessType = get,
- FieldNameTerm = RHSTerm,
- FieldValueTerm = LHSTerm
- ;
- Operator = ":=",
- AccessType = set,
- LHSTerm = term__functor(term__atom("^"), [FieldNameTerm0], _),
- FieldNameTerm = FieldNameTerm0,
- FieldValueTerm = RHSTerm
- )
- ->
- parse_field_list(FieldNameTerm, MaybeFieldNames),
- (
- MaybeFieldNames = ok(FieldNames),
- ArgTerms = [FieldValueTerm, TermInputTerm, TermOutputTerm],
- transform_dcg_record_syntax_2(AccessType, FieldNames, ArgTerms,
- Context, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- MaybeFieldNames = error(Msg, ErrorTerm),
- invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !IO),
- qual_info_set_found_syntax_error(yes, !QualInfo),
- io__set_exit_status(1, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string("In DCG field ", !IO),
- (
- AccessType = set,
- io__write_string("update", !IO)
- ;
- AccessType = get,
- io__write_string("extraction", !IO)
- ),
- io__write_string(" goal:\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" error: ", !IO),
- io__write_string(Msg, !IO),
- io__write_string(" at term `", !IO),
- term_io__write_term(!.VarSet, ErrorTerm, !IO),
- io__write_string("'.\n", !IO)
- )
- ;
- invalid_goal("^", ArgTerms0, GoalInfo, Goal, !VarSet, !SInfo, !IO),
- qual_info_set_found_syntax_error(yes, !QualInfo),
- io__set_exit_status(1, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: expected " ++
- "`Field =^ field1 ^ ... ^ fieldN'\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" or `^ field1 ^ ... ^ fieldN := Field'.\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" in DCG field access goal.\n", !IO)
- ).
-
-:- pred transform_dcg_record_syntax_2(field_access_type::in, field_list::in,
- list(prog_term)::in, prog_context::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-transform_dcg_record_syntax_2(AccessType, FieldNames, ArgTerms, Context, Goal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- make_fresh_arg_vars(ArgTerms, ArgVars, !VarSet, !SInfo, !IO),
- ( ArgVars = [FieldValueVar, TermInputVar, TermOutputVar] ->
- (
- AccessType = set,
- expand_set_field_function_call(Context, explicit, [],
- FieldNames, FieldValueVar, TermInputVar,
- TermOutputVar, !VarSet, Functor,
- InnermostFunctor - InnermostSubContext, Goal0,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- FieldArgNumber = 2,
- FieldArgContext = functor(InnermostFunctor, explicit,
- InnermostSubContext),
- InputTermArgNumber = 1,
- InputTermArgContext = functor(Functor, explicit, []),
- ( Functor = cons(FuncName0, FuncArity0) ->
- FuncName = FuncName0,
- FuncArity = FuncArity0
- ;
- error("transform_dcg_record_syntax_2")
- ),
- % DCG arguments should always be distinct variables,
- % so this context should never be used.
- OutputTermArgNumber = 3,
- OutputTermArgContext = call(
- call(function - FuncName/FuncArity)),
-
- ArgContexts = [
- FieldArgNumber - FieldArgContext,
- InputTermArgNumber - InputTermArgContext,
- OutputTermArgNumber - OutputTermArgContext
- ],
- insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms,
- ArgContexts, Context, Goal0, Goal, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO)
- ;
- AccessType = get,
- expand_dcg_field_extraction_goal(Context, explicit,
- [], FieldNames, FieldValueVar, TermInputVar,
- TermOutputVar, !VarSet, Functor,
- InnermostFunctor - _InnerSubContext, Goal0,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
- InputTermArgNumber = 1,
- InputTermArgContext = functor(Functor, explicit, []),
-
- ( InnermostFunctor = cons(FuncName0, FuncArity0) ->
- FuncName = FuncName0,
- FuncArity = FuncArity0
- ;
- error("transform_dcg_record_syntax_2")
- ),
- FieldArgNumber = 2,
- FieldArgContext = call(call(function - FuncName/FuncArity)),
-
- % DCG arguments should always be distinct variables,
- % so this context should never be used.
- OutputTermArgNumber = 1,
- OutputTermArgContext = functor(Functor, explicit, []),
- ArgContexts = [
- FieldArgNumber - FieldArgContext,
- InputTermArgNumber - InputTermArgContext,
- OutputTermArgNumber - OutputTermArgContext
- ],
- insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms,
- ArgContexts, Context, Goal0, Goal, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO)
- )
- ;
- error("make_hlds__do_transform_dcg_record_syntax")
- ).
-
- % Expand a field update goal into a list of goals which
- % each get or set one level of the structure.
- %
- % A field update goal:
- % Term = Term0 ^ module_info ^ ctors := Ctors
- % is expanded into
- % V_1 = Term0 ^ module_info,
- % V_3 = V_2 ^ ctors := Ctors,
- % Term = Term0 ^ module_info := V_3.
- %
-:- pred expand_set_field_function_call(prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, field_list::in,
- prog_var::in, prog_var::in, prog_var::in,
- prog_varset::in, prog_varset::out, cons_id::out,
- pair(cons_id, unify_sub_contexts)::out, hlds_goal::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-expand_set_field_function_call(Context, MainContext, SubContext0, FieldNames,
- FieldValueVar, TermInputVar, TermOutputVar, !VarSet, Functor,
- FieldSubContext, Goal, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- expand_set_field_function_call_2(Context, MainContext,
- SubContext0, FieldNames, FieldValueVar, TermInputVar,
- TermOutputVar, !VarSet, Functor, FieldSubContext, Goals,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_init(Context, GoalInfo),
- conj_list_to_goal(Goals, GoalInfo, Goal).
-
-:- pred expand_set_field_function_call_2(prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, field_list::in,
- prog_var::in, prog_var::in, prog_var::in,
- prog_varset::in, prog_varset::out, cons_id::out,
- pair(cons_id, unify_sub_contexts)::out, list(hlds_goal)::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-expand_set_field_function_call_2(_, _, _, [], _, _, _, !VarSet, _, _, _,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- error("expand_set_field_function_call_2: empty list of field names").
-expand_set_field_function_call_2(Context, MainContext, SubContext0,
- [FieldName - FieldArgs | FieldNames], FieldValueVar,
- TermInputVar, TermOutputVar, !VarSet, Functor,
- FieldSubContext, Goals, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- make_fresh_arg_vars(FieldArgs, FieldArgVars, !VarSet, !SInfo, !IO),
- ( FieldNames = [_ | _] ->
- varset__new_var(!.VarSet, SubTermInputVar, !:VarSet),
- varset__new_var(!.VarSet, SubTermOutputVar, !:VarSet),
- SetArgs = list__append(FieldArgVars,
- [TermInputVar, SubTermOutputVar]),
- construct_field_access_function_call(set, Context,
- MainContext, SubContext0, FieldName, TermOutputVar,
- SetArgs, Functor, UpdateGoal, !QualInfo),
-
- % extract the field containing the field to update.
- construct_field_access_function_call(get, Context,
- MainContext, SubContext0, FieldName, SubTermInputVar,
- list__append(FieldArgVars, [TermInputVar]), _,
- GetSubFieldGoal, !QualInfo),
-
- % recursively update the field.
- SubTermInputArgNumber = 2 + list__length(FieldArgs),
- TermInputContext = Functor - SubTermInputArgNumber,
- SubContext = [TermInputContext | SubContext0],
- expand_set_field_function_call_2(Context, MainContext,
- SubContext, FieldNames, FieldValueVar, SubTermInputVar,
- SubTermOutputVar, !VarSet, _, FieldSubContext, Goals0,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- list__append([GetSubFieldGoal | Goals0], [UpdateGoal], Goals1)
- ;
- SetArgs = list__append(FieldArgVars,
- [TermInputVar, FieldValueVar]),
- construct_field_access_function_call(set, Context,
- MainContext, SubContext0, FieldName, TermOutputVar,
- SetArgs, Functor, Goal, !QualInfo),
- FieldSubContext = Functor - SubContext0,
- Goals1 = [Goal]
-
- ),
- ArgContext = functor(Functor, MainContext, SubContext0),
- goal_info_init(Context, GoalInfo),
- conj_list_to_goal(Goals1, GoalInfo, Conj0),
- insert_arg_unifications(FieldArgVars, FieldArgs, Context, ArgContext,
- Conj0, Conj, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_to_conj_list(Conj, Goals).
-
- % Expand a field extraction goal into a list of goals which
- % each get one level of the structure.
- %
- % A field extraction goal:
- % := (ModuleName, ^ module_info ^ sub_info ^ module_name,
- % DCG_in, DCG_out).
- % is expanded into
- % DCG_out = DCG_in,
- % V_1 = DCG_out ^ module_info
- % V_2 = V_1 ^ sub_info,
- % ModuleName = V_2 ^ module_name.
- %
-:- pred expand_dcg_field_extraction_goal(prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, field_list::in,
- prog_var::in, prog_var::in, prog_var::in,
- prog_varset::in, prog_varset::out, cons_id::out,
- pair(cons_id, unify_sub_contexts)::out, hlds_goal::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-expand_dcg_field_extraction_goal(Context, MainContext, SubContext, FieldNames,
- FieldValueVar, TermInputVar, TermOutputVar, !VarSet, Functor,
- FieldSubContext, Goal, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- % unify the DCG input and output variables
- make_atomic_unification(TermOutputVar, var(TermInputVar), Context,
- MainContext, SubContext, UnifyDCG, !QualInfo),
-
- % process the access function as a get function on
- % the output DCG variable
- expand_get_field_function_call_2(Context, MainContext, SubContext,
- FieldNames, FieldValueVar, TermOutputVar, !VarSet,
- Functor, FieldSubContext, Goals1, !ModuleInfo, !QualInfo, !SInfo, !IO),
- Goals = [UnifyDCG | Goals1],
- goal_info_init(Context, GoalInfo),
- conj_list_to_goal(Goals, GoalInfo, Goal).
-
- % Expand a field extraction function call into a list of goals which
- % each get one level of the structure.
- %
- % A field extraction goal:
- % ModuleName = Info ^ module_info ^ sub_info ^ module_name
- % is expanded into
- % V_1 = Info ^ module_info,
- % V_2 = V_1 ^ sub_info,
- % ModuleName = V_2 ^ module_name.
- %
-:- pred expand_get_field_function_call(prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, field_list::in,
- prog_var::in, prog_var::in, prog_varset::in, prog_varset::out,
- cons_id::out, pair(cons_id, unify_sub_contexts)::out, hlds_goal::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-expand_get_field_function_call(Context, MainContext, SubContext0,
- FieldNames, FieldValueVar, TermInputVar, !VarSet,
- Functor, FieldSubContext, Goal, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- expand_get_field_function_call_2(Context, MainContext, SubContext0,
- FieldNames, FieldValueVar, TermInputVar, !VarSet,
- Functor, FieldSubContext, Goals, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_init(Context, GoalInfo),
- conj_list_to_goal(Goals, GoalInfo, Goal).
-
-:- pred expand_get_field_function_call_2(prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, field_list::in,
- prog_var::in, prog_var::in, prog_varset::in, prog_varset::out,
- cons_id::out, pair(cons_id, unify_sub_contexts)::out, list(hlds_goal)::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-expand_get_field_function_call_2(_, _, _, [], _, _, _, _, _, _, _,
- !ModuleInfo, !QualInfo, !Sinfo, !IO) :-
- error("expand_get_field_function_call_2: empty list of field names").
-expand_get_field_function_call_2(Context, MainContext, SubContext0,
- [FieldName - FieldArgs | FieldNames], FieldValueVar,
- TermInputVar, !VarSet, Functor, FieldSubContext, Goals,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- make_fresh_arg_vars(FieldArgs, FieldArgVars, !VarSet, !SInfo, !IO),
- GetArgVars = list__append(FieldArgVars, [TermInputVar]),
- ( FieldNames = [_ | _] ->
- varset__new_var(!.VarSet, SubTermInputVar, !:VarSet),
- construct_field_access_function_call(get, Context, MainContext,
- SubContext0, FieldName, SubTermInputVar, GetArgVars, Functor, Goal,
- !QualInfo),
-
- % recursively extract until we run out of field names
- TermInputArgNumber = 1 + list__length(FieldArgVars),
- TermInputContext = Functor - TermInputArgNumber,
- SubContext = [TermInputContext | SubContext0],
- expand_get_field_function_call_2(Context, MainContext,
- SubContext, FieldNames, FieldValueVar, SubTermInputVar,
- !VarSet, _, FieldSubContext, Goals1, !ModuleInfo, !QualInfo, !SInfo,
- !IO),
- Goals2 = [Goal | Goals1]
- ;
- FieldSubContext = Functor - SubContext0,
- construct_field_access_function_call(get, Context,
- MainContext, SubContext0, FieldName, FieldValueVar,
- GetArgVars, Functor, Goal, !QualInfo),
- Goals2 = [Goal]
- ),
- ArgContext = functor(Functor, MainContext, SubContext0),
- goal_info_init(Context, GoalInfo),
- conj_list_to_goal(Goals2, GoalInfo, Conj0),
- insert_arg_unifications(FieldArgVars, FieldArgs, Context, ArgContext,
- Conj0, Conj, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_to_conj_list(Conj, Goals).
-
-:- pred construct_field_access_function_call(field_access_type::in,
- prog_context::in, unify_main_context::in, unify_sub_contexts::in,
- ctor_field_name::in, prog_var::in, list(prog_var)::in, cons_id::out,
- hlds_goal::out, qual_info::in, qual_info::out) is det.
-
-construct_field_access_function_call(AccessType, Context, MainContext,
- SubContext, FieldName, RetArg, Args, Functor, Goal, !QualInfo) :-
- field_access_function_name(AccessType, FieldName, FuncName),
- list__length(Args, Arity),
- Functor = cons(FuncName, Arity),
- make_atomic_unification(RetArg, functor(Functor, no, Args),
- Context, MainContext, SubContext, Goal, !QualInfo).
-
-:- type field_list == assoc_list(ctor_field_name, list(prog_term)).
-
-:- pred parse_field_list(prog_term::in,
- maybe1(field_list, prog_var_type)::out) is det.
-
-parse_field_list(Term, MaybeFieldNames) :-
- (
- Term = term__functor(term__atom("^"),
- [FieldNameTerm, OtherFieldNamesTerm], _)
- ->
- (
- parse_qualified_term(FieldNameTerm, FieldNameTerm,
- "field name", Result),
- Result = ok(FieldName, Args)
- ->
- parse_field_list(OtherFieldNamesTerm,
- MaybeFieldNames1),
- (
- MaybeFieldNames1 = error(_, _),
- MaybeFieldNames = MaybeFieldNames1
- ;
- MaybeFieldNames1 = ok(FieldNames1),
- MaybeFieldNames =
- ok([FieldName - Args | FieldNames1])
- )
- ;
- MaybeFieldNames = error("expected field name",
- FieldNameTerm)
- )
- ;
- (
- parse_qualified_term(Term, Term, "field name", Result),
- Result = ok(FieldName, Args)
- ->
- MaybeFieldNames = ok([FieldName - Args])
- ;
- MaybeFieldNames = error("expected field name", Term)
- )
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- inst aditi_update_str
- ---> "aditi_insert"
- ; "aditi_delete"
- ; "aditi_bulk_insert"
- ; "aditi_bulk_delete"
- ; "aditi_bulk_modify".
-
- % See the "Aditi update syntax" section of the
- % Mercury Language Reference Manual.
-:- pred transform_aditi_builtin(string::in(aditi_update_str),
- list(prog_term)::in, prog_context::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-transform_aditi_builtin(UpdateStr, Args0, Context, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- (
- ( UpdateStr = "aditi_insert", Update = insert
- ; UpdateStr = "aditi_delete", Update = delete
- )
- ->
- transform_aditi_tuple_update(UpdateStr, Update, Args0,
- Context, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- ( UpdateStr = "aditi_bulk_insert", Update = bulk_insert
- ; UpdateStr = "aditi_bulk_delete", Update = bulk_delete
- ; UpdateStr = "aditi_bulk_modify", Update = bulk_modify
- )
- ->
- transform_aditi_bulk_update(UpdateStr, Update, Args0,
- Context, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
-
- ;
- error("transform_aditi_builtin")
- ).
-
-:- pred transform_aditi_tuple_update(string::in, aditi_tuple_update::in,
- list(prog_term)::in, prog_context::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-transform_aditi_tuple_update(UpdateStr, Update, Args0, Context,
- Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- % Build an empty goal_info.
- goal_info_init(Context, GoalInfo),
-
- %
- % Syntax -
- % aditi_insert(p(_DB, X, Y), DB0, DB).
- %
- % `p(_DB, X, Y)' is the tuple to insert, not a higher-order term.
- %
- ( Args0 = [InsertTupleTerm, AditiState0Term, AditiStateTerm] ->
- (
- % Parse the tuple to insert.
- parse_pred_or_func_and_args(InsertTupleTerm,
- PredOrFunc, SymName, TupleArgTerms)
- ->
- %
- % Make new variables for the arguments.
- % The argument list of the `aditi_insert'
- % goal contains the arguments of the tuple
- % to insert and the `aditi__state' arguments.
- %
- make_fresh_arg_var(AditiState0Term, AditiState0Var, [],
- !VarSet, !SInfo, !IO),
- make_fresh_arg_var(AditiStateTerm, AditiStateVar, [],
- !VarSet, !SInfo, !IO),
- make_fresh_arg_vars(TupleArgTerms, TupleArgVars,
- !VarSet, !SInfo, !IO),
- list__append(TupleArgVars,
- [AditiState0Var, AditiStateVar], AllArgs),
- list__length(TupleArgVars, InsertArity),
-
- PredId = invalid_pred_id,
- Builtin = aditi_tuple_update(Update, PredId),
- InsertCallId = PredOrFunc - SymName/InsertArity,
- Call = generic_call(
- aditi_builtin(Builtin, InsertCallId),
- AllArgs, [], det),
- Goal0 = Call - GoalInfo,
- CallId = generic_call(aditi_builtin(Builtin,
- InsertCallId)),
- list__append(TupleArgTerms,
- [AditiState0Term, AditiStateTerm],
- AllArgTerms),
-
- record_called_pred_or_func(PredOrFunc, SymName, InsertArity,
- !QualInfo),
- insert_arg_unifications(AllArgs, AllArgTerms, Context,
- call(CallId), Goal0, Goal, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO)
- ;
- invalid_goal(UpdateStr, Args0, GoalInfo,
- Goal, !VarSet, !SInfo, !IO),
- qual_info_set_found_syntax_error(yes, !QualInfo),
- io__set_exit_status(1, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string("Error: expected tuple to ", !IO),
- io__write(Update, !IO),
- io__write_string(" in `", !IO),
- io__write_string(UpdateStr, !IO),
- io__write_string("'.\n", !IO)
- )
- ;
- invalid_goal(UpdateStr, Args0, GoalInfo, Goal, !VarSet,
- !SInfo, !IO),
- qual_info_set_found_syntax_error(yes, !QualInfo),
- list__length(Args0, Arity),
- aditi_update_arity_error(Context, UpdateStr, Arity, [3], !IO)
- ).
-
- % Parse an `aditi_delete' or `aditi_modify' goal.
-:- pred transform_aditi_bulk_update(string::in, aditi_bulk_update::in,
- list(prog_term)::in, prog_context::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-transform_aditi_bulk_update(Descr, Update, Args0, Context, UpdateGoal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- goal_info_init(Context, GoalInfo),
- (
- list__length(Args0, Arity),
- Arity \= 3,
- Arity \= 4
- ->
- invalid_goal(Descr, Args0, GoalInfo,
- UpdateGoal, !VarSet, !SInfo, !IO),
- qual_info_set_found_syntax_error(yes, !QualInfo),
- aditi_update_arity_error(Context, Descr, Arity, [3, 4], !IO)
- ;
- %
- % First syntax -
- % aditi_insert((p(X, Y, _DB0) :- X = 2, Y = 1), DB0, DB).
- % or
- % aditi_delete((p(X, Y, _DB0) :- X = 2), DB0, DB).
- % or
- % aditi_modify((p(X0, Y0, _DB0) ==> p(X0, Y, _DB) :-
- % X0 < 100, Y = Y0 + 1), DB0, DB).
- %
- Args0 = [HOTerm, AditiState0Term, AditiStateTerm],
- parse_rule_term(Context, HOTerm, HeadTerm, GoalTerm1),
- (
- Update = bulk_insert,
- parse_pred_or_func_and_args(HeadTerm,
- PredOrFunc, SymName, HeadArgs1),
- list__length(HeadArgs1, PredArity)
- ;
- Update = bulk_delete,
- parse_pred_or_func_and_args(HeadTerm,
- PredOrFunc, SymName, HeadArgs1),
- list__length(HeadArgs1, PredArity)
- ;
- Update = bulk_modify,
- HeadTerm = term__functor(term__atom("==>"),
- [LeftHeadTerm, RightHeadTerm], _),
- parse_pred_or_func_and_args(LeftHeadTerm,
- PredOrFunc, SymName, LeftHeadArgs),
- parse_pred_or_func_and_args(RightHeadTerm,
- PredOrFunc, SymName, RightHeadArgs),
- list__append(LeftHeadArgs, RightHeadArgs, HeadArgs1),
- list__length(LeftHeadArgs, PredArity),
- list__length(RightHeadArgs, PredArity)
- )
- ->
- %
- % This syntax is transformed into a construction of
- % a lambda expression for the modification condition
- % and a call to an update goal with that closure.
- % The transformed code is equivalent to the
- % `sym_name_and_closure' syntax which is parsed below.
- %
- Syntax = pred_term,
-
- %
- % Parse the modification goal as for a lambda expression.
- %
- make_fresh_arg_vars(HeadArgs1, HeadArgs, !VarSet, !SInfo, !IO),
- term__coerce(GoalTerm1, GoalTerm),
- parse_goal(GoalTerm, ParsedGoal, !VarSet),
-
- prepare_for_lambda(!SInfo),
-
- hlds_goal__true_goal(PredHead0),
- ArgContext = head(PredOrFunc, PredArity),
- insert_arg_unifications(HeadArgs, HeadArgs1, Context, ArgContext,
- PredHead0, PredHead, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
-
- map__init(Substitution),
- transform_goal(ParsedGoal, Substitution, PredBody,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- finish_head_and_body(Context, FinalSVarMap, PredHead, PredBody,
- PredGoal0, !.SInfo),
-
- % Quantification will reduce this down to
- % the proper set of nonlocal arguments.
- goal_util__goal_vars(PredGoal, LambdaGoalVars0),
- set__delete_list(LambdaGoalVars0, HeadArgs, LambdaGoalVars1),
- set__to_sorted_list(LambdaGoalVars1, LambdaNonLocals),
- aditi_bulk_update_goal_info(Update,
- PredOrFunc, SymName, PredArity, HeadArgs,
- LambdaPredOrFunc, EvalMethod, LambdaModes,
- Detism, PredGoal0, PredGoal),
- ModifiedCallId = PredOrFunc - SymName/PredArity,
-
- PredId = invalid_pred_id,
- Builtin = aditi_bulk_update(Update, PredId, Syntax),
- MainContext =
- call(generic_call(
- aditi_builtin(Builtin, ModifiedCallId)),
- 1),
- varset__new_var(!.VarSet, LambdaVar, !:VarSet),
-
- % Tell purity.m to change the mode of the `aditi__state'
- % arguments of the closure to `unused', to make sure
- % that the closure does not call any Aditi relations.
- % We don't know which argument is the `aditi__state' until
- % after typechecking.
- % The `aditi__state's are passed even though they are not
- % used to make the arguments of the closure match the
- % arguments of the relation being updated.
- FixModes = modes_need_fixing,
-
- % Build the lambda expression for the modification condition.
- make_atomic_unification(LambdaVar,
- lambda_goal((pure), LambdaPredOrFunc, EvalMethod,
- FixModes, LambdaNonLocals,
- HeadArgs, LambdaModes, Detism, PredGoal),
- Context, MainContext, [], LambdaConstruct, !QualInfo),
-
- make_fresh_arg_var(AditiState0Term, AditiState0Var, [],
- !VarSet, !SInfo, !IO),
- make_fresh_arg_var(AditiStateTerm, AditiStateVar, [],
- !VarSet, !SInfo, !IO),
- AllArgs = [LambdaVar, AditiState0Var, AditiStateVar],
-
- % post_typecheck.m will fill this in.
- GenericCallModes = [],
-
- Call = generic_call(aditi_builtin(Builtin, ModifiedCallId),
- AllArgs, GenericCallModes, det) - GoalInfo,
-
- %
- % Wrap an explicit quantification around the goal to make
- % sure that the closure construction and the
- % `aditi_delete' or `aditi_modify' call are not separated.
- % Separating the goals would make optimization of the update
- % using indexes more difficult.
- %
- UpdateConj = scope(barrier(not_removable),
- conj([LambdaConstruct, Call]) - GoalInfo) - GoalInfo,
-
- CallId = call(generic_call(
- aditi_builtin(Builtin, ModifiedCallId))),
-
- record_called_pred_or_func(PredOrFunc, SymName, PredArity,
- !QualInfo),
- insert_arg_unifications(AllArgs,
- [term__variable(LambdaVar), AditiState0Term, AditiStateTerm],
- Context, CallId, UpdateConj, UpdateGoal, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO)
- ;
- %
- % Second syntax -
- % aditi_bulk_delete(pred p/3,
- % (aditi_bottom_up pred(..) :- ..), DB0, DB).
- %
- % The `pred_term' syntax parsed above is transformed
- % into the equivalent of this syntax.
- %
- Args0 = [PredCallIdTerm | OtherArgs0],
- OtherArgs0 = [_, _, _],
-
- parse_pred_or_func_name_and_arity(PredCallIdTerm,
- PredOrFunc, SymName, Arity0),
- adjust_func_arity(PredOrFunc, Arity0, Arity)
- ->
- Syntax = sym_name_and_closure,
-
- make_fresh_arg_vars(OtherArgs0,
- OtherArgs, !VarSet, !SInfo, !IO),
- PredId = invalid_pred_id,
-
- Builtin = aditi_bulk_update(Update, PredId, Syntax),
-
- ModifiedCallId = PredOrFunc - SymName/Arity,
-
- % post_typecheck.m will fill this in.
- GenericCallModes = [],
-
- Call = generic_call(aditi_builtin(Builtin, ModifiedCallId),
- OtherArgs, GenericCallModes, det) - GoalInfo,
- CallId = call(generic_call(aditi_builtin(Builtin, ModifiedCallId))),
- record_called_pred_or_func(PredOrFunc, SymName, Arity, !QualInfo),
- insert_arg_unifications(OtherArgs, OtherArgs0, Context, CallId,
- Call, UpdateGoal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- invalid_goal(Descr, Args0, GoalInfo, UpdateGoal, !VarSet, !SInfo, !IO),
- qual_info_set_found_syntax_error(yes, !QualInfo),
- io__set_exit_status(1, !IO),
- output_expected_aditi_update_syntax(Context, Update, !IO)
- ).
-
-:- pred aditi_bulk_update_goal_info(aditi_bulk_update::in, pred_or_func::in,
- sym_name::in, arity::in, list(prog_var)::in, pred_or_func::out,
- lambda_eval_method::out, list(mode)::out, determinism::out,
- hlds_goal::in, hlds_goal::out) is det.
-
-aditi_bulk_update_goal_info(bulk_insert, PredOrFunc, _SymName,
- PredArity, _Args, LambdaPredOrFunc, EvalMethod,
- LambdaModes, Detism, Goal, Goal) :-
- LambdaPredOrFunc = PredOrFunc,
- EvalMethod = (aditi_bottom_up),
- out_mode(OutMode),
- Detism = nondet,
- % Modes for the arguments of the input tuple.
- list__duplicate(PredArity, OutMode, LambdaModes).
-
-aditi_bulk_update_goal_info(bulk_delete, PredOrFunc,
- SymName, PredArity, Args, LambdaPredOrFunc, EvalMethod,
- LambdaModes, Detism, Goal0, Goal) :-
- LambdaPredOrFunc = PredOrFunc,
- EvalMethod = (aditi_bottom_up),
- Detism = nondet,
- out_mode(OutMode),
- list__duplicate(PredArity, OutMode, LambdaModes),
-
- % Join the result of the deletion goal with the
- % relation to be updated.
- conjoin_aditi_update_goal_with_call(PredOrFunc, SymName,
- Args, Goal0, Goal).
-
-aditi_bulk_update_goal_info(bulk_modify, PredOrFunc,
- SymName, PredArity, Args, LambdaPredOrFunc, EvalMethod,
- LambdaModes, Detism, Goal0, Goal) :-
-
- % The closure passed to `aditi_modify' and `aditi_bulk_modify'
- % is always a predicate closure.
- LambdaPredOrFunc = predicate,
-
- out_mode(OutMode),
- EvalMethod = (aditi_bottom_up),
- Detism = nondet,
-
- % Modes for the arguments corresponding to
- % the input tuple.
- list__duplicate(PredArity, OutMode, DeleteModes),
-
- % `Args' must have length `PredArity * 2',
- % so this will always succeed.
- ( list__take(PredArity, Args, CallArgs0) ->
- CallArgs = CallArgs0
- ;
- error("aditi_delete_insert_delete_modify_goal_info")
- ),
-
- % Join the result of the modify goal with the
- % relation to be updated.
- conjoin_aditi_update_goal_with_call(PredOrFunc, SymName,
- CallArgs, Goal0, Goal),
-
- % Modes for the arguments corresponding to
- % the output tuple.
- list__duplicate(PredArity, OutMode, InsertModes),
- list__append(DeleteModes, InsertModes, LambdaModes).
-
-:- pred conjoin_aditi_update_goal_with_call(pred_or_func::in, sym_name::in,
- list(prog_var)::in, hlds_goal::in, hlds_goal::out) is det.
-
-conjoin_aditi_update_goal_with_call(PredOrFunc, SymName, Args, Goal0, Goal) :-
- PredId = invalid_pred_id,
- Goal0 = _ - GoalInfo,
-
- % The predicate is recorded as used in
- % transform_aditi_tuple_update and
- % transform_aditi_insert_delete_modify
- do_construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args,
- GoalInfo, CallGoal),
-
- Goal = conj([CallGoal, Goal0]) - GoalInfo.
-
-:- pred output_expected_aditi_update_syntax(prog_context::in,
- aditi_bulk_update::in, io::di, io::uo) is det.
-
-output_expected_aditi_update_syntax(Context, bulk_insert, !IO) :-
- output_insert_or_delete_expected_syntax(Context, "aditi_bulk_insert", !IO).
-output_expected_aditi_update_syntax(Context, bulk_delete, !IO) :-
- output_insert_or_delete_expected_syntax(Context, "aditi_bulk_delete", !IO).
-output_expected_aditi_update_syntax(Context, bulk_modify, !IO) :-
- Name = "aditi_bulk_modify",
- prog_out__write_context(Context, !IO),
- io__write_string("Error: expected\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" `", !IO),
- io__write_string(Name, !IO),
- io__write_string("(\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" (p(<Args0>) ==> p(<Args>) :- <Goal>),\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string( " DB0, DB)'\n", !IO),
- output_aditi_closure_syntax(Context, Name, !IO).
-
-:- pred output_insert_or_delete_expected_syntax(prog_context::in, string::in,
- io::di, io::uo) is det.
-
-output_insert_or_delete_expected_syntax(Context, Name, !IO) :-
- prog_out__write_context(Context, !IO),
- io__write_string("Error: expected `", !IO),
- io__write_string(Name, !IO),
- io__write_string("((p(<Args>) :- <Goal>), DB0, DB)'\n", !IO),
- output_aditi_closure_syntax(Context, Name, !IO).
-
-:- pred output_aditi_closure_syntax(prog_context::in, string::in,
- io::di, io::uo) is det.
-
-output_aditi_closure_syntax(Context, Name, !IO) :-
- prog_out__write_context(Context, !IO),
- io__write_string(" or `", !IO),
- io__write_string(Name, !IO),
- io__write_string("(PredOrFunc p/N, Closure, DB0, DB)'.\n", !IO).
-
- % Report an error for an Aditi update with the wrong number
- % of arguments.
-:- pred aditi_update_arity_error(prog_context::in, string::in, int::in,
- list(int)::in, io::di, io::uo) is det.
-
-aditi_update_arity_error(Context, UpdateStr, Arity, ExpectedArities, !IO) :-
- io__set_exit_status(1, !IO),
- MaybePredOrFunc = no,
- prog_out__write_context(Context, !IO),
- io__write_string("Error: ", !IO),
- MaybePredOrFunc = no,
- report_error_num_args(MaybePredOrFunc, Arity, ExpectedArities, !IO),
- io__nl(!IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" in `", !IO),
- io__write_string(UpdateStr, !IO),
- io__write_string("'.\n", !IO).
-
- % Produce an invalid goal when parsing of an Aditi update fails.
-:- pred invalid_goal(string::in, list(prog_term)::in, hlds_goal_info::in,
- hlds_goal::out, prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-invalid_goal(UpdateStr, Args0, GoalInfo, Goal, !VarSet, !SInfo, !IO) :-
- make_fresh_arg_vars(Args0, HeadVars, !VarSet, !SInfo, !IO),
- MaybeUnifyContext = no,
- Goal = call(invalid_pred_id, invalid_proc_id, HeadVars, not_builtin,
- MaybeUnifyContext, unqualified(UpdateStr)) - GoalInfo.
-
-%-----------------------------------------------------------------------------
-
- % `insert_arg_unifications' takes a list of variables,
- % a list of terms to unify them with, and a goal, and
- % inserts the appropriate unifications onto the front of
- % the goal. It calls `unravel_unification' to ensure
- % that each unification gets reduced to superhomogeneous form.
- % It also gets passed an `arg_context', which indicates
- % where the terms came from.
-
- % We never insert unifications of the form X = X.
-
-:- type arg_context
- --->
- % the arguments in the head of the clause
- head(pred_or_func, arity)
- ;
- % the arguments in a call to a predicate
- call(call_id)
- ;
- % the arguments in a functor
- functor(
- cons_id,
- unify_main_context,
- unify_sub_contexts
- ).
-
-:- pred insert_arg_unifications(list(prog_var)::in, list(prog_term)::in,
- prog_context::in, arg_context::in,
- hlds_goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-insert_arg_unifications(HeadVars, Args0, Context, ArgContext,
- !Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- (
- HeadVars = []
- ;
- HeadVars = [_ | _],
- !.Goal = _ - GoalInfo0,
- goal_to_conj_list(!.Goal, Goals0),
- substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO),
- insert_arg_unifications_2(HeadVars, Args, Context, ArgContext,
- 0, Goals0, Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_set_context(GoalInfo0, Context, GoalInfo),
- conj_list_to_goal(Goals, GoalInfo, !:Goal)
- ).
-
-:- pred insert_arg_unifications_2(list(prog_var)::in, list(prog_term)::in,
- prog_context::in, arg_context::in, int::in,
- list(hlds_goal)::in, list(hlds_goal)::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-insert_arg_unifications_2([], [_ | _], _, _, _, _, _, _, _, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- error("insert_arg_unifications_2: length mismatch").
-insert_arg_unifications_2([_ | _], [], _, _, _, _, _, _, _, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- error("insert_arg_unifications_2: length mismatch").
-insert_arg_unifications_2([], [], _, _, _, !Goals, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO).
-insert_arg_unifications_2([Var | Vars], [Arg | Args], Context, ArgContext,
- N0, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo,
- !IO) :-
- N1 = N0 + 1,
- insert_arg_unification(Var, Arg, Context, ArgContext, N1,
- !VarSet, ArgUnifyConj, !ModuleInfo, !QualInfo, !SInfo, !IO),
- (
- ArgUnifyConj = [],
- % Allow the recursive call to be tail recursive.
- insert_arg_unifications_2(Vars, Args, Context, ArgContext,
- N1, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- ArgUnifyConj = [_ | _],
- insert_arg_unifications_2(Vars, Args, Context, ArgContext,
- N1, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- list__append(ArgUnifyConj, !.Goals, !:Goals)
- ).
-
-:- pred insert_arg_unifications_with_supplied_contexts(list(prog_var)::in,
- list(prog_term)::in, assoc_list(int, arg_context)::in, prog_context::in,
- hlds_goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms0, ArgContexts,
- Context, !Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo,
- !IO) :-
- (
- ArgVars = []
- ;
- ArgVars = [_ | _],
- !.Goal = _ - GoalInfo0,
- goal_to_conj_list(!.Goal, GoalList0),
- substitute_state_var_mappings(ArgTerms0, ArgTerms, !VarSet, !SInfo,
- !IO),
- insert_arg_unifications_with_supplied_contexts_2(ArgVars, ArgTerms,
- ArgContexts, Context, GoalList0, GoalList, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_set_context(GoalInfo0, Context, GoalInfo),
- conj_list_to_goal(GoalList, GoalInfo, !:Goal)
- ).
-
-:- pred insert_arg_unifications_with_supplied_contexts_2(list(prog_var)::in,
- list(prog_term)::in, assoc_list(int, arg_context)::in, prog_context::in,
- list(hlds_goal)::in, list(hlds_goal)::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-insert_arg_unifications_with_supplied_contexts_2(Vars, Terms, ArgContexts,
- Context, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- (
- Vars = [],
- Terms = [],
- ArgContexts = []
- ->
- true
- ;
- Vars = [Var | VarsTail],
- Terms = [Term | TermsTail],
- ArgContexts = [ArgNumber - ArgContext | ArgContextsTail]
- ->
- insert_arg_unification(Var, Term, Context, ArgContext, ArgNumber,
- !VarSet, UnifyConj, !ModuleInfo, !QualInfo, !SInfo, !IO),
- insert_arg_unifications_with_supplied_contexts_2(VarsTail, TermsTail,
- ArgContextsTail, Context, !Goals, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- list__append(UnifyConj, !.Goals, !:Goals)
- ;
- error("insert_arg_unifications_with_supplied_contexts")
- ).
-
-:- pred insert_arg_unification(prog_var::in, prog_term::in, prog_context::in,
- arg_context::in, int::in, prog_varset::in, prog_varset::out,
- list(hlds_goal)::out, module_info::in, module_info::out,
- qual_info::in, qual_info::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
-
-insert_arg_unification(Var, Arg, Context, ArgContext, N1, !VarSet,
- ArgUnifyConj, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- ( Arg = term__variable(Var) ->
- % Skip unifications of the form `X = X'
- ArgUnifyConj = []
- ;
- arg_context_to_unify_context(ArgContext, N1, UnifyMainContext,
- UnifySubContext),
- unravel_unification(term__variable(Var), Arg, Context,
- UnifyMainContext, UnifySubContext, pure, Goal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_to_conj_list(Goal, ArgUnifyConj)
- ).
-
- % append_arg_unifications is the same as insert_arg_unifications,
- % except that the unifications are added after the goal rather
- % than before the goal.
-
-:- pred append_arg_unifications(list(prog_var)::in, list(prog_term)::in,
- prog_context::in, arg_context::in, hlds_goal::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-append_arg_unifications(HeadVars, Args0, Context, ArgContext,
- !Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- (
- HeadVars = []
- ;
- HeadVars = [_ | _],
- !.Goal = _ - GoalInfo,
- goal_to_conj_list(!.Goal, List0),
- substitute_state_var_mappings(Args0, Args, !VarSet,
- !SInfo, !IO),
- append_arg_unifications_2(HeadVars, Args, Context, ArgContext,
- 0, List0, List, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- conj_list_to_goal(List, GoalInfo, !:Goal)
- ).
-
-:- pred append_arg_unifications_2(list(prog_var)::in, list(prog_term)::in,
- prog_context::in, arg_context::in, int::in,
- list(hlds_goal)::in, list(hlds_goal)::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-append_arg_unifications_2([], [_|_], _, _, _, _, _, _, _, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- error("append_arg_unifications_2: length mismatch").
-append_arg_unifications_2([_|_], [], _, _, _, _, _, _, _, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- error("append_arg_unifications_2: length mismatch").
-append_arg_unifications_2([], [], _, _, _, !List, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO).
-append_arg_unifications_2([Var|Vars], [Arg|Args], Context, ArgContext,
- N0, !List, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- N1 = N0 + 1,
- append_arg_unification(Var, Arg, Context, ArgContext, N1, ConjList,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- list__append(!.List, ConjList, !:List),
- append_arg_unifications_2(Vars, Args, Context, ArgContext, N1,
- !List, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
-
-:- pred append_arg_unification(prog_var::in, prog_term::in, prog_context::in,
- arg_context::in, int::in, list(hlds_goal)::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-append_arg_unification(Var, Arg, Context, ArgContext, N1, ConjList,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- ( Arg = term__variable(Var) ->
- % skip unifications of the form `X = X'
- ConjList = []
- ;
- arg_context_to_unify_context(ArgContext, N1, UnifyMainContext,
- UnifySubContext),
- unravel_unification(term__variable(Var), Arg, Context,
- UnifyMainContext, UnifySubContext, pure, Goal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_to_conj_list(Goal, ConjList)
- ).
-
-:- pred arg_context_to_unify_context(arg_context::in, int::in,
- unify_main_context::out, unify_sub_contexts::out) is det.
-
-arg_context_to_unify_context(head(PredOrFunc, Arity), ArgNum,
- ArgContext, []) :-
- ( PredOrFunc = function, ArgNum = Arity ->
- % it's the function result term in the head
- ArgContext = head_result
- ;
- % it's a head argument
- ArgContext = head(ArgNum)
- ).
-arg_context_to_unify_context(call(PredId), ArgNum, call(PredId, ArgNum), []).
-arg_context_to_unify_context(functor(ConsId, MainContext, SubContexts), ArgNum,
- MainContext, [ConsId - ArgNum | SubContexts]).
-
-%-----------------------------------------------------------------------------%
-
- % make_fresh_arg_vars(Args, VarSet0, Vars, VarSet, !SInfo, !IO):
- % `Vars' is a list of distinct variables corresponding to
- % the terms in `Args'. For each term in `Args', if
- % the term is a variable V which is distinct from the
- % variables already produced, then the corresponding
- % variable in `Vars' is just V, otherwise a fresh variable
- % is allocated from `VarSet0'. `VarSet' is the resulting
- % varset after all the necessary variables have been allocated.
- % !SInfo and !IO are required to handle state variables.
- %
- % For efficiency, the list `Vars' is constructed backwards
- % and then reversed to get the correct order.
-
-:- pred make_fresh_arg_vars(list(prog_term)::in, list(prog_var)::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
-
-make_fresh_arg_vars(Args, Vars, !VarSet, !SInfo, !IO) :-
- make_fresh_arg_vars_2(Args, [], Vars1, !VarSet, !SInfo, !IO),
- list__reverse(Vars1, Vars).
-
-:- pred make_fresh_arg_vars_2(list(prog_term)::in, list(prog_var)::in,
- list(prog_var)::out, prog_varset::in,prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-make_fresh_arg_vars_2([], Vars, Vars, !VarSet, !SInfo, !IO).
-make_fresh_arg_vars_2([Arg | Args], Vars0, Vars, !VarSet, !SInfo, !IO) :-
- make_fresh_arg_var(Arg, Var, Vars0, !VarSet, !SInfo, !IO),
- make_fresh_arg_vars_2(Args, [Var | Vars0], Vars, !VarSet, !SInfo, !IO).
-
-:- pred make_fresh_arg_var(prog_term::in, prog_var::out, list(prog_var)::in,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
-
-make_fresh_arg_var(Arg0, Var, Vars0, !VarSet, !SInfo, !IO) :-
- substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO),
- (
- Arg = term__variable(ArgVar),
- \+ list__member(ArgVar, Vars0)
- ->
- Var = ArgVar
- ;
- varset__new_var(!.VarSet, Var, !:VarSet)
- ).
-
-%-----------------------------------------------------------------------------%
-
- %
- % XXX We could do better on the error messages for
- % lambda expressions and field extraction and update expressions.
- %
-:- pred unravel_unification(prog_term::in, prog_term::in, prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, purity::in,
- hlds_goal::out, prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-unravel_unification(LHS0, RHS0, Context, MainContext, SubContext,
- Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- substitute_state_var_mapping(LHS0, LHS, !VarSet, !SInfo, !IO),
- substitute_state_var_mapping(RHS0, RHS, !VarSet, !SInfo, !IO),
- unravel_unification_2(LHS, RHS, Context, MainContext, SubContext,
- Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
-
-:- pred unravel_unification_2(prog_term::in, prog_term::in, prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, purity::in,
- hlds_goal::out, prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
- % `X = Y' needs no unravelling.
-
-unravel_unification_2(term__variable(X), term__variable(Y), Context,
- MainContext, SubContext, Purity, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- make_atomic_unification(X, var(Y), Context, MainContext, SubContext, Goal,
- !QualInfo),
- check_expr_purity(Purity, Context, !ModuleInfo, !IO).
-
- % If we find a unification of the form
- % X = f(A1, A2, A3)
- % we replace it with
- % X = f(NewVar1, NewVar2, NewVar3),
- % NewVar1 = A1,
- % NewVar2 = A2,
- % NewVar3 = A3.
- % In the trivial case `X = c', no unravelling occurs.
-
-unravel_unification_2(term__variable(X), RHS, Context, MainContext, SubContext,
- Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- RHS = term__functor(F, Args1, FunctorContext),
- substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !IO),
- (
- % Handle explicit type qualification.
- F = term__atom("with_type"),
- Args = [RVal, DeclType0]
- ->
- convert_type(DeclType0, DeclType),
- varset__coerce(!.VarSet, DeclVarSet),
- process_type_qualification(X, DeclType, DeclVarSet,
- Context, !ModuleInfo, !QualInfo, !IO),
- unravel_unification(term__variable(X), RVal, Context,
- MainContext, SubContext, Purity, Goal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- % Handle unification expressions.
- F = term__atom("@"),
- Args = [LVal, RVal]
- ->
- unravel_unification(term__variable(X), LVal, Context,
- MainContext, SubContext, Purity, Goal1,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- unravel_unification(term__variable(X), RVal, Context,
- MainContext, SubContext, Purity, Goal2,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_init(GoalInfo),
- goal_to_conj_list(Goal1, ConjList1),
- goal_to_conj_list(Goal2, ConjList2),
- list__append(ConjList1, ConjList2, ConjList),
- conj_list_to_goal(ConjList, GoalInfo, Goal)
- ;
- (
- % handle lambda expressions
- parse_lambda_eval_method(RHS, EvalMethod0, RHS1),
- RHS1 = term__functor(term__atom("lambda"), Args1, _),
- Args1 = [LambdaExpressionTerm0, GoalTerm0],
- term__coerce(LambdaExpressionTerm0, LambdaExpressionTerm),
- parse_lambda_expression(LambdaExpressionTerm, Vars0, Modes0, Det0)
- ->
- LambdaPurity = (pure),
- PredOrFunc = predicate,
- EvalMethod = EvalMethod0,
- Vars1 = Vars0,
- Modes1 = Modes0,
- Det1 = Det0,
- GoalTerm1 = GoalTerm0,
- WarnDeprecatedLambda = yes
- ;
- % handle higher-order pred and func expressions -
- % same semantics as lambda expressions, different
- % syntax (the original lambda expression syntax
- % is now deprecated)
- parse_rule_term(Context, RHS, HeadTerm0, GoalTerm1),
- term__coerce(HeadTerm0, HeadTerm1),
- parse_purity_annotation(HeadTerm1, LambdaPurity,
- HeadTerm),
- (
- parse_pred_expression(HeadTerm, EvalMethod0,
- Vars0, Modes0, Det0)
- ->
- PredOrFunc = predicate,
- EvalMethod = EvalMethod0,
- Vars1 = Vars0,
- Modes1 = Modes0,
- Det1 = Det0
- ;
- parse_func_expression(HeadTerm, EvalMethod,
- Vars1, Modes1, Det1),
- PredOrFunc = function
- ),
- WarnDeprecatedLambda = no
- )
- ->
- (
- WarnDeprecatedLambda = yes,
- report_warning(Context, 0,
- [words("Warning:"),
- words("deprecated lambda expression syntax."),
- nl,
- words("Lambda expressions with lambda as the"),
- words("top-level functor are deprecated;"),
- words("please use the form"),
- words("using pred instead.")],
- !IO)
- ;
- WarnDeprecatedLambda = no
- ),
- check_expr_purity(Purity, Context, !ModuleInfo, !IO),
- make_hlds__qualify_lambda_mode_list(Modes1, Modes, Context,
- !QualInfo, !IO),
- Det = Det1,
- term__coerce(GoalTerm1, GoalTerm),
- parse_goal(GoalTerm, ParsedGoal, !VarSet),
- build_lambda_expression(X, LambdaPurity, PredOrFunc, EvalMethod,
- Vars1, Modes, Det, ParsedGoal, Context, MainContext,
- SubContext, Goal, !VarSet, !ModuleInfo, !QualInfo, !.SInfo,
- !IO)
- ;
- % handle higher-order dcg pred expressions -
- % same semantics as higher-order pred expressions,
- % but has two extra arguments, and the goal is expanded
- % as a DCG goal.
- F = term__atom("-->"),
- Args = [PredTerm0, GoalTerm0],
- term__coerce(PredTerm0, PredTerm1),
- parse_purity_annotation(PredTerm1, DCGLambdaPurity, PredTerm),
- parse_dcg_pred_expression(PredTerm, EvalMethod, Vars0, Modes0, Det)
- ->
- make_hlds__qualify_lambda_mode_list(Modes0, Modes, Context, !QualInfo,
- !IO),
- term__coerce(GoalTerm0, GoalTerm),
- parse_dcg_pred_goal(GoalTerm, ParsedGoal, DCG0, DCGn, !VarSet),
- list__append(Vars0, [term__variable(DCG0), term__variable(DCGn)],
- Vars1),
- build_lambda_expression(X, DCGLambdaPurity, predicate, EvalMethod,
- Vars1, Modes, Det, ParsedGoal, Context, MainContext, SubContext,
- Goal0, !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
- Goal0 = GoalExpr - GoalInfo0,
- add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo),
- Goal = GoalExpr - GoalInfo
- ;
- % handle if-then-else expressions
- (
- F = term__atom("else"),
- IfThenTerm = term__functor(
- term__atom("if"),
- [term__functor(term__atom("then"), [IfTerm0, ThenTerm], _)],
- _),
- Args = [IfThenTerm, ElseTerm]
- ;
- F = term__atom(";"),
- Args = [term__functor(term__atom("->"), [IfTerm0, ThenTerm], _),
- ElseTerm]
- ),
- term__coerce(IfTerm0, IfTerm),
- parse_some_vars_goal(IfTerm, Vars, StateVars, IfParseTree, !VarSet)
- ->
- BeforeSInfo = !.SInfo,
- prepare_for_if_then_else_expr(StateVars, !VarSet, !SInfo),
-
- check_expr_purity(Purity, Context, !ModuleInfo, !IO),
- map__init(EmptySubst),
- transform_goal(IfParseTree, EmptySubst, IfGoal, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- finish_if_then_else_expr_condition(BeforeSInfo, !SInfo),
-
- unravel_unification(term__variable(X), ThenTerm,
- Context, MainContext, SubContext, pure, ThenGoal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- finish_if_then_else_expr_then_goal(StateVars, BeforeSInfo, !SInfo),
-
- unravel_unification(term__variable(X), ElseTerm,
- Context, MainContext, SubContext, pure,
- ElseGoal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- IfThenElse = if_then_else(StateVars ++ Vars, IfGoal, ThenGoal,
- ElseGoal),
- goal_info_init(Context, GoalInfo),
- Goal = IfThenElse - GoalInfo
- ;
- % handle field extraction expressions
- F = term__atom("^"),
- Args = [InputTerm, FieldNameTerm],
- parse_field_list(FieldNameTerm, FieldNameResult),
- FieldNameResult = ok(FieldNames)
- ->
- check_expr_purity(Purity, Context, !ModuleInfo, !IO),
- make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo, !IO),
- expand_get_field_function_call(Context, MainContext, SubContext,
- FieldNames, X, InputTermVar, !VarSet, Functor, _, Goal0,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- ArgContext = functor(Functor, MainContext, SubContext),
- insert_arg_unifications([InputTermVar], [InputTerm],
- FunctorContext, ArgContext, Goal0, Goal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- % handle field update expressions
- F = term__atom(":="),
- Args = [FieldDescrTerm, FieldValueTerm],
- FieldDescrTerm = term__functor(term__atom("^"),
- [InputTerm, FieldNameTerm], _),
- parse_field_list(FieldNameTerm, FieldNameResult),
- FieldNameResult = ok(FieldNames)
- ->
- check_expr_purity(Purity, Context, !ModuleInfo, !IO),
- make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo, !IO),
- make_fresh_arg_var(FieldValueTerm, FieldValueVar, [InputTermVar],
- !VarSet, !SInfo, !IO),
-
- expand_set_field_function_call(Context, MainContext, SubContext,
- FieldNames, FieldValueVar, InputTermVar, X, !VarSet,
- Functor, InnerFunctor - FieldSubContext, Goal0,
- !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- TermArgContext = functor(Functor, MainContext, SubContext),
- TermArgNumber = 1,
- FieldArgContext = functor(InnerFunctor, MainContext, FieldSubContext),
- FieldArgNumber = 2,
- ArgContexts = [TermArgNumber - TermArgContext,
- FieldArgNumber - FieldArgContext],
- insert_arg_unifications_with_supplied_contexts(
- [InputTermVar, FieldValueVar],
- [InputTerm, FieldValueTerm], ArgContexts, Context,
- Goal0, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- % handle the usual case
- parse_qualified_term(RHS, RHS, "", MaybeFunctor),
- (
- MaybeFunctor = ok(FunctorName, FunctorArgs),
- list__length(FunctorArgs, Arity),
- ConsId = cons(FunctorName, Arity)
- ;
- % float, int or string constant
- % - any errors will be caught by typechecking
- MaybeFunctor = error(_, _),
- list__length(Args, Arity),
- ConsId = make_functor_cons_id(F, Arity),
- FunctorArgs = Args
- ),
- (
- FunctorArgs = [],
- make_atomic_unification(X, functor(ConsId, no, []), Context,
- MainContext, SubContext, Goal0, !QualInfo),
- Goal0 = GoalExpr - GoalInfo0,
- add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo),
- % We could attach the from_ground_term feature to Goal,
- % but there would be no gain from doing so, whereas the
- % increase would lead to a slight increase in memory and time
- % requirements.
- Goal = GoalExpr - GoalInfo
- ;
- FunctorArgs = [_ | _],
- make_fresh_arg_vars(FunctorArgs, HeadVars, !VarSet, !SInfo, !IO),
- make_atomic_unification(X, functor(ConsId, no, HeadVars), Context,
- MainContext, SubContext, Goal0, !QualInfo),
- ArgContext = functor(ConsId, MainContext, SubContext),
- % Should this be insert_... rather than append_...?
- % No, because that causes efficiency problems
- % with type-checking :-(
- % But for impure unifications, we need to do
- % this, because mode reordering can't reorder
- % around the functor unification.
- ( Purity = pure ->
- append_arg_unifications(HeadVars, FunctorArgs, FunctorContext,
- ArgContext, Goal0, Goal2, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- Goal0 = GoalExpr0 - GoalInfo0,
- add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo1),
- Goal1 = GoalExpr0 - GoalInfo1,
- insert_arg_unifications(HeadVars, FunctorArgs, FunctorContext,
- ArgContext, Goal1, Goal2, !VarSet,
- !ModuleInfo, !QualInfo, !SInfo, !IO)
- ),
- % This "optimization" is disabled, because the extra cost of
- % traversing the scope goals in typechecking is more than the
- % savings from the reduction in delays/wakeups in modechecking.
- (
- semidet_fail,
- ground_terms(FunctorArgs)
- ->
- % This insertion of the `scope' goal is undone by the code
- % handling `scope' goals in modecheck_goal_expr in modes.m.
-
- Goal2 = _GoalExpr2 - GoalInfo,
- GoalExpr = scope(from_ground_term(X), Goal2),
- Goal = GoalExpr - GoalInfo
- ;
- Goal = Goal2
- )
- )
- ).
-
-:- pred ground_term(term(T)::in) is semidet.
-
-ground_term(term__functor(_, Terms, _)) :-
- ground_terms(Terms).
-
-:- pred ground_terms(list(term(T))::in) is semidet.
-
-ground_terms([]).
-ground_terms([Term | Terms]) :-
- ground_term(Term),
- ground_terms(Terms).
-
- % Handle `f(...) = X' in the same way as `X = f(...)'.
-
-unravel_unification_2(term__functor(F, As, FC), term__variable(Y), C, MC, SC,
- Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- unravel_unification(term__variable(Y), term__functor(F, As, FC), C, MC, SC,
- Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
-
- % If we find a unification of the form `f1(...) = f2(...)',
- % then we replace it with `Tmp = f1(...), Tmp = f2(...)',
- % and then process it according to the rule above.
- % Note that we can't simplify it yet, because we might simplify
- % away type errors.
-
-unravel_unification_2(term__functor(LeftF, LeftAs, LeftC),
- term__functor(RightF, RightAs, RightC),
- Context, MainContext, SubContext,
- Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
- varset__new_var(!.VarSet, TmpVar, !:VarSet),
- unravel_unification(term__variable(TmpVar),
- term__functor(LeftF, LeftAs, LeftC),
- Context, MainContext, SubContext,
- Purity, Goal0, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- unravel_unification(term__variable(TmpVar),
- term__functor(RightF, RightAs, RightC),
- Context, MainContext, SubContext,
- Purity, Goal1, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- goal_info_init(GoalInfo),
- goal_to_conj_list(Goal0, ConjList0),
- goal_to_conj_list(Goal1, ConjList1),
- list__append(ConjList0, ConjList1, ConjList),
- conj_list_to_goal(ConjList, GoalInfo, Goal).
-
-:- pred parse_purity_annotation(term(T)::in, purity::out, term(T)::out) is det.
-
-parse_purity_annotation(Term0, Purity, Term) :-
- (
- Term0 = term__functor(term__atom(PurityName), [Term1], _),
- purity_name(Purity0, PurityName)
- ->
- Purity = Purity0,
- Term = Term1
- ;
- Purity = (pure),
- Term = Term0
- ).
-
-:- pred make_hlds__qualify_lambda_mode_list(list(mode)::in, list(mode)::out,
- prog_context::in, qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-make_hlds__qualify_lambda_mode_list(Modes0, Modes, Context, !QualInfo, !IO) :-
- % The modes in `.opt' files are already fully module qualified.
- ( !.QualInfo ^ import_status \= opt_imported ->
- qual_info_get_mq_info(!.QualInfo, MQInfo0),
- module_qual__qualify_lambda_mode_list(Modes0, Modes, Context,
- MQInfo0, MQInfo1, !IO),
- qual_info_set_mq_info(MQInfo1, !QualInfo)
- ;
- Modes = Modes0
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred check_expr_purity(purity::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
-
-check_expr_purity(Purity, Context, !ModuleInfo, !IO) :-
- ( Purity \= pure ->
- impure_unification_expr_error(Context, Purity, !IO),
- module_info_incr_errors(!ModuleInfo)
- ;
- true
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Parse a term of the form `Head :- Body', treating
- % a term not in that form as `Head :- true'.
-:- pred parse_rule_term(term__context::in, term(T)::in, term(T)::out,
- term(T)::out) is det.
-
-parse_rule_term(Context, RuleTerm, HeadTerm, GoalTerm) :-
- (
- RuleTerm = term__functor(term__atom(":-"), [HeadTerm0, GoalTerm0], _)
- ->
- HeadTerm = HeadTerm0,
- GoalTerm = GoalTerm0
- ;
- HeadTerm = RuleTerm,
- GoalTerm = term__functor(term__atom("true"), [], Context)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred build_lambda_expression(prog_var::in, purity::in, pred_or_func::in,
- lambda_eval_method::in, list(prog_term)::in, list(mode)::in,
- determinism::in, goal::in, prog_context::in, unify_main_context::in,
- unify_sub_contexts::in, hlds_goal::out,
- prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, io::di, io::uo) is det.
-
-build_lambda_expression(X, Purity, PredOrFunc, EvalMethod, Args0, Modes, Det,
- ParsedGoal, Context, MainContext, SubContext, Goal, !VarSet,
- !ModuleInfo, !QualInfo, !.SInfo, !IO) :-
- %
- % In the parse tree, the lambda arguments can be any terms.
- % But in the HLDS, they must be distinct variables. So we introduce
- % fresh variables for the lambda arguments, and add appropriate
- % unifications.
- %
- % For example, we convert from
- % X = (func(f(A, B), c) = D :- G)
- % to
- % X = (func(H1, H2) = H3 :-
- % some [A, B] (H1 = f(A, B), H2 = c, H3 = D).
- %
- % Note that the quantification is important here.
- % That's why we need to introduce the explicit `some [...]'.
- % Variables in the argument positions are lambda-quantified,
- % so when we move them to the body, we need to make them
- % explicitly existentially quantified, to avoid capturing
- % any variables of the same name that occur outside this scope.
- %
- % For predicates, all variables occuring in the lambda arguments
- % are locally quantified to the lambda goal.
- % For functions, we need to be careful because variables in
- % arguments should similarly be quantified, but variables in
- % the function return value term (and not in the arguments)
- % should *not* be locally quantified.
- %
-
- %
- % Create fresh variables, transform the goal to HLDS,
- % and add unifications with the fresh variables.
- % We use varset__new_vars rather than make_fresh_arg_vars,
- % since for functions we need to ensure that the variable
- % corresponding to the function result term is a new variable,
- % to avoid the function result term becoming lambda-quantified.
- %
- (
- illegal_state_var_func_result(PredOrFunc, Args0, StateVar)
- ->
- report_illegal_func_svar_result(Context, !.VarSet, StateVar, !IO),
- true_goal(Goal)
- ;
- lambda_args_contain_bang_state_var(Args0, StateVar)
- ->
- report_illegal_bang_svar_lambda_arg(Context, !.VarSet, StateVar, !IO),
- true_goal(Goal)
- ;
- prepare_for_lambda(!SInfo),
- substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO),
-
- list__length(Args, NumArgs),
- varset__new_vars(!.VarSet, NumArgs, LambdaVars, !:VarSet),
- map__init(Substitution),
- hlds_goal__true_goal(Head0),
- ArgContext = head(PredOrFunc, NumArgs),
-
- insert_arg_unifications(LambdaVars, Args, Context, ArgContext,
- Head0, Head, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
-
- transform_goal(ParsedGoal, Substitution,
- Body, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
-
- finish_head_and_body(Context, FinalSVarMap,
- Head, Body, HLDS_Goal0, !.SInfo),
-
- %
- % Now figure out which variables we need to
- % explicitly existentially quantify.
- %
- (
- PredOrFunc = predicate,
- QuantifiedArgs = Args
- ;
- PredOrFunc = function,
- pred_args_to_func_args(Args, QuantifiedArgs, _ReturnValTerm)
- ),
- term__vars_list(QuantifiedArgs, QuantifiedVars0),
- list__sort_and_remove_dups(QuantifiedVars0, QuantifiedVars),
-
- goal_info_init(Context, GoalInfo),
- HLDS_Goal = scope(exist_quant(QuantifiedVars), HLDS_Goal0) - GoalInfo,
-
- %
- % We set the lambda nonlocals here to anything that
- % could possibly be nonlocal. Quantification will
- % reduce this down to the proper set of nonlocal arguments.
- %
- goal_util__goal_vars(HLDS_Goal, LambdaGoalVars0),
- set__delete_list(LambdaGoalVars0, LambdaVars, LambdaGoalVars1),
- set__delete_list(LambdaGoalVars1, QuantifiedVars, LambdaGoalVars2),
- set__to_sorted_list(LambdaGoalVars2, LambdaNonLocals),
-
- make_atomic_unification(X,
- lambda_goal(Purity, PredOrFunc, EvalMethod, modes_are_ok,
- LambdaNonLocals, LambdaVars, Modes, Det, HLDS_Goal),
- Context, MainContext, SubContext, Goal, !QualInfo)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred construct_pred_or_func_call(pred_id::in, pred_or_func::in,
- sym_name::in, list(prog_var)::in, hlds_goal_info::in, hlds_goal::out,
- qual_info::in, qual_info::out) is det.
-
-construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args, GoalInfo, Goal,
- !QualInfo) :-
- do_construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args,
- GoalInfo, Goal),
- list__length(Args, Arity),
- adjust_func_arity(PredOrFunc, OrigArity, Arity),
- record_called_pred_or_func(PredOrFunc, SymName, OrigArity, !QualInfo).
-
-:- pred do_construct_pred_or_func_call(pred_id::in, pred_or_func::in,
- sym_name::in, list(prog_var)::in, hlds_goal_info::in, hlds_goal::out)
- is det.
-
-do_construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args,
- GoalInfo, Goal) :-
- (
- PredOrFunc = predicate,
- Goal = call(PredId, invalid_proc_id, Args, not_builtin, no, SymName)
- - GoalInfo
- ;
- PredOrFunc = function,
- pred_args_to_func_args(Args, FuncArgs, RetArg),
- list__length(FuncArgs, Arity),
- ConsId = cons(SymName, Arity),
- goal_info_get_context(GoalInfo, Context),
- hlds_goal__create_atomic_unification(RetArg,
- functor(ConsId, no, FuncArgs), Context,
- explicit, [], GoalExpr - _),
- Goal = GoalExpr - GoalInfo
- ).
-
-:- pred make_atomic_unification(prog_var::in, unify_rhs::in, prog_context::in,
- unify_main_context::in, unify_sub_contexts::in, hlds_goal::out,
- qual_info::in, qual_info::out) is det.
-
-make_atomic_unification(Var, Rhs, Context, MainContext, SubContext,
- Goal, !QualInfo) :-
- (
- Rhs = var(_)
- ;
- Rhs = lambda_goal(_, _, _, _, _, _, _, _, _)
- ;
- Rhs = functor(ConsId, _, _),
- record_used_functor(ConsId, !QualInfo)
- ),
- hlds_goal__create_atomic_unification(Var, Rhs, Context,
- MainContext, SubContext, Goal).
-
-%-----------------------------------------------------------------------------%
-
- % Process an explicit type qualification.
-:- pred process_type_qualification(prog_var::in, (type)::in, tvarset::in,
- prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-process_type_qualification(Var, Type0, VarSet, Context, !ModuleInfo,
- !QualInfo, !IO) :-
- !.QualInfo = qual_info(EqvMap, TVarSet0, TVarRenaming0,
- TVarNameMap0, VarTypes0, MQInfo0, Status, FoundError),
- ( Status = opt_imported ->
- % Types in `.opt' files should already be
- % fully module qualified.
- Type1 = Type0,
- MQInfo = MQInfo0
- ;
- module_qual__qualify_type_qualification(Type0, Type1,
- Context, MQInfo0, MQInfo, !IO)
- ),
-
- % Find any new type variables introduced by this type, and
- % add them to the var-name index and the variable renaming.
- term__vars(Type1, TVars),
- get_new_tvars(TVars, VarSet, TVarSet0, TVarSet1,
- TVarNameMap0, TVarNameMap, TVarRenaming0, TVarRenaming),
-
- % Apply the updated renaming to convert type variables in
- % the clause to type variables in the tvarset.
- term__apply_variable_renaming(Type1, TVarRenaming, Type2),
-
- % Expand equivalence types.
- % We don't need to record the expanded types for smart recompilation
- % because at the moment no recompilation.item_id can depend on a
- % clause item.
- RecordExpanded = no,
- equiv_type__replace_in_type(EqvMap, Type2, Type, _, TVarSet1, TVarSet,
- RecordExpanded, _),
- update_var_types(Var, Type, Context, VarTypes0, VarTypes, !IO),
- !:QualInfo = qual_info(EqvMap, TVarSet, TVarRenaming,
- TVarNameMap, VarTypes, MQInfo, Status, FoundError).
-
-:- pred update_var_types(prog_var::in, (type)::in, prog_context::in,
- vartypes::in, vartypes::out, io::di, io::uo) is det.
-
-update_var_types(Var, Type, Context, !VarTypes, !IO) :-
- ( map__search(!.VarTypes, Var, Type0) ->
- ( Type = Type0 ->
- true
- ;
- prog_out__write_context(Context, !IO),
- io__write_string("Error: explicit type qualification does\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" not match prior qualification.\n", !IO),
- io__set_exit_status(1, !IO)
- )
- ;
- map__det_insert(!.VarTypes, Var, Type, !:VarTypes)
- ).
-
- % Add new type variables for those introduced by a type qualification.
-:- pred get_new_tvars(list(tvar)::in, tvarset::in, tvarset::in, tvarset::out,
- tvar_name_map::in, tvar_name_map::out,
- map(tvar, tvar)::in, map(tvar, tvar)::out) is det.
-
-get_new_tvars([], _, !TVarSet, !TVarNameMap, !TVarRenaming).
-get_new_tvars([TVar | TVars], VarSet, !TVarSet, !TVarNameMap, !TVarRenaming) :-
- ( map__contains(!.TVarRenaming, TVar) ->
- true
- ;
- ( varset__search_name(VarSet, TVar, TVarName) ->
- ( map__search(!.TVarNameMap, TVarName, TVarSetVar) ->
- svmap__det_insert(TVar, TVarSetVar, !TVarRenaming)
- ;
- varset__new_var(!.TVarSet, NewTVar, !:TVarSet),
- varset__name_var(!.TVarSet, NewTVar, TVarName,
- !:TVarSet),
- svmap__det_insert(TVarName, NewTVar, !TVarNameMap),
- svmap__det_insert(TVar, NewTVar, !TVarRenaming)
- )
- ;
- varset__new_var(!.TVarSet, NewTVar, !:TVarSet),
- svmap__det_insert(TVar, NewTVar, !TVarRenaming)
- )
- ),
- get_new_tvars(TVars, VarSet, !TVarSet, !TVarNameMap, !TVarRenaming).
-
-%-----------------------------------------------------------------------------%
-
-% substitute_vars(Vars0, Subst, Vars)
-% apply substitiution `Subst' (which must only rename vars) to `Vars0',
-% and return the result in `Vars'.
-
-:- pred substitute_vars(list(var(T))::in, substitution(T)::in,
- list(var(T))::out) is det.
-
-substitute_vars(Vars0, Subst, Vars) :-
- Vars = list__map(substitute_var(Subst), Vars0).
-
-:- func substitute_var(substitution(T), var(T)) = var(T).
-
-substitute_var(Subst, Var0) = Var :-
- term__apply_substitution(term__variable(Var0), Subst, Term),
- ( Term = term__variable(Var1) ->
- Var = Var1
- ;
- error("substitute_var: invalid substitution")
- ).
-
-%-----------------------------------------------------------------------------%
-
- % get_rev_conj(Goal, Subst, RevConj0, RevConj) :
- % Goal is a tree of conjuncts. Flatten it into a list (applying Subst),
- % reverse it, append RevConj0, and return the result in RevConj.
-
-:- pred get_rev_conj(goal::in, prog_substitution::in, list(hlds_goal)::in,
- list(hlds_goal)::out, prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-get_rev_conj(Goal, Subst, RevConj0, RevConj, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO) :-
- ( Goal = (A,B) - _Context ->
- get_rev_conj(A, Subst, RevConj0, RevConj1,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- get_rev_conj(B, Subst, RevConj1, RevConj,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- transform_goal(Goal, Subst, Goal1, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- goal_to_conj_list(Goal1, ConjList),
- RevConj = list__reverse(ConjList) ++ RevConj0
- ).
-
- % get_rev_par_conj(Goal, Subst, RevParConj0, RevParConj) :
- % Goal is a tree of conjuncts. Flatten it into a list (applying Subst),
- % reverse it, append RevParConj0, and return the result in RevParConj.
-
-:- pred get_rev_par_conj(goal::in, prog_substitution::in, list(hlds_goal)::in,
- list(hlds_goal)::out, prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-get_rev_par_conj(Goal, Subst, RevParConj0, RevParConj, !VarSet, !ModuleInfo,
- !QualInfo, !SInfo, !IO) :-
- ( Goal = (A & B) - _Context ->
- get_rev_par_conj(A, Subst, RevParConj0, RevParConj1,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
- get_rev_par_conj(B, Subst, RevParConj1, RevParConj,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
- ;
- transform_goal(Goal, Subst, Goal1, !VarSet, !ModuleInfo, !QualInfo,
- !SInfo, !IO),
- goal_to_par_conj_list(Goal1, ParConjList),
- RevParConj = list__reverse(ParConjList) ++ RevParConj0
- ).
-
-% get_disj(Goal, Subst, Disj0, Disj) :
-% Goal is a tree of disjuncts. Flatten it into a list (applying Subst)
-% append Disj0, and return the result in Disj.
-
-:- pred get_disj(goal::in, prog_substitution::in, hlds_goal_svar_infos::in,
- hlds_goal_svar_infos::out, prog_varset::in, prog_varset::out,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- svar_info::in, io::di, io::uo) is det.
-
-get_disj(Goal, Subst, Disj0, Disj, !VarSet, !ModuleInfo, !QualInfo, SInfo,
- !IO) :-
- ( Goal = (A;B) - _Context ->
- get_disj(B, Subst, Disj0, Disj1, !VarSet, !ModuleInfo, !QualInfo,
- SInfo, !IO),
- get_disj(A, Subst, Disj1, Disj, !VarSet, !ModuleInfo, !QualInfo,
- SInfo, !IO)
- ;
- transform_goal(Goal, Subst, Goal1, !VarSet, !ModuleInfo, !QualInfo,
- SInfo, SInfo1, !IO),
- Disj = [{Goal1, SInfo1} | Disj0]
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Information used to process explicit type qualifications.
-:- type qual_info
- ---> qual_info(
- eqv_map :: eqv_map,
- % Used to expand equivalence types.
-
- tvarset :: tvarset,
- % All type variables for predicate.
-
- tvar_renaming :: map(tvar, tvar),
- % Map from clause type variable to
- % actual type variable in tvarset.
-
- tvar_name_map :: tvar_name_map,
- % Type variables in tvarset occurring
- % in the predicate's argument types
- % indexed by name.
-
- vartypes :: vartypes,
-
- mq_info :: mq_info,
- % Module qualification info.
-
- import_status :: import_status,
-
- found_syntax_error :: bool
- % Was there a syntax error in an Aditi
- % update.
- ).
-
-:- pred init_qual_info(mq_info::in, eqv_map::in, qual_info::out) is det.
-
-init_qual_info(MQInfo0, EqvMap, QualInfo) :-
- mq_info_set_need_qual_flag(may_be_unqualified, MQInfo0, MQInfo),
- varset__init(TVarSet),
- map__init(Renaming),
- map__init(Index),
- map__init(VarTypes),
- FoundSyntaxError = no,
- QualInfo = qual_info(EqvMap, TVarSet, Renaming, Index, VarTypes,
- MQInfo, local, FoundSyntaxError).
-
- % Update the qual_info when processing a new clause.
-:- pred update_qual_info(tvar_name_map::in, tvarset::in,
- map(prog_var, type)::in, import_status::in,
- qual_info::in, qual_info::out) is det.
-
-update_qual_info(TVarNameMap, TVarSet, VarTypes, Status, !QualInfo) :-
- !.QualInfo = qual_info(EqvMap, _TVarSet0, _Renaming0, _TVarNameMap0,
- _VarTypes0, MQInfo, _Status, _FoundError),
- % The renaming for one clause is useless in the others.
- map__init(Renaming),
- !:QualInfo = qual_info(EqvMap, TVarSet, Renaming, TVarNameMap,
- VarTypes, MQInfo, Status, no).
-
-:- pred qual_info_get_mq_info(qual_info::in, mq_info::out) is det.
-
-qual_info_get_mq_info(Info, Info ^ mq_info).
-
-:- pred qual_info_set_mq_info(mq_info::in, qual_info::in, qual_info::out)
- is det.
-
-qual_info_set_mq_info(MQInfo, Info, Info ^ mq_info := MQInfo).
-
-:- pred qual_info_get_var_types(qual_info::in, map(prog_var, type)::out)
- is det.
-
-qual_info_get_var_types(Info, Info ^ vartypes).
-
-:- pred qual_info_get_found_syntax_error(qual_info::in, bool::out) is det.
-
-qual_info_get_found_syntax_error(Info, Info ^ found_syntax_error).
-
-:- pred qual_info_set_found_syntax_error(bool::in,
- qual_info::in, qual_info::out) is det.
-
-qual_info_set_found_syntax_error(FoundError, Info,
- Info ^ found_syntax_error := FoundError).
-
-:- pred apply_to_recompilation_info(
- pred(recompilation_info, recompilation_info)::in(pred(in, out) is det),
- qual_info::in, qual_info::out) is det.
-
-apply_to_recompilation_info(Pred, !QualInfo) :-
- MQInfo0 = !.QualInfo ^ mq_info,
- mq_info_get_recompilation_info(MQInfo0, MaybeRecompInfo0),
- (
- MaybeRecompInfo0 = yes(RecompInfo0),
- Pred(RecompInfo0, RecompInfo),
- mq_info_set_recompilation_info(yes(RecompInfo), MQInfo0, MQInfo),
- !:QualInfo = !.QualInfo ^ mq_info := MQInfo
- ;
- MaybeRecompInfo0 = no
- ).
-
-set_module_recompilation_info(QualInfo, !ModuleInfo) :-
- mq_info_get_recompilation_info(QualInfo ^ mq_info, RecompInfo),
- module_info_set_maybe_recompilation_info(RecompInfo, !ModuleInfo).
-
-:- pred record_called_pred_or_func(pred_or_func::in, sym_name::in, arity::in,
- qual_info::in, qual_info::out) is det.
-
-record_called_pred_or_func(PredOrFunc, SymName, Arity, !QualInfo) :-
- Id = SymName - Arity,
- apply_to_recompilation_info(recompilation__record_used_item(
- pred_or_func_to_item_type(PredOrFunc), Id, Id), !QualInfo).
-
-:- pred record_used_functor(cons_id::in,
- qual_info::in, qual_info::out) is det.
-
-record_used_functor(ConsId, !QualInfo) :-
- ( ConsId = cons(SymName, Arity) ->
- Id = SymName - Arity,
- apply_to_recompilation_info(
- recompilation__record_used_item(functor, Id, Id), !QualInfo)
- ;
- true
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Predicates to write out the different warning and error messages.
-
-:- pred report_unexpected_decl(string::in, prog_context::in,
- io::di, io::uo) is det.
-
-report_unexpected_decl(Descr, Context, !IO) :-
- Pieces = [words("Error: unexpected or incorrect"),
- words("`" ++ Descr ++ "' declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred multiple_def_error(import_status::in, sym_name::in, int::in,
- string::in, prog_context::in, prog_context::in, bool::out,
- io::di, io::uo) is det.
-
-multiple_def_error(Status, Name, Arity, DefType, Context, OrigContext,
- FoundError, !IO) :-
- ( Status \= opt_imported ->
- Pieces = [words("Error:"),
- fixed(DefType), sym_name_and_arity(Name / Arity),
- words("multiply defined.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- OrigPieces = [words("Here is the previous definition of"),
- fixed(DefType), sym_name_and_arity(Name / Arity),
- suffix(".")],
- write_error_pieces(OrigContext, 0, OrigPieces, !IO),
- io__set_exit_status(1, !IO),
- FoundError = yes
- ;
- % We don't take care not to read the same declaration
- % from multiple sources with inter-module optimization
- % so ignore multiple definition errors in the items read
- % for inter-module optimization.
- FoundError = no
- ).
-
-:- pred undefined_pred_or_func_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
-
-undefined_pred_or_func_error(Name, Arity, Context, Description, !IO) :-
- % This used to say `preceding' instead of `corresponding.'
- % Which is more correct?
- Pieces = [words("Error:"), words(Description), words("for"),
- sym_name_and_arity(Name / Arity),
- words("without corresponding `pred' or `func' declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred pred_method_with_no_modes_error(pred_info::in, io::di, io::uo) is det.
-
-pred_method_with_no_modes_error(PredInfo, !IO) :-
- pred_info_context(PredInfo, Context),
- Module = pred_info_module(PredInfo),
- Name = pred_info_name(PredInfo),
- Arity = pred_info_orig_arity(PredInfo),
-
- Pieces = [words("Error: no mode declaration for type class method"),
- words("predicate"),
- sym_name_and_arity(qualified(Module, Name) / Arity), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
- % Similar to undeclared_mode_error, but gives less information.
- % XXX perhaps we should get rid of this, and change the callers to
- % instead call undeclared_mode_error.
-:- pred undefined_mode_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
-
-undefined_mode_error(Name, Arity, Context, Description, !IO) :-
- Pieces = [words("Error:"), words(Description), words("for"),
- sym_name_and_arity(Name / Arity),
- words("specifies non-existent mode.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
- % Similar to undefined_mode_error, but gives more information.
-:- pred undeclared_mode_error(list(mode)::in, prog_varset::in,
- pred_id::in, pred_info::in, module_info::in, prog_context::in,
- io::di, io::uo) is det.
-
-undeclared_mode_error(ModeList, VarSet, PredId, PredInfo, ModuleInfo,
- Context, !IO) :-
- prog_out__write_context(Context, !IO),
- io__write_string("In clause for ", !IO),
- hlds_out__write_pred_id(ModuleInfo, PredId, !IO),
- io__write_string(":\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(
- " error: mode annotation specifies undeclared mode\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" `", !IO),
- strip_builtin_qualifiers_from_mode_list(ModeList, StrippedModeList),
- PredOrFunc = pred_info_is_pred_or_func(PredInfo),
- Name = pred_info_name(PredInfo),
- MaybeDet = no,
- mercury_output_mode_subdecl(PredOrFunc, varset__coerce(VarSet),
- unqualified(Name), StrippedModeList, MaybeDet, Context, !IO),
- io__write_string("'\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" of ", !IO),
- hlds_out__write_pred_id(ModuleInfo, PredId, !IO),
- io__write_string(".\n", !IO),
- globals__io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- ProcIds = pred_info_all_procids(PredInfo),
- ( ProcIds = [] ->
- prog_out__write_context(Context, !IO),
- io__write_string(" (There are no declared modes for this ",
- !IO),
- write_pred_or_func(PredOrFunc, !IO),
- io__write_string(".)\n", !IO)
- ; VerboseErrors = yes ->
- io__write_string("\tThe declared modes for this ", !IO),
- write_pred_or_func(PredOrFunc, !IO),
- io__write_string(" are the following:\n", !IO),
- list__foldl(output_mode_decl_for_pred_info(PredInfo), ProcIds, !IO)
- ;
- true
- ).
-
-:- pred output_mode_decl_for_pred_info(pred_info::in, proc_id::in,
- io::di, io::uo) is det.
-
-output_mode_decl_for_pred_info(PredInfo, ProcId, !IO) :-
- io__write_string("\t\t:- mode ", !IO),
- output_mode_decl(ProcId, PredInfo, !IO),
- io__write_string(".\n", !IO).
-
-:- pred maybe_undefined_pred_error(sym_name::in, int::in, pred_or_func::in,
- import_status::in, bool::in, prog_context::in, string::in,
- io::di, io::uo) is det.
-
-% This is not considered an unconditional error anymore:
-% if there is no `:- pred' or `:- func' declaration,
-% and the declaration is local, and not a type class method,
-% and the `--infer-types' option was specified,
-% then we just add an implicit declaration for that predicate or
-% function, marking it as one whose type will be inferred.
-%
-% If this module is for a query generated by the Aditi dbsh
-% (--aditi-only is set), allow mode declarations for exported
-% predicates with no `:- pred' or `:- func' declaration.
-% The predicate will never be called from a compiled Mercury
-% procedure. The RL bytecode for the predicate will be called
-% directly using information from the generated
-% `<module>.derived_schema' file to work out the argument
-% types of the output relation.
-
-maybe_undefined_pred_error(Name, Arity, PredOrFunc, Status, IsClassMethod,
- Context, Description, !IO) :-
- status_defined_in_this_module(Status, DefinedInThisModule),
- status_is_exported(Status, IsExported),
- globals__io_lookup_bool_option(infer_types, InferTypes, !IO),
- globals__io_lookup_bool_option(aditi_only, AditiOnly, !IO),
- (
- (
- DefinedInThisModule = yes,
- IsExported = no,
- IsClassMethod = no,
- InferTypes = yes
- ;
- AditiOnly = yes
- )
- ->
- true
- ;
- Pieces = [words("Error:"), words(Description), words("for"),
- words(simple_call_id_to_string(PredOrFunc, Name, Arity)), nl,
- words("without preceding"),
- fixed("`" ++ pred_or_func_to_str(PredOrFunc) ++ "'"),
- words("declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO)
- ).
-
-:- pred undefined_type_class_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
-
-undefined_type_class_error(ClassName, Arity, Context, Description, !IO) :-
- Pieces = [words("Error:"), words(Description), words("for"),
- sym_name_and_arity(ClassName / Arity),
- words("without preceding typeclass declaration.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred unspecified_det_for_local(sym_name::in, arity::in, pred_or_func::in,
- prog_context::in, io::di, io::uo) is det.
-
-unspecified_det_for_local(Name, Arity, PredOrFunc, Context, !IO) :-
- Pieces = [words("Error: no determinism declaration for local"),
- words(simple_call_id_to_string(PredOrFunc, Name, Arity)),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- record_warning(!IO),
- globals__io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
- (
- VerboseErrors = yes,
- VerbosePieces = [words("(This is an error because"),
- words("you specified the `--no-infer-det' options."),
- words("Use the `--infer-det' option if you want the compiler"),
- words("to automatically infer the determinism"),
- words("of local predicates.)")],
- write_error_pieces(Context, 0, VerbosePieces, !IO)
- ;
- VerboseErrors = no
- ).
-
-:- pred unspecified_det_for_method(sym_name::in, arity::in, pred_or_func::in,
- prog_context::in, io::di, io::uo) is det.
-
-unspecified_det_for_method(Name, Arity, PredOrFunc, Context, !IO) :-
- Pieces = [words("Error: no determinism declaration"),
- words("for type class method"),
- pred_or_func(PredOrFunc),
- sym_name_and_arity(Name / Arity),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred unspecified_det_for_exported(sym_name::in, arity::in, pred_or_func::in,
- prog_context::in, io::di, io::uo) is det.
-
-unspecified_det_for_exported(Name, Arity, PredOrFunc, Context, !IO) :-
- Pieces = [words("Error: no determinism declaration for exported"),
- pred_or_func(PredOrFunc),
- sym_name_and_arity(Name / Arity),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred clause_for_imported_pred_error(sym_name::in, arity::in,
- pred_or_func::in, prog_context::in, io::di, io::uo) is det.
-
-clause_for_imported_pred_error(Name, Arity, PredOrFunc, Context, !IO) :-
- Pieces = [words("Error: clause for imported"),
- pred_or_func(PredOrFunc),
- sym_name_and_arity(Name / Arity),
- suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred unqualified_pred_error(sym_name::in, int::in, prog_context::in,
- io::di, io::uo) is det.
-
-unqualified_pred_error(PredName, Arity, Context, !IO) :-
- Pieces = [words("Internal error: the unqualified predicate name"),
- sym_name_and_arity(PredName / Arity),
- words("should have been qualified by prog_io.m.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred pragma_status_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
-
-pragma_status_error(Name, Arity, Context, PragmaName, !IO) :-
- Pieces = [words("Error: `:- pragma " ++ PragmaName ++ "'"),
- words("declaration for exported predicate or function"),
- sym_name_and_arity(Name / Arity),
- words("must also be exported.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-:- pred pragma_conflict_error(sym_name::in, int::in, prog_context::in,
- string::in, io::di, io::uo) is det.
-
-pragma_conflict_error(Name, Arity, Context, PragmaName, !IO) :-
- Pieces = [words("Error: `:- pragma " ++ PragmaName ++ "'"),
- words("declaration conflicts with previous pragma for"),
- sym_name_and_arity(Name / Arity), suffix(".")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-%-----------------------------------------------------------------------------%
-%
-% module_add_pragma_fact_table(PredName, Arity, FileName,
-% Status, Context, Module0, Module, Info0, Info)
-%
-% Add a `pragma fact_table' declaration to the HLDS. This predicate calls the
-% fact table compiler (fact_table_compile_facts) to create a separate `.o' file
-% for the fact_table and then creates separate pieces of `pragma c_code' to
-% access the table in each mode of the fact table predicate.
-
-:- pred module_add_pragma_fact_table(sym_name::in, arity::in, string::in,
- import_status::in, prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-module_add_pragma_fact_table(Pred, Arity, FileName, Status, Context,
- !ModuleInfo, !QualInfo, !IO) :-
- module_info_get_predicate_table(!.ModuleInfo, PredicateTable),
- (
- predicate_table_search_sym_arity(PredicateTable, is_fully_qualified,
- Pred, Arity, PredIDs0),
- PredIDs0 = [PredID | PredIDs1]
- ->
- (
- PredIDs1 = [], % only one predicate found
- module_info_pred_info(!.ModuleInfo, PredID, PredInfo0),
-
- % compile the fact table into a separate
- % .o file
- fact_table_compile_facts(Pred, Arity, FileName,
- PredInfo0, PredInfo, Context, !.ModuleInfo,
- C_HeaderCode, PrimaryProcID, !IO),
-
- module_info_set_pred_info(PredID, PredInfo, !ModuleInfo),
- pred_info_procedures(PredInfo, ProcTable),
- pred_info_arg_types(PredInfo, ArgTypes),
- ProcIDs = pred_info_procids(PredInfo),
- PredOrFunc = pred_info_is_pred_or_func(PredInfo),
- adjust_func_arity(PredOrFunc, Arity, NumArgs),
-
- % create foreign_decls to declare
- % extern variables
- module_add_foreign_decl(c, foreign_decl_is_local,
- C_HeaderCode, Context, !ModuleInfo),
-
- module_add_fact_table_file(FileName, !ModuleInfo),
-
- io__get_exit_status(ExitStatus, !IO),
- ( ExitStatus = 1 ->
- true
- ;
- % create foreign_procs to access the table
- % in each mode
- module_add_fact_table_procedures(ProcIDs,
- PrimaryProcID, ProcTable, Pred,
- PredOrFunc, NumArgs, ArgTypes, Status,
- Context, !ModuleInfo, !QualInfo, !IO)
- )
- ;
- PredIDs1 = [_ | _], % >1 predicate found
- io__set_exit_status(1, !IO),
- prog_out__write_context(Context, !IO),
- io__write_string("In pragma fact_table for `", !IO),
- prog_out__write_sym_name_and_arity(Pred/Arity, !IO),
- io__write_string("':\n", !IO),
- prog_out__write_context(Context, !IO),
- io__write_string(" error: " ++
- "ambiguous predicate/function name.\n", !IO)
- )
- ;
- undefined_pred_or_func_error(Pred, Arity, Context,
- "`:- pragma fact_table' declaration", !IO)
- ).
-
- % Add a `pragma c_code' for each mode of the fact table lookup to the
- % HLDS.
- % `pragma fact_table's are represented in the HLDS by a
- % `pragma c_code' for each mode of the predicate.
-
-:- pred module_add_fact_table_procedures(list(proc_id)::in, proc_id::in,
- proc_table::in, sym_name::in, pred_or_func::in, arity::in,
- list(type)::in, import_status::in, prog_context::in,
- module_info::in, module_info::out, qual_info::in, qual_info::out,
- io::di, io::uo) is det.
-
-module_add_fact_table_procedures([],_,_,_,_,_,_,_,_, !ModuleInfo, !QualInfo,
- !IO).
-module_add_fact_table_procedures([ProcID | ProcIDs], PrimaryProcID, ProcTable,
- SymName, PredOrFunc, Arity, ArgTypes, Status, Context,
- !ModuleInfo, !QualInfo, !IO) :-
- module_add_fact_table_proc(ProcID, PrimaryProcID, ProcTable, SymName,
- PredOrFunc, Arity, ArgTypes, Status, Context,
- !ModuleInfo, !QualInfo, !IO),
- module_add_fact_table_procedures(ProcIDs, PrimaryProcID, ProcTable,
- SymName, PredOrFunc, Arity, ArgTypes, Status, Context,
- !ModuleInfo, !QualInfo, !IO).
-
-:- pred module_add_fact_table_proc(proc_id::in, proc_id::in, proc_table::in,
- sym_name::in, pred_or_func::in, arity::in, list(type)::in,
- import_status::in, prog_context::in, module_info::in, module_info::out,
- qual_info::in, qual_info::out, io::di, io::uo) is det.
-
-module_add_fact_table_proc(ProcID, PrimaryProcID, ProcTable, SymName,
- PredOrFunc, Arity, ArgTypes, Status, Context, !ModuleInfo, !QualInfo,
- !IO) :-
- map__lookup(ProcTable, ProcID, ProcInfo),
- varset__init(VarSet0),
- varset__new_vars(VarSet0, Arity, Vars, VarSet),
- proc_info_argmodes(ProcInfo, Modes),
- fact_table_pragma_vars(Vars, Modes, VarSet, PragmaVars),
- fact_table_generate_c_code(SymName, PragmaVars, ProcID, PrimaryProcID,
- ProcInfo, ArgTypes, !.ModuleInfo, C_ProcCode, C_ExtraCode, !IO),
-
- % XXX this should be modified to use nondet pragma c_code.
- Attrs0 = default_attributes(c),
- set_may_call_mercury(will_not_call_mercury, Attrs0, Attrs1),
- set_thread_safe(thread_safe, Attrs1, Attrs2),
- % fact tables procedures should be considered pure
- set_purity(pure, Attrs2, Attrs),
- module_add_pragma_foreign_proc(Attrs, SymName, PredOrFunc, PragmaVars,
- VarSet, ordinary(C_ProcCode, no), Status, Context,
- !ModuleInfo, !QualInfo, !IO),
- ( C_ExtraCode = "" ->
- true
- ;
- module_add_foreign_body_code(c, C_ExtraCode, Context, !ModuleInfo)
- ),
- %
- % The C code for fact tables includes C labels;
- % we cannot inline this code, because if we try,
- % the result may be duplicate labels in the generated code.
- % So we must disable inlining for fact_table procedures.
- %
- add_pred_marker("fact_table", SymName, Arity, Status, Context,
- no_inline, [], !ModuleInfo, !IO).
-
- % Create a list(pragma_var) that looks like the ones that are created
- % for pragma c_code in prog_io.m.
- % This is required by module_add_pragma_c_code to add the C code for
- % the procedure to the HLDS.
-
-:- pred fact_table_pragma_vars(list(prog_var)::in, list(mode)::in,
- prog_varset::in, list(pragma_var)::out) is det.
-
-fact_table_pragma_vars(Vars0, Modes0, VarSet, PragmaVars0) :-
- (
- Vars0 = [Var | VarsTail],
- Modes0 = [Mode | ModesTail]
- ->
- varset__lookup_name(VarSet, Var, Name),
- PragmaVar = pragma_var(Var, Name, Mode),
- fact_table_pragma_vars(VarsTail, ModesTail, VarSet, PragmaVarsTail),
- PragmaVars0 = [PragmaVar | PragmaVarsTail]
- ;
- PragmaVars0 = []
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% promise ex error checking
-%
-% The following predicates are used to perform extra error checking specific
-% to promise ex declarations (see notes/promise_ex.html). Currently, the
-% following checks are performed:
-% * check for universally quantified variables
-% * check if universal quantification is placed in the wrong
-% position (i.e. after the `promise_exclusive' rather than
-% before it)
-% * check that its goal is a disjunction and that each arm of the
-% disjunction has at most one call, and otherwise has only unifications
-
- % perform above checks on a promise ex declaration
-:- pred check_promise_ex_decl(prog_vars::in, promise_type::in, goal::in,
- prog_context::in, io::di, io::uo) is det.
-
-check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !IO) :-
- % are universally quantified variables present?
- (
- UnivVars = [],
- promise_ex_error(PromiseType, Context,
- "declaration has no universally quantified variables", !IO)
- ;
- UnivVars = [_ | _]
- ),
- check_promise_ex_goal(PromiseType, Goal, !IO).
-
- % check for misplaced universal quantification, otherwise find the
- % disjunction, flatten it out into list form and perform further
- % checks
-:- pred check_promise_ex_goal(promise_type::in, goal::in, io::di, io::uo)
- is det.
-
-check_promise_ex_goal(PromiseType, GoalExpr - Context, !IO) :-
- ( GoalExpr = some(_, Goal) ->
- check_promise_ex_goal(PromiseType, Goal, !IO)
- ; GoalExpr = ( _ ; _ ) ->
- flatten_to_disj_list(GoalExpr - Context, DisjList),
- list__map(flatten_to_conj_list, DisjList, DisjConjList),
- check_disjunction(PromiseType, DisjConjList, !IO)
- ; GoalExpr = all(_UnivVars, Goal) ->
- promise_ex_error(PromiseType, Context,
- "universal quantification should come before " ++
- "the declaration name", !IO),
- check_promise_ex_goal(PromiseType, Goal, !IO)
- ;
- promise_ex_error(PromiseType, Context,
- "goal in declaration is not a disjunction", !IO)
- ).
-
- % turns the goal of a promise ex declaration into a list of goals,
- % where each goal is an arm of the disjunction
-:- pred flatten_to_disj_list(goal::in, goals::out) is det.
-
-flatten_to_disj_list(GoalExpr - Context, GoalList) :-
- ( GoalExpr = ( GoalA ; GoalB ) ->
- flatten_to_disj_list(GoalA, GoalListA),
- flatten_to_disj_list(GoalB, GoalListB),
- GoalList = GoalListA ++ GoalListB
- ;
- GoalList = [GoalExpr - Context]
- ).
-
- % takes a goal representing an arm of a disjunction and turn it into
- % a list of conjunct goals
-:- pred flatten_to_conj_list(goal::in, goals::out) is det.
-
-flatten_to_conj_list(GoalExpr - Context, GoalList) :-
- ( GoalExpr = ( GoalA , GoalB ) ->
- flatten_to_conj_list(GoalA, GoalListA),
- flatten_to_conj_list(GoalB, GoalListB),
- GoalList = GoalListA ++ GoalListB
- ;
- GoalList = [GoalExpr - Context]
- ).
-
- % taking a list of arms of the disjunction, check each arm
- % individually
-:- pred check_disjunction(promise_type::in, list(goals)::in, io::di, io::uo)
- is det.
-
-check_disjunction(PromiseType, DisjConjList, !IO) :-
- (
- DisjConjList = []
- ;
- DisjConjList = [ConjList | Rest],
- check_disj_arm(PromiseType, ConjList, no, !IO),
- check_disjunction(PromiseType, Rest, !IO)
- ).
-
- % only one goal in an arm is allowed to be a call, the rest must be
- % unifications
-:- pred check_disj_arm(promise_type::in, goals::in, bool::in,
- io::di, io::uo) is det.
-
-check_disj_arm(PromiseType, Goals, CallUsed, !IO) :-
- (
- Goals = []
- ;
- Goals = [GoalExpr - Context | Rest],
- ( GoalExpr = unify(_, _, _) ->
- check_disj_arm(PromiseType, Rest, CallUsed, !IO)
- ; GoalExpr = some(_, Goal) ->
- check_disj_arm(PromiseType, [Goal | Rest], CallUsed, !IO)
- ; GoalExpr = call(_, _, _) ->
- (
- CallUsed = no
- ;
- CallUsed = yes,
- promise_ex_error(PromiseType, Context,
- "disjunct contains more than one call", !IO)
- ),
- check_disj_arm(PromiseType, Rest, yes, !IO)
- ;
- promise_ex_error(PromiseType, Context,
- "disjunct is not a call or unification", !IO),
- check_disj_arm(PromiseType, Rest, CallUsed, !IO)
- )
- ).
-
- % called for any error in the above checks
-:- pred promise_ex_error(promise_type::in, prog_context::in, string::in,
- io::di, io::uo) is det.
-
-promise_ex_error(PromiseType, Context, Message, !IO) :-
- ErrorPieces = [
- words("In"),
- fixed("`" ++ prog_out__promise_to_string(PromiseType) ++ "'"),
- words("declaration:"),
- nl,
- words("error:"),
- words(Message)
- ],
- error_util__write_error_pieces(Context, 0, ErrorPieces, !IO).
-
-:- func this_file = string.
-
-this_file = "make_hlds.m".
-
-%-----------------------------------------------------------------------------%
-
- % This synonym improves code legibility.
- %
-:- type svar == prog_var.
-
-:- type svars == list(svar).
-
- % A set of state variables.
- %
-:- type svar_set == set(svar).
-
- % A mapping from state variables to logical variables.
- %
-:- type svar_map == map(svar, prog_var).
-
- % This controls how state variables are dealt with.
- %
-:- type svar_ctxt
- ---> in_head
- % In the head of a clause or lambda.
-
- ; in_body
- % In the body of a clause or lambda.
-
- ; in_atom(
- % In the context of an atomic goal at the level of the
- % source code.
- had_colon_reference :: svar_set,
- % The set of state variables X that
- % have been referenced as !:X in the
- % parameters of the atomic goal.
- parent_svar_info :: svar_info
- % The parent svar_info, used to keep
- % track of nesting in subterms of
- % an atomic formula.
- ).
-
-:- type svar_info
- ---> svar_info(
- ctxt :: svar_ctxt,
-
- num :: int,
- % This is used to number state variables and
- % is incremented for each source-level
- % conjunct.
-
- external_dot :: svar_map,
- % The "read only" state variables in
- % scope (e.g. external state variables
- % visible from within a lambda body or
- % condition of an if-then-else expression.)
-
- dot :: svar_map,
- colon :: svar_map
- % The "read/write" state variables in scope.
- ).
-
- % When collecting the arms of a disjunction we also need to
- % collect the resulting svar_infos.
- %
-:- type hlds_goal_svar_info == {hlds_goal, svar_info}.
-
-:- type hlds_goal_svar_infos == list(hlds_goal_svar_info).
-
- % Create a new svar_info set up to start processing a clause head.
- %
-:- func new_svar_info = svar_info.
-
-new_svar_info = svar_info(in_head, 0, map__init, map__init, map__init).
-
-%-----------------------------------------------------------------------------%
-
- % Obtain the mapping for a !.X state variable reference and
- % update the svar_info.
- %
- % If we are processing the head of a clause or lambda, we
- % incrementally accumulate the mappings.
- %
- % Otherwise, the mapping must already be present for a local
- % or `external' state variable (i.e. one that may be visible,
- % but not updatable, in the current context.)
- %
- % Note that if !.X does not appear in the head then !:X must
- % appear before !.X can be referenced.
- %
-:- pred dot(prog_context::in, svar::in, prog_var::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
-
-dot(Context, StateVar, Var, !VarSet, !SInfo, !IO) :-
- ( !.SInfo ^ ctxt = in_head ->
- ( !.SInfo ^ dot ^ elem(StateVar) = Var0 ->
- Var = Var0
- ;
- new_dot_state_var(StateVar, Var, !VarSet, !SInfo)
- )
- ;
- ( !.SInfo ^ dot ^ elem(StateVar) = Var0 ->
- Var = Var0
- ; !.SInfo ^ external_dot ^ elem(StateVar) = Var0 ->
- Var = Var0
- ; !.SInfo `has_svar_colon_mapping_for` StateVar ->
- new_dot_state_var(StateVar, Var, !VarSet, !SInfo),
- report_unitialized_state_var(Context, !.VarSet, StateVar, !IO)
- ;
- Var = StateVar,
- report_non_visible_state_var(".", Context, !.VarSet, StateVar, !IO)
- )
- ).
-
-:- pred svar_info `has_svar_colon_mapping_for` svar.
-:- mode in `has_svar_colon_mapping_for` in is semidet.
-
-SInfo `has_svar_colon_mapping_for` StateVar :-
- SInfo ^ colon `contains` StateVar.
-
-SInfo `has_svar_colon_mapping_for` StateVar :-
- SInfo ^ ctxt = in_atom(_, ParentSInfo),
- ParentSInfo `has_svar_colon_mapping_for` StateVar.
-
-%-----------------------------------------------------------------------------%
-
- % Obtain the mapping for a !:X state variable reference.
- %
- % If we are processing the head of a clause or lambda, we
- % incrementally accumulate the mappings.
- %
- % Otherwise, the mapping must already be present for a local
- % state variable (`externally' visible state variables cannot
- % be updated.)
- %
- % We also keep track of which state variables have been updated
- % in an atomic context.
- %
-:- pred colon(prog_context::in, svar::in, prog_var::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
-
-colon(Context, StateVar, Var, !VarSet, !SInfo, !IO) :-
- ( !.SInfo ^ ctxt = in_head ->
- ( !.SInfo ^ colon ^ elem(StateVar) = Var0 ->
- Var = Var0
- ;
- new_final_state_var(StateVar, Var, !VarSet, !SInfo)
- )
- ;
- ( !.SInfo ^ colon ^ elem(StateVar) = Var0 ->
- Var = Var0,
- !:SInfo = !.SInfo `with_updated_svar` StateVar
- ;
- Var = StateVar,
- % Set up a dummy mapping: there's no point
- % in mentioning this error twice.
- !:SInfo = ( !.SInfo ^ colon ^ elem(StateVar) := Var ),
- ( !.SInfo ^ external_dot `contains` StateVar ->
- PError = report_illegal_state_var_update
- ;
- PError = report_non_visible_state_var(":")
- ),
- PError(Context, !.VarSet, StateVar, !IO)
- )
- ).
-
-:- func svar_info `with_updated_svar` svar = svar_info.
-
-SInfo `with_updated_svar` StateVar =
- ( SInfo ^ ctxt = in_atom(UpdatedStateVars, ParentSInfo) ->
- SInfo ^ ctxt := in_atom(set__insert(UpdatedStateVars, StateVar),
- ParentSInfo)
- ;
- SInfo
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Construct the initial and final mappings for a state variable.
- %
-:- pred new_local_state_var(svar::in, prog_var::out, prog_var::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
- is det.
-
-new_local_state_var(StateVar, VarD, VarC, !VarSet, !SInfo) :-
- new_dot_state_var(StateVar, VarD, !VarSet, !SInfo),
- new_final_state_var(StateVar, VarC, !VarSet, !SInfo).
-
- % Construct the initial and final mappings for a state variable.
- %
-:- pred new_dot_state_var(svar::in, prog_var::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
- is det.
-
-new_dot_state_var(StateVar, VarD, !VarSet, !SInfo) :-
- N = !.SInfo ^ num,
- Name = varset__lookup_name(!.VarSet, StateVar),
- NameD = string__format("STATE_VARIABLE_%s_%d", [s(Name), i(N)]),
- varset__new_named_var(!.VarSet, NameD, VarD, !:VarSet),
- !:SInfo = ( !.SInfo ^ dot ^ elem(StateVar) := VarD ).
-
-:- pred new_colon_state_var(svar::in, prog_var::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
- is det.
-
-new_colon_state_var(StateVar, VarC, !VarSet, !SInfo) :-
- N = !.SInfo ^ num,
- Name = varset__lookup_name(!.VarSet, StateVar),
- NameC = string__format("STATE_VARIABLE_%s_%d", [s(Name), i(N)]),
- varset__new_named_var(!.VarSet, NameC, VarC, !:VarSet),
- !:SInfo = ( !.SInfo ^ colon ^ elem(StateVar) := VarC ).
-
-:- pred new_final_state_var(svar::in, prog_var::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
- is det.
-
-new_final_state_var(StateVar, VarC, !VarSet, !SInfo) :-
- Name = varset__lookup_name(!.VarSet, StateVar),
- NameC = string__format("STATE_VARIABLE_%s", [s(Name)]),
- varset__new_named_var(!.VarSet, NameC, VarC, !:VarSet),
- !:SInfo = ( !.SInfo ^ colon ^ elem(StateVar) := VarC ).
-
-%-----------------------------------------------------------------------------%
-
- % Prepare for the head of a new clause.
- %
-:- pred prepare_for_head(svar_info::out) is det.
-
-prepare_for_head(new_svar_info).
-
-%-----------------------------------------------------------------------------%
-
- % We need to make the current !.Xs external
- % ("read-only") and clear the !.Xs and !:Xs.
- %
- % While processing the head, any state variables therein are
- % implicitly scoped over the body and have !. and !: mappings
- % set up.
- %
-:- pred prepare_for_lambda(svar_info::in, svar_info::out) is det.
-
-prepare_for_lambda(!SInfo) :-
- !:SInfo = ( new_svar_info ^ external_dot := !.SInfo ^ dot ).
-
-%-----------------------------------------------------------------------------%
-
- % Having processed the head of a clause, prepare for the first
- % (source-level) atomic conjunct. We return the final !:
- % mappings identified while processing the head.
- %
-:- pred prepare_for_body(svar_map::out, prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out) is det.
-
-prepare_for_body(FinalMap, !VarSet, !SInfo) :-
- FinalMap = !.SInfo ^ colon,
- N = !.SInfo ^ num + 1,
- StateVars = list__merge_and_remove_dups(map__keys(!.SInfo ^ colon),
- map__keys(!.SInfo ^ dot)),
- next_svar_mappings(N, StateVars, !VarSet, Colon),
- !:SInfo = !.SInfo ^ ctxt := in_body,
- !:SInfo = !.SInfo ^ num := N,
- !:SInfo = !.SInfo ^ colon := Colon.
-
-%-----------------------------------------------------------------------------%
-
- % We have to conjoin the head and body and add unifiers to tie up all
- % the final values of the state variables to the head variables.
- %
-:- pred finish_head_and_body(prog_context::in, svar_map::in,
- hlds_goal::in, hlds_goal::in, hlds_goal::out, svar_info::in) is det.
-
-finish_head_and_body(Context, FinalSVarMap, Head, Body, Goal, SInfo) :-
- goal_info_init(Context, GoalInfo),
- goal_to_conj_list(Head, HeadGoals),
- goal_to_conj_list(Body, BodyGoals),
- Unifiers = svar_unifiers(yes(dont_warn_singleton), Context, FinalSVarMap,
- SInfo ^ dot),
- conj_list_to_goal(HeadGoals ++ BodyGoals ++ Unifiers, GoalInfo, Goal).
-
-:- func svar_unifiers(maybe(goal_feature), prog_context, svar_map, svar_map)
- = hlds_goals.
-
-svar_unifiers(MaybeFeature, Context, LHSMap, RHSMap) =
- map__foldl(add_svar_unifier(MaybeFeature, RHSMap, Context), LHSMap, []).
-
-:- func add_svar_unifier(maybe(goal_feature), svar_map, prog_context,
- svar, prog_var, hlds_goals) = hlds_goals.
-
-add_svar_unifier(MaybeFeature, RHSMap, Context, StateVar, Var, Unifiers0)
- = Unifiers :-
- ( RHSVar = RHSMap ^ elem(StateVar) ->
- Unifier = svar_unification(MaybeFeature, Context, Var, RHSVar),
- Unifiers = [Unifier | Unifiers0]
- ;
- Unifiers = Unifiers0
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- func svar_unification(maybe(goal_feature), prog_context, prog_var, prog_var)
- = hlds_goal.
-
-svar_unification(MaybeFeature, Context, SVar, Var) = Unification :-
- hlds_goal__create_atomic_unification(SVar, var(Var), Context,
- implicit("state variable"), [], Unification0),
- (
- MaybeFeature = no,
- Unification = Unification0
- ;
- MaybeFeature = yes(Feature),
- goal_add_feature(Unification0, Feature, Unification)
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Add some local state variables.
- %
-:- pred prepare_for_local_state_vars(svars::in,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
-
-prepare_for_local_state_vars(StateVars, !VarSet, !SInfo) :-
- list__foldl2(add_new_local_state_var, StateVars, !VarSet, !SInfo).
-
-:- pred add_new_local_state_var(svar::in,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
-
-add_new_local_state_var(StateVar, !VarSet, !SInfo) :-
- new_colon_state_var(StateVar, _, !VarSet, !SInfo).
-
-%-----------------------------------------------------------------------------%
-
- % Remove some local state variables.
- %
-:- pred finish_local_state_vars(svars::in, prog_vars::out,
- svar_info::in, svar_info::in, svar_info::out) is det.
-
-finish_local_state_vars(StateVars, Vars, SInfoBefore, !SInfo) :-
- InitDot = !.SInfo ^ dot,
- InitColon = !.SInfo ^ colon,
- Dots = svar_mappings(InitDot, StateVars),
- Colons = svar_mappings(InitColon, StateVars),
- Vars = list__sort_and_remove_dups(Dots ++ Colons),
- !:SInfo = !.SInfo ^ dot :=
- del_locals(StateVars, SInfoBefore ^ dot, InitDot),
- !:SInfo = !.SInfo ^ colon :=
- del_locals(StateVars, SInfoBefore ^ colon, InitColon).
-
-:- func svar_mappings(svar_map, svars) = svars.
-
-svar_mappings(_, []) = [].
-svar_mappings(Map, [StateVar | StateVars]) =
- ( Map ^ elem(StateVar) = Var ->
- [Var | svar_mappings(Map, StateVars)]
- ;
- svar_mappings(Map, StateVars)
- ).
-
-:- func del_locals(svars, svar_map, svar_map) = svar_map.
-
-del_locals(StateVars, MapBefore, Map) =
- list__foldl(
- func(K, M) =
- ( if MapBefore ^ elem(K) = V
- then M ^ elem(K) := V
- else map__delete(M, K)
- ),
- StateVars,
- Map
- ).
-
-%-----------------------------------------------------------------------------%
-
- % We have to add unifiers to the Then and Else arms of an
- % if-then-else to make sure all the state variables match up.
- %
- % More to the point, we have to add unifiers to the Then arm
- % for any new state variable mappings produced in the condition.
- %
- % We construct new mappings for the state variables and then
- % add unifiers.
- %
-:- pred finish_if_then_else(prog_context::in, hlds_goal::in, hlds_goal::out,
- hlds_goal::in, hlds_goal::out, svar_info::in,
- svar_info::in, svar_info::in, svar_info::in, svar_info::out,
- prog_varset::in, prog_varset::out) is det.
-
-finish_if_then_else(Context, Then0, Then, Else0, Else,
- SInfo0, SInfoC, SInfoT0, SInfoE, SInfo, !VarSet) :-
-
- % Add unifiers to the Then arm for state variables that
- % acquired new mappings in the condition, but not in the
- % Them arm itself. This is because the new mappings
- % appear only in a negated context.
- %
- StateVars = list__merge_and_remove_dups(map__keys(SInfoT0 ^ dot),
- map__keys(SInfoE ^ dot)),
- Then0 = _ - GoalInfo,
- goal_to_conj_list(Then0, Thens0),
- add_then_arm_specific_unifiers(Context, StateVars,
- SInfo0, SInfoC, SInfoT0, SInfoT, Thens0, Thens, !VarSet),
- conj_list_to_goal(Thens, GoalInfo, Then1),
-
- % Calculate the svar_info with the highest numbered
- % mappings from each arm.
- %
- DisjSInfos = [{Then1, SInfoT}, {Else0, SInfoE}],
- SInfo = reconciled_disj_svar_info(!.VarSet, DisjSInfos),
-
- % Add unifiers to each arm to ensure they both construct
- % the same final state variable mappings.
- %
- Then = add_disj_unifiers(Context, SInfo, StateVars,
- {Then1, SInfoT}),
- Else = add_disj_unifiers(Context, SInfo, StateVars,
- {Else0, SInfoE}).
-
- % If a new mapping was produced for state variable X in the
- % condition-goal (i.e. the condition refers to !:X), but not
- % in the then-goal, then we have to add a new unifier !:X = !.X
- % to the then-goal because the new mapping was created in a
- % negated context.
- %
-:- pred add_then_arm_specific_unifiers(prog_context::in, svars::in,
- svar_info::in, svar_info::in, svar_info::in, svar_info::out,
- hlds_goals::in, hlds_goals::out, prog_varset::in, prog_varset::out) is det.
-
-add_then_arm_specific_unifiers(_, [], _, _, SInfoT, SInfoT,
- Thens, Thens, VarSet, VarSet).
-
-add_then_arm_specific_unifiers(Context, [StateVar | StateVars],
- SInfo0, SInfoC, !SInfoT, !Thens, !VarSet) :-
- ( % the condition refers to !:X, but the then-goal doesn't
- SInfoC ^ dot ^ elem(StateVar) \= SInfo0 ^ dot ^ elem(StateVar),
- !.SInfoT ^ dot ^ elem(StateVar) = SInfoC ^ dot ^ elem(StateVar)
- ->
- % add a new unifier !:X = !.X
- Dot0 = !.SInfoT ^ dot ^ det_elem(StateVar),
- new_colon_state_var(StateVar, Dot, !VarSet, !SInfoT),
- !:Thens = [svar_unification(yes(dont_warn_singleton), Context,
- Dot, Dot0) | !.Thens],
- prepare_for_next_conjunct(set__make_singleton_set(StateVar),
- !VarSet, !SInfoT)
- ;
- true
- ),
- add_then_arm_specific_unifiers(Context, StateVars,
- SInfo0, SInfoC, !SInfoT, !Thens, !VarSet).
-
-%-----------------------------------------------------------------------------%
-
-:- pred next_svar_mappings(int::in, svars::in,
- prog_varset::in, prog_varset::out, svar_map::out) is det.
-
-next_svar_mappings(N, StateVars, VarSet0, VarSet, Map) :-
- next_svar_mappings_2(N, StateVars, VarSet0, VarSet, map__init, Map).
-
-:- pred next_svar_mappings_2(int::in, svars::in,
- prog_varset::in, prog_varset::out, svar_map::in, svar_map::out) is det.
-
-next_svar_mappings_2(_, [], !VarSet, !Map).
-next_svar_mappings_2(N, [StateVar | StateVars], !VarSet, !Map) :-
- next_svar_mapping(N, StateVar, _, !VarSet, !Map),
- next_svar_mappings_2(N, StateVars, !VarSet, !Map).
-
-%-----------------------------------------------------------------------------%
-
- % We assume that a negation updates all state variables in scope,
- % so we construct new mappings for the state variables and then
- % add unifiers from their pre-negated goal mappings.
- %
-:- pred finish_negation(svar_info::in, svar_info::in, svar_info::out) is det.
-
-finish_negation(SInfoBefore, SInfoNeg, SInfo) :-
- SInfo = (( SInfoBefore ^ num := SInfoNeg ^ num )
- ^ colon := SInfoNeg ^ colon ).
-
-%-----------------------------------------------------------------------------%
-
- % We have to make sure that all arms of a disjunction produce the
- % same state variable bindings by adding unifiers as necessary.
- %
-:- pred finish_disjunction(prog_context::in, prog_varset::in,
- hlds_goal_svar_infos::in, hlds_goals::out, svar_info::out) is det.
-
-finish_disjunction(Context, VarSet, DisjSInfos, Disjs, SInfo) :-
- SInfo = reconciled_disj_svar_info(VarSet, DisjSInfos),
- StateVars = map__keys(SInfo ^ dot),
- Disjs = list__map( add_disj_unifiers(Context, SInfo, StateVars),
- DisjSInfos).
-
- % Each arm of a disjunction may have a different mapping for
- % !.X and/or !:X. The reconciled svar_info for the disjunction
- % takes the highest numbered mapping for each disjunct (each
- % state variable mapping for !.X or !:X will have a name of
- % the form `STATE_VARIABLE_X_n' for some number `n'.)
- %
-:- func reconciled_disj_svar_info(prog_varset, hlds_goal_svar_infos) =
- svar_info.
-
-reconciled_disj_svar_info(_, []) = _ :-
- error("make_hlds__reconciled_disj_svar_info: empty disjunct list").
-
-reconciled_disj_svar_info(VarSet, [{_, SInfo0} | DisjSInfos]) = SInfo :-
-
- % We compute the set of final !. and !: state variables
- % over the whole disjunction (not all arms will necessarily
- % include !. and !: mappings for all state variables).
- %
- Dots0 = set__sorted_list_to_set(map__keys(SInfo0 ^ dot)),
- Colons0 = set__sorted_list_to_set(map__keys(SInfo0 ^ colon)),
- Dots = union_dot_svars(Dots0, DisjSInfos),
- Colons = union_colon_svars(Colons0, DisjSInfos),
-
- % Then we update SInfo0 to take the highest numbered
- % !. and !: mapping for each state variable.
- %
- SInfo = list__foldl(reconciled_svar_infos(VarSet, Dots, Colons),
- DisjSInfos, SInfo0).
-
-:- func union_dot_svars(svar_set, hlds_goal_svar_infos) = svar_set.
-
-union_dot_svars(Dots, [] ) = Dots.
-
-union_dot_svars(Dots, [{_, SInfo} | DisjSInfos]) =
- union_dot_svars(
- Dots `union` set__sorted_list_to_set(map__keys(SInfo ^ dot)),
- DisjSInfos
- ).
-
-:- func union_colon_svars(svar_set, hlds_goal_svar_infos) = svar_set.
-
-union_colon_svars(Colons, [] ) = Colons.
-
-union_colon_svars(Colons, [{_, SInfo} | DisjSInfos]) =
- union_colon_svars(
- Colons `union` set__sorted_list_to_set(map__keys(SInfo ^ colon)),
- DisjSInfos
- ).
-
-:- func reconciled_svar_infos(prog_varset, svar_set, svar_set,
- hlds_goal_svar_info, svar_info) = svar_info.
-
-reconciled_svar_infos(VarSet, Dots, Colons,
- {_, SInfoX}, SInfo0) = SInfo :-
- SInfo1 = set__fold(reconciled_svar_infos_dots(VarSet, SInfoX),
- Dots, SInfo0),
- SInfo2 = set__fold(reconciled_svar_infos_colons(VarSet, SInfoX),
- Colons, SInfo1),
- SInfo = ( SInfo2 ^ num := max(SInfo0 ^ num, SInfoX ^ num) ).
-
-:- func reconciled_svar_infos_dots(prog_varset, svar_info, svar, svar_info)
- = svar_info.
-
-reconciled_svar_infos_dots(VarSet, SInfoX, StateVar, SInfo0) = SInfo :-
- (
- DotX = SInfoX ^ dot ^ elem(StateVar),
- Dot0 = SInfo0 ^ dot ^ elem(StateVar)
- ->
- NameX = varset__lookup_name(VarSet, DotX) `with_type` string,
- Name0 = varset__lookup_name(VarSet, Dot0) `with_type` string,
- compare_svar_names(RDot, NameX, Name0),
- (
- RDot = (<),
- SInfo = ( SInfo0 ^ dot ^ elem(StateVar) := Dot0 )
- ;
- RDot = (=),
- SInfo = SInfo0
- ;
- RDot = (>),
- SInfo = ( SInfo0 ^ dot ^ elem(StateVar) := DotX )
- )
- ;
- SInfo = SInfo0
- ).
-
-:- func reconciled_svar_infos_colons(prog_varset, svar_info, svar, svar_info)
- = svar_info.
-
-reconciled_svar_infos_colons(VarSet, SInfoX, StateVar, SInfo0) = SInfo :-
- (
- ColonX = SInfoX ^ colon ^ elem(StateVar),
- Colon0 = SInfo0 ^ colon ^ elem(StateVar)
- ->
- NameX = varset__lookup_name(VarSet, ColonX) `with_type` string,
- Name0 = varset__lookup_name(VarSet, Colon0) `with_type` string,
- compare_svar_names(RColon, NameX, Name0),
- (
- RColon = (<),
- SInfo = ( SInfo0 ^ colon ^ elem(StateVar) := Colon0 )
- ;
- RColon = (=),
- SInfo = SInfo0
- ;
- RColon = (>),
- SInfo = ( SInfo0 ^ colon ^ elem(StateVar) := ColonX )
- )
- ;
- SInfo = SInfo0
- ).
-
-:- func add_disj_unifiers(prog_context, svar_info, svars, hlds_goal_svar_info)
- = hlds_goal.
-
-add_disj_unifiers(Context, SInfo, StateVars, {GoalX, SInfoX}) = Goal :-
- Unifiers = list__foldl(add_disj_unifier(Context, SInfo, SInfoX),
- StateVars, []),
- GoalX = _ - GoalInfo,
- goal_to_conj_list(GoalX, GoalsX),
- conj_list_to_goal(GoalsX ++ Unifiers, GoalInfo, Goal).
-
-:- func add_disj_unifier(prog_context, svar_info, svar_info, svar, hlds_goals)
- = hlds_goals.
-
-add_disj_unifier(Context, SInfo, SInfoX, StateVar, Unifiers) =
- (
- Dot = SInfo ^ dot ^ elem(StateVar),
- DotX = SInfoX ^ dot ^ elem(StateVar),
- Dot \= DotX
- ->
- [svar_unification(yes(dont_warn_singleton), Context, Dot, DotX)
- | Unifiers]
- ;
- Unifiers
- ).
-
-%-----------------------------------------------------------------------------%
-
- % We implement a special purpose comparison for state variable
- % names that compares the numbers appended at the right hand
- % ends of the name strings.
- %
- % NOTE state variable names are either "..._X" or "..._X_N"
- % where X is the name of the program variable used for the
- % state variable and N is a decimal number with no leading
- % zeroes.
- %
-:- pred compare_svar_names(comparison_result::out, string::in, string::in)
- is det.
-
-compare_svar_names(R, A, B) :-
- compare(R, int_suffix_of(A), int_suffix_of(B)).
-
- % Find the number suffix at the end of a string as an int.
- %
-:- func int_suffix_of(string) = int.
-
-int_suffix_of(S) = int_suffix_2(S, length(S) - 1, 1, 0).
-
- % int_suffix_2(String, Index, RadixOfIndexDigit, IntSoFar) = IntSuffix
- %
-:- func int_suffix_2(string, int, int, int) = int.
-
-int_suffix_2(S, I, R, N) =
- (
- 0 =< I,
- digit_to_int(S `unsafe_index` I, D),
- D < 10
- ->
- int_suffix_2(S, I - 1, 10 * R, (R * D) + N)
- ;
- N
- ).
-
-%-----------------------------------------------------------------------------%
-
- % We treat equivalence goals as if they were negations (they are
- % in a negated context after all.)
- %
-:- pred finish_equivalence(svar_info::in, svar_info::in, svar_info::out)
- is det.
-
-finish_equivalence(SInfoBefore, SInfoEqv, SInfo) :-
- finish_negation(SInfoBefore, SInfoEqv, SInfo).
-
-%-----------------------------------------------------------------------------%
-
- % We prepare for a call by setting the ctxt to in_atom. If we're
- % already in an atom then we inherit the parent's set of "updated"
- % state variables.
- %
-:- pred prepare_for_call(svar_info::in, svar_info::out) is det.
-
-prepare_for_call(ParentSInfo, SInfo) :-
- ( ParentSInfo ^ ctxt = in_atom(UpdatedStateVars, _GrandparentSInfo) ->
- Ctxt = in_atom(UpdatedStateVars, ParentSInfo)
- ;
- Ctxt = in_atom(set__init, ParentSInfo)
- ),
- SInfo = ParentSInfo ^ ctxt := Ctxt.
-
-%-----------------------------------------------------------------------------%
-
- % When we finish a call, we're either still inside the
- % atomic formula, in which case we simply propagate the set of
- % "updated" state variables, or we've just emerged, in which case
- % we need to set up the svar_info for the next conjunct.
- %
- % (We can still be in an atomic context if, for example, we've
- % been processing a function call which must appear as an
- % expression and hence occur inside an atomic context.)
- %
-:- pred finish_call(prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out) is det.
-
-finish_call(!VarSet, !SInfo) :-
- ( !.SInfo ^ ctxt = in_atom(UpdatedStateVars, ParentSInfo0) ->
- ParentSInfo = ( ParentSInfo0 ^ dot := !.SInfo ^ dot ),
- ( ParentSInfo ^ ctxt = in_atom(_, GrandParentSInfo) ->
- !:SInfo = ( ParentSInfo ^ ctxt :=
- in_atom(UpdatedStateVars, GrandParentSInfo) )
- ;
- prepare_for_next_conjunct(UpdatedStateVars, !VarSet, ParentSInfo,
- !:SInfo)
- )
- ;
- error("make_hlds__finish_call: ctxt is not in_atom")
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred prepare_for_if_then_else_goal(svars::in,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
-
-prepare_for_if_then_else_goal(StateVars, !VarSet, !SInfo) :-
- prepare_for_local_state_vars(StateVars, !VarSet, !SInfo).
-
-%-----------------------------------------------------------------------------%
-
-:- pred finish_if_then_else_goal_condition(svars::in,
- svar_info::in, svar_info::in, svar_info::out, svar_info::out) is det.
-
-finish_if_then_else_goal_condition(StateVars, SInfoBefore, SInfoA0, SInfoA,
- SInfoB) :-
- SInfoB = SInfoA0,
- finish_local_state_vars(StateVars, _, SInfoBefore, SInfoA0, SInfoA).
-
-%-----------------------------------------------------------------------------%
-
-:- pred finish_if_then_else_goal_then_goal(svars::in,
- svar_info::in, svar_info::in, svar_info::out) is det.
-
-finish_if_then_else_goal_then_goal(StateVars, SInfoBefore, SInfoB0, SInfoB) :-
- finish_local_state_vars(StateVars, _, SInfoBefore, SInfoB0, SInfoB).
-
-%-----------------------------------------------------------------------------%
-
- % The condition of an if-then-else expression is a goal in which
- % only !.X state variables in scope are visible (although the goal
- % may use local state variables introduced via an explicit
- % quantifier.) The StateVars are local to the condition and then-goal.
- %
-:- pred prepare_for_if_then_else_expr(svars::in,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
-
-prepare_for_if_then_else_expr(StateVars, !VarSet, !SInfo) :-
- SInfo0 = !.SInfo,
- !:SInfo = new_svar_info ^ ctxt := in_body,
- !:SInfo = !.SInfo ^ external_dot := SInfo0 ^ dot,
- !:SInfo = !.SInfo ^ num := SInfo0 ^ num,
- prepare_for_local_state_vars(StateVars, !VarSet, !SInfo).
-
-%-----------------------------------------------------------------------------%
-
-:- pred finish_if_then_else_expr_condition(svar_info::in,
- svar_info::in, svar_info::out) is det.
-
-finish_if_then_else_expr_condition(Before, !SInfo) :-
- SInfo0 = !.SInfo,
- !:SInfo = !.SInfo ^ external_dot := Before ^ external_dot,
- !:SInfo = !.SInfo ^ dot := (SInfo0 ^ dot) `overlay` (Before ^ dot),
- !:SInfo = !.SInfo ^ colon := (SInfo0 ^ colon) `overlay` (Before ^ colon),
- !:SInfo = !.SInfo ^ ctxt := Before ^ ctxt.
-
-%-----------------------------------------------------------------------------%
-
-:- pred finish_if_then_else_expr_then_goal(svars::in,
- svar_info::in, svar_info::in, svar_info::out) is det.
-
-finish_if_then_else_expr_then_goal(StateVars, SInfoBefore, !SInfo) :-
- finish_local_state_vars(StateVars, _, SInfoBefore, !SInfo).
-
-%-----------------------------------------------------------------------------%
-
- % Having finished processing one source-level atomic conjunct, prepare
- % for the next. Note that if !:X was not seen in the conjunct we've
- % just processed, then we can reuse the !.X and !:X mappings.
- %
- % p(!.X) where [!.X -> X0, !:X -> X1]
- %
- % can yield
- %
- % p(X0) and [!.X -> X0, !:X -> X2]
- %
- % but
- %
- % p(!.X, !:X) where [!.X -> X0, !:X -> X1]
- %
- % will yield
- %
- % p(X0, X1) and [!.X -> X1, !:X -> X2]
- %
-:- pred prepare_for_next_conjunct(svar_set::in,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
- is det.
-
-prepare_for_next_conjunct(UpdatedStateVars, !VarSet, !SInfo) :-
- Dot0 = !.SInfo ^ dot,
- Colon0 = !.SInfo ^ colon,
- N = !.SInfo ^ num + 1,
- map__init(Nil),
- map__foldl(next_dot_mapping(UpdatedStateVars, Dot0, Colon0), Colon0,
- Nil, Dot),
- map__foldl2(next_colon_mapping(UpdatedStateVars, Colon0, N), Colon0,
- !VarSet, Nil, Colon),
- !:SInfo = !.SInfo ^ ctxt := in_body,
- !:SInfo = !.SInfo ^ num := N,
- !:SInfo = !.SInfo ^ dot := Dot,
- !:SInfo = !.SInfo ^ colon := Colon.
-
- % If the state variable has been updated (i.e. there was a !:X
- % reference) then the next !.X mapping will be the current !:X
- % mapping.
- % Otherwise, preserve the current !.X mapping, if any (there
- % may be none if, for example, the head only references !:X
- % and there have been no prior references to !:X in the body.)
- %
-:- pred next_dot_mapping(svar_set::in, svar_map::in, svar_map::in, svar::in,
- prog_var::in, svar_map::in, svar_map::out) is det.
-
-next_dot_mapping(UpdatedStateVars, OldDot, OldColon, StateVar, _, Dot0, Dot) :-
- ( UpdatedStateVars `contains` StateVar ->
- Var = OldColon ^ det_elem(StateVar),
- Dot = ( Dot0 ^ elem(StateVar) := Var )
- ; Var = OldDot ^ elem(StateVar) ->
- Dot = ( Dot0 ^ elem(StateVar) := Var )
- ;
- Dot = Dot0
- ).
-
- % If the state variable has been updated (i.e. there was a !:X
- % reference) then create a new mapping for the next !:X.
- % Otherwise, the next !:X mapping is the same as the current
- % !:X mapping.
- %
-:- pred next_colon_mapping(svar_set::in, svar_map::in, int::in, svar::in,
- prog_var::in, prog_varset::in, prog_varset::out,
- svar_map::in, svar_map::out) is det.
-
-next_colon_mapping(UpdatedStateVars, OldColon, N, StateVar, _,
- !VarSet, !Colon) :-
- ( UpdatedStateVars `contains` StateVar ->
- next_svar_mapping(N, StateVar, _Var, !VarSet, !Colon)
- ;
- !:Colon = ( !.Colon ^ elem(StateVar) := OldColon ^ det_elem(StateVar) )
- ).
-
-:- pred next_svar_mapping(int::in, svar::in, prog_var::out,
- prog_varset::in, prog_varset::out, svar_map::in, svar_map::out) is det.
-
-next_svar_mapping(N, StateVar, Var, !VarSet, !Map) :-
- Name = string__format("STATE_VARIABLE_%s_%d",
- [s(varset__lookup_name(!.VarSet, StateVar)), i(N)]),
- varset__new_named_var(!.VarSet, Name, Var, !:VarSet),
- !:Map = ( !.Map ^ elem(StateVar) := Var ).
-
-%-----------------------------------------------------------------------------%
-
- % Replace !X args with two args !.X, !:X in that order.
- %
-:- func expand_bang_state_var_args(list(prog_term)) = list(prog_term).
-
-expand_bang_state_var_args(Args) =
- list__foldr(expand_bang_state_var, Args, []).
-
-:- func expand_bang_state_var(prog_term, list(prog_term)) = list(prog_term).
-
-expand_bang_state_var(T @ variable(_), Ts) = [T | Ts].
-
-expand_bang_state_var(T @ functor(Const, Args, Ctxt), Ts) =
- (
- Const = atom("!"),
- Args = [variable(_StateVar)]
- ->
- [functor(atom("!."), Args, Ctxt), functor(atom("!:"), Args, Ctxt) | Ts]
- ;
- [T | Ts]
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- func expand_bang_state_var_args_in_instance_method_heads(instance_body) =
- instance_body.
-
-expand_bang_state_var_args_in_instance_method_heads(abstract) = abstract.
-
-expand_bang_state_var_args_in_instance_method_heads(concrete(Methods)) =
- concrete(list__map(expand_method_bsvs, Methods)).
-
-:- func expand_method_bsvs(instance_method) = instance_method.
-
-expand_method_bsvs(IM) = IM :-
- IM = instance_method(_, _, name(_), _, _).
-
-expand_method_bsvs(IM0) = IM :-
- IM0 = instance_method(PredOrFunc, Method, clauses(Cs0), Arity0, Ctxt),
- Cs = list__map(expand_item_bsvs, Cs0),
- % Note that the condition should always succeed...
- %
- ( Cs = [clause(_, _, _, Args, _) | _] ->
- adjust_func_arity(PredOrFunc, Arity, list__length(Args))
- ;
- Arity = Arity0
- ),
- IM = instance_method(PredOrFunc, Method, clauses(Cs), Arity, Ctxt).
-
- % The instance method clause items will all be clause items.
- %
-:- func expand_item_bsvs(item) = item.
-
-expand_item_bsvs(Item) =
- ( Item = clause(VarSet, PredOrFunc, SymName, Args, Body) ->
- clause(VarSet, PredOrFunc, SymName, expand_bang_state_var_args(Args),
- Body)
- ;
- Item
- ).
-
-%-----------------------------------------------------------------------------%
-
- % Given a list of argument terms, substitute !.X and !:X with
- % the corresponding state variable mappings. Any !X should
- % already have been expanded into !.X, !:X via a call to
- % expand_bang_state_var_args/1.
- %
-:- pred substitute_state_var_mappings(list(prog_term)::in,
- list(prog_term)::out, prog_varset::in, prog_varset::out,
- svar_info::in, svar_info::out, io::di, io::uo) is det.
-
-substitute_state_var_mappings([], [], !VarSet, !SInfo, !IO).
-substitute_state_var_mappings([Arg0 | Args0], [Arg | Args],
- !VarSet, !SInfo, !IO) :-
- substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO),
- substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO).
-
-:- pred substitute_state_var_mapping(prog_term::in, prog_term::out,
- prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
- io::di, io::uo) is det.
-
-substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO) :-
- (
- Arg0 = functor(atom("!."), [variable(StateVar)], Context)
- ->
- dot(Context, StateVar, Var, !VarSet, !SInfo, !IO),
- Arg = variable(Var)
- ;
- Arg0 = functor(atom("!:"), [variable(StateVar)], Context)
- ->
- colon(Context, StateVar, Var, !VarSet, !SInfo, !IO),
- Arg = variable(Var)
- ;
- Arg = Arg0
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred illegal_state_var_func_result(pred_or_func::in, list(prog_term)::in,
- svar::out) is semidet.
-
-illegal_state_var_func_result(function, Args, StateVar) :-
- list__last(Args, functor(atom("!"), [variable(StateVar)], _Ctxt)).
-
-%-----------------------------------------------------------------------------%
-
- % We do not allow !X to appear as a lambda head argument.
- % We might extend the syntax still further to accommodate
- % this as an option, e.g. !IO::(di, uo).
- %
-:- pred lambda_args_contain_bang_state_var(list(prog_term)::in, prog_var::out)
- is semidet.
-
-lambda_args_contain_bang_state_var([Arg | Args], StateVar) :-
- ( Arg = functor(atom("!"), [variable(StateVar0)], _) ->
- StateVar = StateVar0
- ;
- lambda_args_contain_bang_state_var(Args, StateVar)
- ).
-
-%-----------------------------------------------------------------------------%
-
-:- pred report_illegal_state_var_update(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
-
-report_illegal_state_var_update(Context, VarSet, StateVar, !IO) :-
- Name = varset__lookup_name(VarSet, StateVar),
- % XXX: why the nl here?
- Pieces = [nl, words("Error: cannot use"), fixed("!:" ++ Name),
- words("in this context;"), nl,
- words("however"), fixed("!." ++ Name), words("may be used here.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred report_non_visible_state_var(string::in, prog_context::in,
- prog_varset::in, svar::in, io::di, io::uo) is det.
-
-report_non_visible_state_var(DorC, Context, VarSet, StateVar, !IO) :-
- Name = varset__lookup_name(VarSet, StateVar),
- Pieces = [words("Error: state variable"),
- fixed("!" ++ DorC ++ Name), words("is not visible in this context.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred report_unitialized_state_var(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
-
-report_unitialized_state_var(Context, VarSet, StateVar, !IO) :-
- Name = varset__lookup_name(VarSet, StateVar),
- Pieces = [words("Warning: reference to unitialized state variable"),
- fixed("!." ++ Name), suffix("."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- record_warning(!IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred report_illegal_func_svar_result(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
-
-report_illegal_func_svar_result(Context, VarSet, StateVar, !IO) :-
- Name = varset__lookup_name(VarSet, StateVar),
- Pieces = [words("Error:"), fixed("!" ++ Name),
- words("cannot be a function result."), nl,
- words("You probably meant"), fixed("!." ++ Name),
- words("or"), fixed("!:" ++ Name), suffix("."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
-
-%-----------------------------------------------------------------------------%
-
-:- pred report_illegal_bang_svar_lambda_arg(prog_context::in, prog_varset::in,
- svar::in, io::di, io::uo) is det.
-
-report_illegal_bang_svar_lambda_arg(Context, VarSet, StateVar, !IO) :-
- Name = varset__lookup_name(VarSet, StateVar),
- Pieces = [words("Error:"), fixed("!" ++ Name),
- words("cannot be a lambda argument."), nl,
- words("Perhaps you meant"), fixed("!." ++ Name),
- words("or"), fixed("!:" ++ Name), suffix("."), nl],
- write_error_pieces(Context, 0, Pieces, !IO),
- io__set_exit_status(1, !IO).
+:- include_module add_aditi.
+:- include_module add_class.
+:- include_module add_clause.
+:- include_module add_mode.
+:- include_module add_pragma.
+:- include_module add_pred.
+:- include_module add_solver.
+:- include_module add_special_pred.
+:- include_module add_type.
+:- include_module field_access.
+:- include_module make_hlds_error.
+:- include_module make_hlds_passes.
+:- include_module make_hlds_warn.
+:- include_module qual_info.
+:- include_module state_var.
+:- include_module superhomogeneous.
+
+:- import_module hlds__make_hlds__add_class.
+:- import_module hlds__make_hlds__add_pred.
+:- import_module hlds__make_hlds__add_special_pred.
+:- import_module hlds__make_hlds__make_hlds_passes.
+:- import_module hlds__make_hlds__qual_info.
+
+:- type make_hlds_qual_info == hlds__make_hlds__qual_info__qual_info.
+
+parse_tree_to_hlds(Module, MQInfo0, EqvMap, ModuleInfo,
+ QualInfo, InvalidTypes, InvalidModes, !IO) :-
+ do_parse_tree_to_hlds(Module, MQInfo0, EqvMap, ModuleInfo,
+ QualInfo, InvalidTypes, InvalidModes, !IO).
+
+add_new_proc(InstVarSet, Arity, ArgModes, MaybeDeclaredArgModes,
+ MaybeArgLives, MaybeDet, Context, IsAddressTaken, PredInfo0, PredInfo,
+ ModeId) :-
+ do_add_new_proc(InstVarSet, Arity, ArgModes, MaybeDeclaredArgModes,
+ MaybeArgLives, MaybeDet, Context, IsAddressTaken, PredInfo0, PredInfo,
+ ModeId).
+
+add_special_pred_for_real(SpecialPredId, TVarSet,
+ Type0, TypeCtor, TypeBody, Context, Status0, !ModuleInfo) :-
+ do_add_special_pred_for_real(SpecialPredId, TVarSet,
+ Type0, TypeCtor, TypeBody, Context, Status0, !ModuleInfo).
+
+add_special_pred_decl_for_real(SpecialPredId, TVarSet,
+ Type, TypeCtor, Context, Status0, !ModuleInfo) :-
+ do_add_special_pred_decl_for_real(SpecialPredId, TVarSet,
+ Type, TypeCtor, Context, Status0, !ModuleInfo).
+
+produce_instance_method_clauses(InstanceProcDefn,
+ PredOrFunc, PredArity, ArgTypes, Markers, Context, Status,
+ ClausesInfo, !ModuleInfo, !QualInfo, !IO) :-
+ do_produce_instance_method_clauses(InstanceProcDefn, PredOrFunc,
+ PredArity, ArgTypes, Markers, Context, Status, ClausesInfo,
+ !ModuleInfo, !QualInfo, !IO).
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
+set_module_recomp_info(QualInfo, !ModuleInfo) :-
+ set_module_recompilation_info(QualInfo, !ModuleInfo).
Index: compiler/make_hlds_error.m
===================================================================
RCS file: compiler/make_hlds_error.m
diff -N compiler/make_hlds_error.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/make_hlds_error.m 25 Jul 2005 04:21:42 -0000
@@ -0,0 +1,211 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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.
+%-----------------------------------------------------------------------------%
+%
+% Utility predicates for writing out warning and error messages when
+% building the HLDS. Error messages specific to a given submodule of
+% make_hlds.m are in that specific submodule; this submodule is for error
+% messages that are needed by more than one submodule.
+%
+
+:- module hlds__make_hlds__make_hlds_error.
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module bool.
+:- import_module io.
+:- import_module list.
+
+:- pred multiple_def_error(import_status::in, sym_name::in, int::in,
+ string::in, prog_context::in, prog_context::in, bool::out,
+ io::di, io::uo) is det.
+
+:- pred undefined_pred_or_func_error(sym_name::in, int::in, prog_context::in,
+ string::in, io::di, io::uo) is det.
+
+ % Similar to undeclared_mode_error, but gives less information.
+ % XXX perhaps we should get rid of this, and change the callers to
+ % instead call undeclared_mode_error.
+ %
+:- pred undefined_mode_error(sym_name::in, int::in, prog_context::in,
+ string::in, io::di, io::uo) is det.
+
+ % Similar to undefined_mode_error, but gives more information.
+ % XXX the documentation here should be somewhat less circular.
+ %
+:- pred undeclared_mode_error(list(mode)::in, prog_varset::in,
+ pred_id::in, pred_info::in, module_info::in, prog_context::in,
+ io::di, io::uo) is det.
+
+:- pred maybe_undefined_pred_error(sym_name::in, int::in, pred_or_func::in,
+ import_status::in, bool::in, prog_context::in, string::in,
+ io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module check_hlds__mode_errors.
+:- import_module hlds__hlds_out.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__mercury_to_mercury.
+:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_out.
+
+:- import_module std_util.
+:- import_module string.
+:- import_module varset.
+
+%-----------------------------------------------------------------------------%
+
+multiple_def_error(Status, Name, Arity, DefType, Context, OrigContext,
+ FoundError, !IO) :-
+ ( Status \= opt_imported ->
+ Pieces = [words("Error:"),
+ fixed(DefType), sym_name_and_arity(Name / Arity),
+ words("multiply defined.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ OrigPieces = [words("Here is the previous definition of"),
+ fixed(DefType), sym_name_and_arity(Name / Arity),
+ suffix(".")],
+ write_error_pieces(OrigContext, 0, OrigPieces, !IO),
+ io__set_exit_status(1, !IO),
+ FoundError = yes
+ ;
+ % We don't take care not to read the same declaration
+ % from multiple sources with inter-module optimization
+ % so ignore multiple definition errors in the items read
+ % for inter-module optimization.
+ FoundError = no
+ ).
+
+undefined_pred_or_func_error(Name, Arity, Context, Description, !IO) :-
+ % This used to say `preceding' instead of `corresponding.'
+ % Which is more correct?
+ Pieces = [words("Error:"), words(Description), words("for"),
+ sym_name_and_arity(Name / Arity),
+ words("without corresponding `pred' or `func' declaration.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+undefined_mode_error(Name, Arity, Context, Description, !IO) :-
+ Pieces = [words("Error:"), words(Description), words("for"),
+ sym_name_and_arity(Name / Arity),
+ words("specifies non-existent mode.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+undeclared_mode_error(ModeList, VarSet, PredId, PredInfo, ModuleInfo,
+ Context, !IO) :-
+ prog_out__write_context(Context, !IO),
+ io__write_string("In clause for ", !IO),
+ hlds_out__write_pred_id(ModuleInfo, PredId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(
+ " error: mode annotation specifies undeclared mode\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" `", !IO),
+ strip_builtin_qualifiers_from_mode_list(ModeList, StrippedModeList),
+ PredOrFunc = pred_info_is_pred_or_func(PredInfo),
+ Name = pred_info_name(PredInfo),
+ MaybeDet = no,
+ mercury_output_mode_subdecl(PredOrFunc, varset__coerce(VarSet),
+ unqualified(Name), StrippedModeList, MaybeDet, Context, !IO),
+ io__write_string("'\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" of ", !IO),
+ hlds_out__write_pred_id(ModuleInfo, PredId, !IO),
+ io__write_string(".\n", !IO),
+ globals__io_lookup_bool_option(verbose_errors, VerboseErrors, !IO),
+ ProcIds = pred_info_all_procids(PredInfo),
+ (
+ ProcIds = [],
+ prog_out__write_context(Context, !IO),
+ io__write_string(" (There are no declared modes for this ", !IO),
+ write_pred_or_func(PredOrFunc, !IO),
+ io__write_string(".)\n", !IO)
+ ;
+ ProcIds = [_ | _],
+ (
+ VerboseErrors = yes,
+ io__write_string("\tThe declared modes for this ", !IO),
+ write_pred_or_func(PredOrFunc, !IO),
+ io__write_string(" are the following:\n", !IO),
+ list__foldl(output_mode_decl_for_pred_info(PredInfo), ProcIds, !IO)
+ ;
+ VerboseErrors = no
+ )
+ ).
+
+:- pred output_mode_decl_for_pred_info(pred_info::in, proc_id::in,
+ io::di, io::uo) is det.
+
+output_mode_decl_for_pred_info(PredInfo, ProcId, !IO) :-
+ io__write_string("\t\t:- mode ", !IO),
+ output_mode_decl(ProcId, PredInfo, !IO),
+ io__write_string(".\n", !IO).
+
+ % This is not considered an unconditional error anymore:
+ % if there is no `:- pred' or `:- func' declaration,
+ % and the declaration is local, and not a type class method,
+ % and the `--infer-types' option was specified,
+ % then we just add an implicit declaration for that predicate or
+ % function, marking it as one whose type will be inferred.
+ %
+ % If this module is for a query generated by the Aditi dbsh
+ % (--aditi-only is set), allow mode declarations for exported
+ % predicates with no `:- pred' or `:- func' declaration.
+ % The predicate will never be called from a compiled Mercury
+ % procedure. The RL bytecode for the predicate will be called
+ % directly using information from the generated
+ % `<module>.derived_schema' file to work out the argument
+ % types of the output relation.
+ %
+maybe_undefined_pred_error(Name, Arity, PredOrFunc, Status, IsClassMethod,
+ Context, Description, !IO) :-
+ status_defined_in_this_module(Status, DefinedInThisModule),
+ status_is_exported(Status, IsExported),
+ globals__io_lookup_bool_option(infer_types, InferTypes, !IO),
+ globals__io_lookup_bool_option(aditi_only, AditiOnly, !IO),
+ (
+ (
+ DefinedInThisModule = yes,
+ IsExported = no,
+ IsClassMethod = no,
+ InferTypes = yes
+ ;
+ AditiOnly = yes
+ )
+ ->
+ true
+ ;
+ Pieces = [words("Error:"), words(Description), words("for"),
+ words(simple_call_id_to_string(PredOrFunc, Name, Arity)), nl,
+ words("without preceding"),
+ fixed("`" ++ pred_or_func_to_str(PredOrFunc) ++ "'"),
+ words("declaration.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO)
+ ).
+
+% % This predicate is currently unused.
+%
+% :- pred clause_for_imported_pred_error(sym_name::in, arity::in,
+% pred_or_func::in, prog_context::in, io::di, io::uo) is det.
+%
+% clause_for_imported_pred_error(Name, Arity, PredOrFunc, Context, !IO) :-
+% Pieces = [words("Error: clause for imported"),
+% pred_or_func(PredOrFunc),
+% sym_name_and_arity(Name / Arity),
+% suffix(".")],
+% write_error_pieces(Context, 0, Pieces, !IO),
+% io__set_exit_status(1, !IO).
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: compiler/make_hlds_passes.m
diff -N compiler/make_hlds_passes.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/make_hlds_passes.m 25 Jul 2005 08:17:22 -0000
@@ -0,0 +1,1003 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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 hlds__make_hlds__make_hlds_passes.
+:- interface.
+
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__equiv_type.
+:- import_module parse_tree__module_qual.
+:- import_module parse_tree__prog_data.
+
+:- import_module bool.
+:- import_module io.
+:- import_module list.
+:- import_module term.
+
+ % When adding an item to the HLDS we need to know both its
+ % import_status and whether uses of it must be module qualified.
+:- type item_status
+ ---> item_status(import_status, need_qualifier).
+
+ % do_parse_tree_to_hlds(ParseTree, MQInfo, EqvMap, HLDS, QualInfo,
+ % InvalidTypes, InvalidModes):
+ %
+ % Given MQInfo (returned by module_qual.m) and EqvMap (returned by
+ % equiv_type.m), converts ParseTree to HLDS. Any errors found are
+ % recorded in the HLDS num_errors field.
+ % Returns InvalidTypes = yes if undefined types found.
+ % Returns InvalidModes = yes if undefined or cyclic insts or modes
+ % found. QualInfo is an abstract type that is then passed back to
+ % produce_instance_method_clauses (see below).
+ %
+:- pred do_parse_tree_to_hlds(compilation_unit::in, mq_info::in, eqv_map::in,
+ module_info::out, qual_info::out, bool::out, bool::out, io::di, io::uo)
+ is det.
+
+:- pred add_item_clause(item::in, import_status::in, import_status::out,
+ prog_context::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+ % If there are any Aditi procedures enable Aditi compilation.
+ % If there are only imported Aditi procedures, magic.m still
+ % needs to remove the `aditi' and `base_relation' markers
+ % so that the procedures are not ignored by the code
+ % generation annotation passes (e.g. arg_info.m).
+ %
+:- pred maybe_enable_aditi_compilation(item_status::in, term__context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+:- pred add_stratified_pred(string::in, sym_name::in, arity::in,
+ term__context::in, module_info::in, module_info::out, io::di, io::uo)
+ is det.
+
+ % add_pred_marker(ModuleInfo0, PragmaName, Name, Arity, Status,
+ % Context, Marker, ConflictMarkers, ModuleInfo, !IO):
+ %
+ % Adds Marker to the marker list of the pred(s) with give Name and Arity,
+ % updating the ModuleInfo. If the named pred does not exist, or the pred
+ % already has a marker in ConflictMarkers, report an error.
+ %
+:- pred add_pred_marker(string::in, sym_name::in, arity::in, import_status::in,
+ prog_context::in, marker::in, list(marker)::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+:- type add_marker_pred_info == pred(pred_info, pred_info).
+:- inst add_marker_pred_info == (pred(in, out) is det).
+
+:- pred do_add_pred_marker(string::in, sym_name::in, arity::in,
+ import_status::in, bool::in, term__context::in,
+ add_marker_pred_info::in(add_marker_pred_info),
+ module_info::in, module_info::out, list(pred_id)::out,
+ io::di, io::uo) is det.
+
+:- pred module_mark_as_external(sym_name::in, int::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+:- pred check_for_errors(pred(module_info, module_info, io, io)
+ ::pred(in, out, di, uo) is det, bool::out,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+:- pred maybe_check_field_access_function(sym_name::in, arity::in,
+ import_status::in, prog_context::in, module_info::in,
+ io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module check_hlds__clause_to_proc.
+:- import_module check_hlds__type_util.
+:- import_module hlds__hlds_data.
+:- import_module hlds__hlds_out.
+:- import_module hlds__make_hlds__add_class.
+:- import_module hlds__make_hlds__add_clause.
+:- import_module hlds__make_hlds__add_mode.
+:- import_module hlds__make_hlds__add_pragma.
+:- import_module hlds__make_hlds__add_pred.
+:- import_module hlds__make_hlds__add_solver.
+:- import_module hlds__make_hlds__add_special_pred.
+:- import_module hlds__make_hlds__add_type.
+:- import_module hlds__make_hlds__make_hlds_error.
+:- import_module hlds__make_hlds__make_hlds_warn.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module hlds__special_pred.
+:- import_module libs__globals.
+:- import_module libs__options.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_data.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_type.
+:- import_module parse_tree__prog_util.
+:- import_module recompilation.
+
+:- import_module int.
+:- import_module map.
+:- import_module require.
+:- import_module set.
+:- import_module std_util.
+:- import_module string.
+:- import_module varset.
+
+do_parse_tree_to_hlds(module(Name, Items), MQInfo0, EqvMap, ModuleInfo,
+ QualInfo, InvalidTypes, InvalidModes, !IO) :-
+ some [!Module] (
+ globals__io_get_globals(Globals, !IO),
+ mq_info_get_partial_qualifier_info(MQInfo0, PQInfo),
+ module_info_init(Name, Items, Globals, PQInfo, no, !:Module),
+ add_item_list_decls_pass_1(Items,
+ item_status(local, may_be_unqualified), !Module,
+ no, InvalidModes0, !IO),
+ globals__io_lookup_bool_option(statistics, Statistics, !IO),
+ maybe_report_stats(Statistics, !IO),
+
+ check_for_errors(
+ add_item_list_decls_pass_2(Items,
+ item_status(local, may_be_unqualified)),
+ InvalidTypes1, !Module, !IO),
+
+ % Add constructors and special preds to the HLDS.
+ % This must be done after adding all type and
+ % `:- pragma foreign_type' declarations.
+ % If there were errors in foreign type type declarations,
+ % doing this may cause a compiler abort.
+ (
+ InvalidTypes1 = no,
+ module_info_types(!.Module, Types),
+ map__foldl3(process_type_defn, Types, no, InvalidTypes2, !Module,
+ !IO)
+ ;
+ InvalidTypes1 = yes,
+ InvalidTypes2 = yes
+ ),
+
+ % Add the special preds for the builtin types which don't have a
+ % type declaration, hence no hlds_type_defn is generated for them.
+ (
+ Name = mercury_public_builtin_module,
+ compiler_generated_rtti_for_builtins(!.Module)
+ ->
+ varset__init(TVarSet),
+ Body = abstract_type(non_solver_type),
+ term__context_init(Context),
+ Status = local,
+ list__foldl(
+ (pred(TypeCtor::in, M0::in, M::out) is det :-
+ construct_type(TypeCtor, [], Type),
+ add_special_preds(TVarSet, Type, TypeCtor, Body, Context,
+ Status, M0, M)
+ ), builtin_type_ctors_with_no_hlds_type_defn, !Module)
+ ;
+ true
+ ),
+
+ maybe_report_stats(Statistics, !IO),
+ % Balance any data structures that need it.
+ module_info_optimize(!Module),
+ maybe_report_stats(Statistics, !IO),
+ init_qual_info(MQInfo0, EqvMap, QualInfo0),
+ add_item_list_clauses(Items, local, !Module, QualInfo0, QualInfo, !IO),
+
+ qual_info_get_mq_info(QualInfo, MQInfo),
+ mq_info_get_type_error_flag(MQInfo, InvalidTypes3),
+ InvalidTypes = InvalidTypes1 `or` InvalidTypes2 `or` InvalidTypes3,
+ mq_info_get_mode_error_flag(MQInfo, InvalidModes1),
+ InvalidModes = InvalidModes0 `or` InvalidModes1,
+ mq_info_get_num_errors(MQInfo, MQ_NumErrors),
+
+ module_info_num_errors(!.Module, ModuleNumErrors),
+ NumErrors = ModuleNumErrors + MQ_NumErrors,
+ module_info_set_num_errors(NumErrors, !Module),
+ % The predid list is constructed in reverse order, for efficiency,
+ % so we return it to the correct order here.
+ module_info_reverse_predids(!Module),
+ ModuleInfo = !.Module
+ ).
+
+check_for_errors(P, FoundError, !ModuleInfo, !IO) :-
+ io__get_exit_status(BeforeStatus, !IO),
+ io__set_exit_status(0, !IO),
+ module_info_num_errors(!.ModuleInfo, BeforeNumErrors),
+ P(!ModuleInfo, !IO),
+ module_info_num_errors(!.ModuleInfo, AfterNumErrors),
+ io__get_exit_status(AfterStatus, !IO),
+ (
+ AfterStatus = 0,
+ BeforeNumErrors = AfterNumErrors
+ ->
+ FoundError = no
+ ;
+ FoundError = yes
+ ),
+ ( BeforeStatus \= 0 ->
+ io__set_exit_status(BeforeStatus, !IO)
+ ;
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % pass 1:
+ % Add the declarations one by one to the module,
+ % except for type definitions and pragmas.
+ %
+ % The `InvalidModes' bool records whether we detected
+ % any cyclic insts or modes.
+ %
+:- pred add_item_list_decls_pass_1(item_list::in, item_status::in,
+ module_info::in, module_info::out, bool::in, bool::out,
+ io::di, io::uo) is det.
+
+add_item_list_decls_pass_1([], _, !ModuleInfo, !InvalidModes, !IO).
+add_item_list_decls_pass_1([Item - Context | Items], Status0, !ModuleInfo,
+ !InvalidModes, !IO) :-
+ add_item_decl_pass_1(Item, Context, Status0, Status1, !ModuleInfo,
+ NewInvalidModes, !IO),
+ !:InvalidModes = bool__or(!.InvalidModes, NewInvalidModes),
+ add_item_list_decls_pass_1(Items, Status1, !ModuleInfo, !InvalidModes, !IO).
+
+ % pass 2:
+ % Add the type definitions and pragmas one by one to the module,
+ % and add default modes for functions with no mode declaration.
+ %
+ % Adding type definitions needs to come after we have added the
+ % pred declarations,
+ % since we need to have the pred_id for `index/2' and `compare/3'
+ % when we add compiler-generated clauses for `compare/3'.
+ % (And similarly for other compiler-generated predicates like that.)
+ %
+ % Adding pragmas needs to come after we have added the
+ % pred declarations, in order to allow the pragma declarations
+ % for a predicate to syntactically precede the pred declaration.
+ %
+ % Adding default modes for functions needs to come after we have
+ % processed all the mode declarations, since otherwise we can't be
+ % sure that there isn't a mode declaration for the function.
+ %
+:- pred add_item_list_decls_pass_2(item_list::in, item_status::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+add_item_list_decls_pass_2([], _, !ModuleInfo, !IO).
+add_item_list_decls_pass_2([Item - Context | Items], Status0, !ModuleInfo,
+ !IO) :-
+ add_item_decl_pass_2(Item, Context, Status0, Status1, !ModuleInfo, !IO),
+ add_item_list_decls_pass_2(Items, Status1, !ModuleInfo, !IO).
+
+ % pass 3:
+ % Add the clauses one by one to the module.
+ % (I supposed this could conceivably be folded into pass 2?)
+ %
+ % Check that the declarations for field extraction
+ % and update functions are sensible.
+ %
+:- pred add_item_list_clauses(item_list::in, import_status::in,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+add_item_list_clauses([], _Status, !ModuleInfo, !QualInfo, !IO).
+add_item_list_clauses([Item - Context | Items], Status0,
+ !ModuleInfo, !QualInfo, !IO) :-
+ add_item_clause(Item, Status0, Status1, Context, !ModuleInfo, !QualInfo,
+ !IO),
+ add_item_list_clauses(Items, Status1, !ModuleInfo, !QualInfo, !IO).
+
+%-----------------------------------------------------------------------------%
+
+ % The bool records whether any cyclic insts or modes were
+ % detected.
+ %
+:- pred add_item_decl_pass_1(item::in, prog_context::in,
+ item_status::in, item_status::out, module_info::in, module_info::out,
+ bool::out, io::di, io::uo) is det.
+
+add_item_decl_pass_1(clause(_, _, _, _, _), _, !Status, !ModuleInfo, no, !IO).
+ % Skip clauses.
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+ % If this is a solver type then we need to also add the declarations
+ % for the compiler generated construction function and deconstruction
+ % predicate for the special constrained data constructor.
+ %
+ % In pass 3 we add the corresponding clauses.
+ %
+ % Before switch detection, we turn calls to these functions/predicates
+ % into ordinary constructions/deconstructions, but preserve the
+ % corresponding impurity annotations.
+ Item = type_defn(TVarSet, SymName, TypeParams, TypeDefn, _Cond),
+ (
+ TypeDefn = solver_type(SolverTypeDetails, _MaybeUserEqComp)
+ ->
+ add_solver_type_decl_items(TVarSet, SymName, TypeParams,
+ SolverTypeDetails, Context, !Status, !ModuleInfo, !IO)
+ ;
+ true
+ ).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode, !IO) :-
+ Item = inst_defn(VarSet, Name, Params, InstDefn, Cond),
+ module_add_inst_defn(VarSet, Name, Params, InstDefn, Cond, Context,
+ !.Status, !ModuleInfo, InvalidMode, !IO).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, InvalidMode, !IO) :-
+ Item = mode_defn(VarSet, Name, Params, ModeDefn, Cond),
+ module_add_mode_defn(VarSet, Name, Params, ModeDefn,
+ Cond, Context, !.Status, !ModuleInfo, InvalidMode, !IO).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+ Item = pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
+ PredName, TypesAndModes, _WithType, _WithInst, MaybeDet, _Cond,
+ Purity, ClassContext),
+ init_markers(Markers),
+ module_add_pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
+ PredName, TypesAndModes, MaybeDet, Purity, ClassContext, Markers,
+ Context, !.Status, _, !ModuleInfo, !IO).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+ Item = pred_or_func_mode(VarSet, MaybePredOrFunc, PredName, Modes,
+ _WithInst, MaybeDet, _Cond),
+ (
+ MaybePredOrFunc = yes(PredOrFunc),
+ !.Status = item_status(ImportStatus, _),
+ IsClassMethod = no,
+ module_add_mode(VarSet, PredName, Modes, MaybeDet, ImportStatus,
+ Context, PredOrFunc, IsClassMethod, _, !ModuleInfo, !IO)
+ ;
+ MaybePredOrFunc = no,
+ % equiv_type.m should have either set the pred_or_func
+ % or removed the item from the list.
+ unexpected(this_file, "add_item_decl_pass_1: " ++
+ "no pred_or_func on mode declaration")
+ ).
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+ Item = pragma(_).
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+ Item = promise(_, _, _, _).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+ Item = module_defn(_VarSet, ModuleDefn),
+ ( module_defn_update_import_status(ModuleDefn, StatusPrime) ->
+ !:Status = StatusPrime
+ ; ModuleDefn = import(module(Specifiers)) ->
+ !.Status = item_status(IStat, _),
+ (
+ ( status_defined_in_this_module(IStat, yes)
+ ; IStat = imported(ancestor_private_interface)
+ )
+ ->
+ module_add_imported_module_specifiers(Specifiers, !ModuleInfo)
+ ;
+ module_add_indirectly_imported_module_specifiers(Specifiers,
+ !ModuleInfo)
+ )
+ ; ModuleDefn = use(module(Specifiers)) ->
+ !.Status = item_status(IStat, _),
+ (
+ ( status_defined_in_this_module(IStat, yes)
+ ; IStat = imported(ancestor)
+ )
+ ->
+ module_add_imported_module_specifiers(Specifiers, !ModuleInfo)
+ ;
+ module_add_indirectly_imported_module_specifiers(Specifiers,
+ !ModuleInfo)
+ )
+ ; ModuleDefn = include_module(_) ->
+ true
+ ; ModuleDefn = external(MaybeBackend, External) ->
+ ( External = name_arity(Name, Arity) ->
+ lookup_current_backend(CurrentBackend, !IO),
+ (
+ (
+ MaybeBackend = no
+ ;
+ MaybeBackend = yes(Backend),
+ Backend = CurrentBackend
+ )
+ ->
+ module_mark_as_external(Name, Arity, Context, !ModuleInfo, !IO)
+ ;
+ true
+ )
+ ;
+ prog_out__write_context(Context, !IO),
+ report_warning("Warning: `external' declaration requires arity.\n",
+ !IO)
+ )
+ ; ModuleDefn = module(_ModuleName) ->
+ report_unexpected_decl("module", Context, !IO)
+ ; ModuleDefn = end_module(_ModuleName) ->
+ report_unexpected_decl("end_module", Context, !IO)
+ ; ModuleDefn = version_numbers(_, _) ->
+ true
+ ; ModuleDefn = transitively_imported ->
+ true
+ ;
+ prog_out__write_context(Context, !IO),
+ report_warning("Warning: declaration not yet implemented.\n", !IO)
+ ).
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+ Item = nothing(_).
+add_item_decl_pass_1(Item, Context, !Status, !ModuleInfo, no, !IO) :-
+ Item = typeclass(Constraints, FunDeps, Name, Vars, Interface, VarSet),
+ module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface,
+ VarSet, Context, !.Status, !ModuleInfo, !IO).
+add_item_decl_pass_1(Item, _, !Status, !ModuleInfo, no, !IO) :-
+ % We add instance declarations on the second pass so that we don't add
+ % an instance declaration before its class declaration.
+ Item = instance(_, _, _, _, _,_).
+
+%-----------------------------------------------------------------------------%
+
+:- pred add_item_decl_pass_2(item::in, prog_context::in, item_status::in,
+ item_status::out, module_info::in, module_info::out,
+ io::di, io::uo) is det.
+
+add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !IO) :-
+ Item = module_defn(_VarSet, ModuleDefn),
+ ( module_defn_update_import_status(ModuleDefn, StatusPrime) ->
+ !:Status = StatusPrime
+ ;
+ true
+ ).
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+ Item = type_defn(VarSet, Name, Args, TypeDefn, Cond),
+ module_add_type_defn(VarSet, Name, Args, TypeDefn, Cond, Context,
+ !.Status, !ModuleInfo, !IO).
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+ Item = pragma(Pragma),
+ add_pragma(Pragma, Context, !Status, !ModuleInfo, !IO).
+add_item_decl_pass_2(Item, _Context, !Status, !ModuleInfo, !IO) :-
+ Item = pred_or_func(_TypeVarSet, _InstVarSet, _ExistQVars,
+ PredOrFunc, SymName, TypesAndModes, _WithType, _WithInst,
+ _MaybeDet, _Cond, _Purity, _ClassContext),
+ %
+ % add default modes for function declarations, if necessary
+ %
+ (
+ PredOrFunc = predicate
+ ;
+ PredOrFunc = function,
+ list__length(TypesAndModes, Arity),
+ adjust_func_arity(function, FuncArity, Arity),
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
+ (
+ predicate_table_search_func_sym_arity(PredTable0,
+ is_fully_qualified, SymName, FuncArity, PredIds)
+ ->
+ predicate_table_get_preds(PredTable0, Preds0),
+ maybe_add_default_func_modes(PredIds, Preds0, Preds),
+ predicate_table_set_preds(Preds, PredTable0, PredTable),
+ module_info_set_predicate_table(PredTable, !ModuleInfo)
+ ;
+ error("make_hlds.m: can't find func declaration")
+ )
+ ).
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+ Item = promise(_, _, _, _).
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+ Item = clause(_, _, _, _, _).
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+ Item = inst_defn(_, _, _, _, _).
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+ Item = mode_defn(_, _, _, _, _).
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+ Item = pred_or_func_mode(_, _, _, _, _, _, _).
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+ Item = nothing(_).
+add_item_decl_pass_2(Item, _, !Status, !ModuleInfo, !IO) :-
+ Item = typeclass(_, _, _, _, _, _).
+add_item_decl_pass_2(Item, Context, !Status, !ModuleInfo, !IO) :-
+ Item = instance(Constraints, Name, Types, Body, VarSet,
+ InstanceModuleName),
+ !.Status = item_status(ImportStatus, _),
+ ( Body = abstract ->
+ make_status_abstract(ImportStatus, BodyStatus)
+ ;
+ BodyStatus = ImportStatus
+ ),
+ module_add_instance_defn(InstanceModuleName, Constraints, Name, Types,
+ Body, VarSet, BodyStatus, Context, !ModuleInfo, !IO).
+
+%------------------------------------------------------------------------------
+
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Item = clause(VarSet, PredOrFunc, PredName, Args, Body),
+ check_not_exported(!.Status, Context, "clause", !IO),
+ GoalType = none,
+ % at this stage we only need know that it's not a promise declaration
+ module_add_clause(VarSet, PredOrFunc, PredName, Args, Body, !.Status,
+ Context, GoalType, !ModuleInfo, !QualInfo, !IO).
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Item = type_defn(_TVarSet, SymName, TypeParams, TypeDefn, _Cond),
+ % If this is a solver type then we need to also add clauses
+ % the compiler generated inst cast predicate (the declaration
+ % for which was added in pass 1).
+ (
+ TypeDefn = solver_type(SolverTypeDetails, _MaybeUserEqComp)
+ ->
+ add_solver_type_clause_items(SymName, TypeParams, SolverTypeDetails,
+ !Status, Context, !ModuleInfo, !QualInfo, !IO)
+ ;
+ true
+ ).
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+ Item = inst_defn(_, _, _, _, _).
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+ Item = mode_defn(_, _, _, _, _).
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Item = pred_or_func(_, _, _, PredOrFunc, SymName, TypesAndModes,
+ _WithType, _WithInst, _, _, _, _),
+ (
+ PredOrFunc = predicate
+ ;
+ PredOrFunc = function,
+ list__length(TypesAndModes, PredArity),
+ adjust_func_arity(function, FuncArity, PredArity),
+ maybe_check_field_access_function(SymName, FuncArity, !.Status,
+ Context, !.ModuleInfo, !IO)
+ ).
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+ Item = pred_or_func_mode(_, _, _, _, _, _, _).
+add_item_clause(Item, !Status, _, !ModuleInfo, !QualInfo, !IO) :-
+ Item = module_defn(_, Defn),
+ ( Defn = version_numbers(ModuleName, ModuleVersionNumbers) ->
+ %
+ % Record the version numbers for each imported module
+ % if smart recompilation is enabled.
+ %
+ apply_to_recompilation_info(
+ (pred(RecompInfo0::in, RecompInfo::out) is det :-
+ RecompInfo = RecompInfo0 ^ version_numbers ^
+ map__elem(ModuleName) := ModuleVersionNumbers
+ ),
+ !QualInfo)
+ ; module_defn_update_import_status(Defn, ItemStatus1) ->
+ ItemStatus1 = item_status(!:Status, NeedQual),
+ qual_info_get_mq_info(!.QualInfo, MQInfo0),
+ mq_info_set_need_qual_flag(NeedQual, MQInfo0, MQInfo),
+ qual_info_set_mq_info(MQInfo, !QualInfo)
+ ;
+ true
+ ).
+add_item_clause(Item, !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ Item = pragma(Pragma),
+ (
+ Pragma = foreign_proc(Attributes, Pred, PredOrFunc,
+ Vars, VarSet, PragmaImpl)
+ ->
+ module_add_pragma_foreign_proc(Attributes, Pred, PredOrFunc,
+ Vars, VarSet, PragmaImpl, !.Status, Context,
+ !ModuleInfo, !QualInfo, !IO)
+ ;
+ Pragma = import(Name, PredOrFunc, Modes, Attributes, C_Function)
+ ->
+ module_add_pragma_import(Name, PredOrFunc, Modes, Attributes,
+ C_Function, !.Status, Context, !ModuleInfo, !QualInfo, !IO)
+ ;
+ Pragma = fact_table(Pred, Arity, File)
+ ->
+ module_add_pragma_fact_table(Pred, Arity, File, !.Status,
+ Context, !ModuleInfo, !QualInfo, !IO)
+ ;
+ Pragma = tabled(Type, Name, Arity, PredOrFunc, Mode)
+ ->
+ globals__io_lookup_bool_option(type_layout, TypeLayout, !IO),
+ (
+ TypeLayout = yes,
+ module_add_pragma_tabled(Type, Name, Arity, PredOrFunc,
+ Mode, !.Status, Context, !ModuleInfo, !IO)
+ ;
+ TypeLayout = no,
+ module_info_incr_errors(!ModuleInfo),
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: `:- pragma ", !IO),
+ EvalMethodS = eval_method_to_string(Type),
+ io__write_string(EvalMethodS, !IO),
+ io__write_string("' declaration requires the type_ctor_layout\n",
+ !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" structures. Use " ++
+ "the --type-layout flag to enable them.\n", !IO)
+ )
+ ;
+ Pragma = type_spec(_, _, _, _, _, _, _, _)
+ ->
+ %
+ % XXX For the Java back-end, `pragma type_spec' can
+ % result in class names that exceed the limits on file
+ % name length. So we ignore these pragmas for the
+ % Java back-end.
+ %
+ globals__io_get_target(Target, !IO),
+ ( Target = java ->
+ true
+ ;
+ add_pragma_type_spec(Pragma, Context, !ModuleInfo, !QualInfo, !IO)
+ )
+ ;
+ Pragma = termination_info(PredOrFunc, SymName, ModeList,
+ MaybeArgSizeInfo, MaybeTerminationInfo)
+ ->
+ add_pragma_termination_info(PredOrFunc, SymName, ModeList,
+ MaybeArgSizeInfo, MaybeTerminationInfo, Context,
+ !ModuleInfo, !IO)
+ ;
+ Pragma = termination2_info(PredOrFunc, SymName, ModeList,
+ MaybeSuccessArgSizeInfo, MaybeFailureArgSizeInfo,
+ MaybeTerminationInfo)
+ ->
+ add_pragma_termination2_info(PredOrFunc, SymName, ModeList,
+ MaybeSuccessArgSizeInfo, MaybeFailureArgSizeInfo,
+ MaybeTerminationInfo, Context, !ModuleInfo, !IO)
+ ;
+ Pragma = reserve_tag(TypeName, TypeArity)
+ ->
+ add_pragma_reserve_tag(TypeName, TypeArity, !.Status,
+ Context, !ModuleInfo, !IO)
+ ;
+ Pragma = export(Name, PredOrFunc, Modes, C_Function)
+ ->
+ add_pragma_export(Name, PredOrFunc, Modes, C_Function,
+ Context, !ModuleInfo, !IO)
+ ;
+ % Don't worry about any pragma declarations other than the
+ % clause-like pragmas (c_code, tabling and fact_table),
+ % foreign_type and the termination_info pragma here,
+ % since they've already been handled earlier, in pass 2.
+ true
+ ).
+add_item_clause(promise(PromiseType, Goal, VarSet, UnivVars),
+ !Status, Context, !ModuleInfo, !QualInfo, !IO) :-
+ %
+ % If the outermost universally quantified variables
+ % are placed in the head of the dummy predicate, the
+ % typechecker will avoid warning about unbound
+ % type variables as this implicity adds a universal
+ % quantification of the typevariables needed.
+ %
+ term__var_list_to_term_list(UnivVars, HeadVars),
+
+ % extra error checking for promise ex declarations
+ ( PromiseType \= true ->
+ check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !IO)
+ ;
+ true
+ ),
+ % add as dummy predicate
+ add_promise_clause(PromiseType, HeadVars, VarSet, Goal, Context,
+ !.Status, !ModuleInfo, !QualInfo, !IO).
+add_item_clause(nothing(_), !Status, _, !ModuleInfo, !QualInfo, !IO).
+add_item_clause(typeclass(_, _, _, _, _, _), !Status, _, !ModuleInfo,
+ !QualInfo, !IO).
+add_item_clause(instance(_, _, _, _, _, _), !Status, _, !ModuleInfo, !QualInfo,
+ !IO).
+
+ % If a module_defn updates the import_status, return the new status
+ % and whether uses of the following items must be module qualified,
+ % otherwise fail.
+ %
+:- pred module_defn_update_import_status(module_defn::in, item_status::out)
+ is semidet.
+
+module_defn_update_import_status(interface,
+ item_status(exported, may_be_unqualified)).
+module_defn_update_import_status(implementation,
+ item_status(local, may_be_unqualified)).
+module_defn_update_import_status(private_interface,
+ item_status(exported_to_submodules, may_be_unqualified)).
+module_defn_update_import_status(imported(Section),
+ item_status(imported(Section), may_be_unqualified)).
+module_defn_update_import_status(used(Section),
+ item_status(imported(Section), must_be_qualified)).
+module_defn_update_import_status(opt_imported,
+ item_status(opt_imported, must_be_qualified)).
+module_defn_update_import_status(abstract_imported,
+ item_status(abstract_imported, must_be_qualified)).
+
+%-----------------------------------------------------------------------------%
+
+maybe_enable_aditi_compilation(_Status, Context, !ModuleInfo, !IO) :-
+ globals__io_lookup_bool_option(aditi, Aditi, !IO),
+ (
+ Aditi = no,
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: compilation of Aditi procedures\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" requires the `--aditi' option.\n", !IO),
+ io__set_exit_status(1, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ Aditi = yes,
+ % There are Aditi procedures - enable Aditi code generation.
+ module_info_set_do_aditi_compilation(!ModuleInfo)
+ ).
+
+:- pred add_promise_clause(promise_type::in, list(term(prog_var_type))::in,
+ prog_varset::in, goal::in, prog_context::in, import_status::in,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ io::di, io::uo) is det.
+
+add_promise_clause(PromiseType, HeadVars, VarSet, Goal, Context, Status,
+ !ModuleInfo, !QualInfo, !IO) :-
+ term__context_line(Context, Line),
+ term__context_file(Context, File),
+ string__format(prog_out__promise_to_string(PromiseType) ++
+ "__%d__%s", [i(Line), s(File)], Name),
+ %
+ % Promise declarations are recorded as a predicate with a
+ % goal_type of promise(X), where X is of promise_type. This
+ % allows us to leverage off all the other checks in the
+ % compiler that operate on predicates.
+ %
+ % :- promise all [A,B,R] ( R = A + B <=> R = B + A ).
+ %
+ % becomes
+ %
+ % promise__lineno_filename(A, B, R) :-
+ % ( R = A + B <=> R = B + A ).
+ %
+ GoalType = promise(PromiseType) ,
+ module_info_name(!.ModuleInfo, ModuleName),
+ module_add_clause(VarSet, predicate, qualified(ModuleName, Name),
+ HeadVars, Goal, Status, Context, GoalType, !ModuleInfo, !QualInfo, !IO).
+
+add_stratified_pred(PragmaName, Name, Arity, Context, !ModuleInfo, !IO) :-
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
+ (
+ predicate_table_search_sym_arity(PredTable0, is_fully_qualified,
+ Name, Arity, PredIds)
+ ->
+ module_info_stratified_preds(!.ModuleInfo, StratPredIds0),
+ set__insert_list(StratPredIds0, PredIds, StratPredIds),
+ module_info_set_stratified_preds(StratPredIds, !ModuleInfo)
+ ;
+ string__append_list(["`:- pragma ", PragmaName, "' declaration"],
+ Description),
+ undefined_pred_or_func_error(Name, Arity, Context, Description, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+add_pred_marker(PragmaName, Name, Arity, Status, Context, Marker,
+ ConflictMarkers, !ModuleInfo, !IO) :-
+ ( marker_must_be_exported(Marker) ->
+ MustBeExported = yes
+ ;
+ MustBeExported = no
+ ),
+ do_add_pred_marker(PragmaName, Name, Arity, Status, MustBeExported,
+ Context, add_marker_pred_info(Marker), !ModuleInfo, PredIds, !IO),
+ module_info_preds(!.ModuleInfo, Preds),
+ pragma_check_markers(Preds, PredIds, ConflictMarkers, Conflict),
+ (
+ Conflict = yes,
+ pragma_conflict_error(Name, Arity, Context, PragmaName, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ Conflict = no
+ ).
+
+do_add_pred_marker(PragmaName, Name, Arity, Status, MustBeExported, Context,
+ UpdatePredInfo, !ModuleInfo, PredIds, !IO) :-
+ ( get_matching_pred_ids(!.ModuleInfo, Name, Arity, PredIds0) ->
+ PredIds = PredIds0,
+ module_info_get_predicate_table(!.ModuleInfo, PredTable0),
+ predicate_table_get_preds(PredTable0, Preds0),
+
+ pragma_add_marker(PredIds, UpdatePredInfo, Status,
+ MustBeExported, Preds0, Preds, WrongStatus),
+ (
+ WrongStatus = yes,
+ pragma_status_error(Name, Arity, Context, PragmaName,
+ !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ WrongStatus = no
+ ),
+
+ predicate_table_set_preds(Preds, PredTable0, PredTable),
+ module_info_set_predicate_table(PredTable, !ModuleInfo)
+ ;
+ PredIds = [],
+ string__append_list(["`:- pragma ", PragmaName, "' declaration"],
+ Description),
+ undefined_pred_or_func_error(Name, Arity, Context, Description, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ).
+
+:- pred get_matching_pred_ids(module_info::in, sym_name::in, arity::in,
+ list(pred_id)::out) is semidet.
+
+get_matching_pred_ids(Module0, Name, Arity, PredIds) :-
+ module_info_get_predicate_table(Module0, PredTable0),
+ % check that the pragma is module qualified.
+ (
+ Name = unqualified(_),
+ error("get_matching_pred_ids: unqualified name")
+ ;
+ Name = qualified(_, _),
+ predicate_table_search_sym_arity(PredTable0, is_fully_qualified,
+ Name, Arity, PredIds)
+ ).
+
+module_mark_as_external(PredName, Arity, Context, !ModuleInfo, !IO) :-
+ % `external' declarations can only apply to things defined
+ % in this module, since everything else is already external.
+ module_info_get_predicate_table(!.ModuleInfo, PredicateTable0),
+ (
+ predicate_table_search_sym_arity(PredicateTable0, is_fully_qualified,
+ PredName, Arity, PredIdList)
+ ->
+ module_mark_preds_as_external(PredIdList, !ModuleInfo)
+ ;
+ undefined_pred_or_func_error(PredName, Arity, Context,
+ "`:- external' declaration", !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ).
+
+:- pred module_mark_preds_as_external(list(pred_id)::in,
+ module_info::in, module_info::out) is det.
+
+module_mark_preds_as_external([], !ModuleInfo).
+module_mark_preds_as_external([PredId | PredIds], !ModuleInfo) :-
+ module_info_preds(!.ModuleInfo, Preds0),
+ map__lookup(Preds0, PredId, PredInfo0),
+ pred_info_mark_as_external(PredInfo0, PredInfo),
+ map__det_update(Preds0, PredId, PredInfo, Preds),
+ module_info_set_preds(Preds, !ModuleInfo),
+ module_mark_preds_as_external(PredIds, !ModuleInfo).
+
+ % For each pred_id in the list, check whether markers present in the list
+ % of conflicting markers are also present in the corresponding pred_info.
+ % The bool indicates whether there was a conflicting marker present.
+ %
+:- pred pragma_check_markers(pred_table::in, list(pred_id)::in,
+ list(marker)::in, bool::out) is det.
+
+pragma_check_markers(_, [], _, no).
+pragma_check_markers(PredTable, [PredId | PredIds], ConflictList,
+ WasConflict) :-
+ map__lookup(PredTable, PredId, PredInfo),
+ pred_info_get_markers(PredInfo, Markers),
+ (
+ list__member(Marker, ConflictList),
+ check_marker(Markers, Marker)
+ ->
+ WasConflict = yes
+ ;
+ pragma_check_markers(PredTable, PredIds, ConflictList, WasConflict)
+ ).
+
+ % For each pred_id in the list, add the given markers to the
+ % list of markers in the corresponding pred_info.
+ %
+:- pred pragma_add_marker(list(pred_id)::in,
+ add_marker_pred_info::in(add_marker_pred_info), import_status::in,
+ bool::in, pred_table::in, pred_table::out, bool::out) is det.
+
+pragma_add_marker([], _, _, _, !PredTable, no).
+pragma_add_marker([PredId | PredIds], UpdatePredInfo, Status, MustBeExported,
+ !PredTable, WrongStatus) :-
+ map__lookup(!.PredTable, PredId, PredInfo0),
+ call(UpdatePredInfo, PredInfo0, PredInfo),
+ (
+ pred_info_is_exported(PredInfo),
+ MustBeExported = yes,
+ Status \= exported
+ ->
+ WrongStatus0 = yes
+ ;
+ WrongStatus0 = no
+ ),
+ map__det_update(!.PredTable, PredId, PredInfo, !:PredTable),
+ pragma_add_marker(PredIds, UpdatePredInfo, Status,
+ MustBeExported, !PredTable, WrongStatus1),
+ bool__or(WrongStatus0, WrongStatus1, WrongStatus).
+
+:- pred add_marker_pred_info(marker::in, pred_info::in, pred_info::out)
+ is det.
+
+add_marker_pred_info(Marker, !PredInfo) :-
+ pred_info_get_markers(!.PredInfo, Markers0),
+ add_marker(Marker, Markers0, Markers),
+ pred_info_set_markers(Markers, !PredInfo).
+
+ % Succeed if a marker for an exported procedure must also be exported.
+ %
+:- pred marker_must_be_exported(marker::in) is semidet.
+
+marker_must_be_exported(aditi).
+marker_must_be_exported(base_relation).
+
+maybe_check_field_access_function(FuncName, FuncArity, Status, Context,
+ Module, !IO) :-
+ (
+ is_field_access_function_name(Module, FuncName, FuncArity,
+ AccessType, FieldName)
+ ->
+ check_field_access_function(AccessType, FieldName, FuncName,
+ FuncArity, Status, Context, Module, !IO)
+ ;
+ true
+ ).
+
+:- pred check_field_access_function(field_access_type::in, ctor_field_name::in,
+ sym_name::in, arity::in, import_status::in, prog_context::in,
+ module_info::in, io::di, io::uo) is det.
+
+check_field_access_function(_AccessType, FieldName, FuncName, FuncArity,
+ FuncStatus, Context, Module, !IO) :-
+ adjust_func_arity(function, FuncArity, PredArity),
+ FuncCallId = function - FuncName/PredArity,
+
+ %
+ % Check that a function applied to an exported type
+ % is also exported.
+ %
+ module_info_ctor_field_table(Module, CtorFieldTable),
+ (
+ % Abstract types have status `abstract_exported',
+ % so errors won't be reported for local field
+ % access functions for them.
+ map__search(CtorFieldTable, FieldName, [FieldDefn]),
+ FieldDefn = hlds_ctor_field_defn(_, DefnStatus, _, _, _),
+ DefnStatus = exported, FuncStatus \= exported
+ ->
+ report_field_status_mismatch(Context, FuncCallId, !IO)
+ ;
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- pred report_field_status_mismatch(prog_context::in, simple_call_id::in,
+ io::di, io::uo) is det.
+
+report_field_status_mismatch(Context, CallId, !IO) :-
+ CallIdString = hlds_out__simple_call_id_to_string(CallId),
+ ErrorPieces = [
+ words("In declaration of"),
+ fixed(string__append(CallIdString, ":")),
+ nl,
+ words("error: a field access function for an"),
+ words("exported field must also be exported.")
+ ],
+ error_util__write_error_pieces(Context, 0, ErrorPieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- pred report_unexpected_decl(string::in, prog_context::in,
+ io::di, io::uo) is det.
+
+report_unexpected_decl(Descr, Context, !IO) :-
+ Pieces = [words("Error: unexpected or incorrect"),
+ words("`" ++ Descr ++ "' declaration.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- pred pragma_status_error(sym_name::in, int::in, prog_context::in,
+ string::in, io::di, io::uo) is det.
+
+pragma_status_error(Name, Arity, Context, PragmaName, !IO) :-
+ Pieces = [words("Error: `:- pragma " ++ PragmaName ++ "'"),
+ words("declaration for exported predicate or function"),
+ sym_name_and_arity(Name / Arity),
+ words("must also be exported.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- pred pragma_conflict_error(sym_name::in, int::in, prog_context::in,
+ string::in, io::di, io::uo) is det.
+
+pragma_conflict_error(Name, Arity, Context, PragmaName, !IO) :-
+ Pieces = [words("Error: `:- pragma " ++ PragmaName ++ "'"),
+ words("declaration conflicts with previous pragma for"),
+ sym_name_and_arity(Name / Arity), suffix(".")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+:- func this_file = string.
+
+this_file = "make_hlds_passes.m".
+
+%-----------------------------------------------------------------------------%
Index: compiler/make_hlds_warn.m
===================================================================
RCS file: compiler/make_hlds_warn.m
diff -N compiler/make_hlds_warn.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/make_hlds_warn.m 25 Jul 2005 08:47:03 -0000
@@ -0,0 +1,730 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1993-2005 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.
+%-----------------------------------------------------------------------------%
+%
+% Generate whatever warnings the module being transformed to HLDS deserves.
+
+:- module hlds__make_hlds__make_hlds_warn.
+:- interface.
+
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__quantification.
+:- import_module libs__globals.
+:- import_module parse_tree__prog_data.
+
+:- import_module io.
+:- import_module list.
+:- import_module std_util.
+
+ % Warn about variables which occur only once but don't start with
+ % an underscore, or about variables which do start with an underscore
+ % but occur more than once.
+ %
+:- pred maybe_warn_overlap(list(quant_warning)::in, prog_varset::in,
+ simple_call_id::in, io::di, io::uo) is det.
+
+ % Warn about variables which occur only once but don't start with
+ % an underscore, or about variables which do start with an underscore
+ % but occur more than once, or about variables that do not occur in
+ % C code strings when they should.
+ %
+:- pred maybe_warn_singletons(prog_varset::in, simple_call_id::in,
+ module_info::in, hlds_goal::in, io::di, io::uo) is det.
+
+:- pred maybe_warn_pragma_singletons(pragma_foreign_code_impl::in,
+ foreign_language::in, list(maybe(pair(string, mode)))::in,
+ prog_context::in, simple_call_id::in, module_info::in,
+ io::di, io::uo) is det.
+
+ % Perform above checks on a promise ex declaration.
+ %
+:- pred check_promise_ex_decl(prog_vars::in, promise_type::in, goal::in,
+ prog_context::in, io::di, io::uo) is det.
+
+ % Check that clauses are not exported.
+ %
+:- pred check_not_exported(import_status::in, prog_context::in, string::in,
+ io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module check_hlds__mode_util.
+:- import_module libs__options.
+:- import_module hlds__goal_util.
+:- import_module hlds__hlds_out.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__mercury_to_mercury.
+:- import_module parse_tree__prog_out.
+
+:- import_module bool.
+:- import_module char.
+:- import_module set.
+:- import_module string.
+:- import_module varset.
+
+maybe_warn_overlap(Warnings, VarSet, PredCallId, !IO) :-
+ globals__io_lookup_bool_option(warn_overlapping_scopes,
+ WarnOverlappingScopes, !IO),
+ (
+ WarnOverlappingScopes = yes,
+ warn_overlap(Warnings, VarSet, PredCallId, !IO)
+ ;
+ WarnOverlappingScopes = no
+ ).
+
+:- pred warn_overlap(list(quant_warning)::in, prog_varset::in,
+ simple_call_id::in, io::di, io::uo) is det.
+
+warn_overlap([], _, _, !IO).
+warn_overlap([Warn | Warns], VarSet, PredCallId, !IO) :-
+ Warn = warn_overlap(Vars, Context),
+ Part1 = [words("In clause for"),
+ words(simple_call_id_to_string(PredCallId)), suffix(":"), nl],
+ ( Vars = [Var] ->
+ Part2 = [words("warning: variable"),
+ words("`" ++ mercury_var_to_string(Var, VarSet, no) ++ "'"),
+ words("has overlapping scopes.")]
+ ;
+ Part2 = [words("warning: variables"),
+ words("`" ++ mercury_vars_to_string(Vars, VarSet, no) ++ "'"),
+ words("each have overlapping scopes.")]
+ ),
+ write_error_pieces(Context, 0, Part1 ++ Part2, !IO),
+ record_warning(!IO),
+ warn_overlap(Warns, VarSet, PredCallId, !IO).
+
+%-----------------------------------------------------------------------------%
+
+maybe_warn_singletons(VarSet, PredCallId, ModuleInfo, Body, !IO) :-
+ globals__io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars,
+ !IO),
+ (
+ WarnSingletonVars = yes,
+ set__init(QuantVars),
+ warn_singletons_in_goal(Body, QuantVars, VarSet, PredCallId,
+ ModuleInfo, !IO)
+ ;
+ WarnSingletonVars = no
+ ).
+
+:- pred warn_singletons_in_goal(hlds_goal::in, set(prog_var)::in,
+ prog_varset::in, simple_call_id::in, module_info::in,
+ io::di, io::uo) is det.
+
+warn_singletons_in_goal(Goal - GoalInfo, QuantVars, VarSet, PredCallId, MI,
+ !IO) :-
+ warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet,
+ PredCallId, MI, !IO).
+
+:- pred warn_singletons_in_goal_2(hlds_goal_expr::in, hlds_goal_info::in,
+ set(prog_var)::in, prog_varset::in, simple_call_id::in,
+ module_info::in, io::di, io::uo) is det.
+
+warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = conj(Goals),
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI,
+ !IO).
+warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = par_conj(Goals),
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI,
+ !IO).
+warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = disj(Goals),
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, PredCallId, MI, !IO).
+warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = switch(_Var, _CanFail, Cases),
+ warn_singletons_in_cases(Cases, QuantVars, VarSet, PredCallId, MI, !IO).
+warn_singletons_in_goal_2(Goal, _GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = not(SubGoal),
+ warn_singletons_in_goal(SubGoal, QuantVars, VarSet, PredCallId, MI, !IO).
+warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = scope(Reason, SubGoal),
+ %
+ % warn if any quantified variables occur only in the quantifier
+ %
+ (
+ ( Reason = exist_quant(Vars)
+ ; Reason = promise_equivalent_solutions(Vars)
+ ),
+ Vars = [_ | _]
+ ->
+ quantification__goal_vars(SubGoal, SubGoalVars),
+ goal_info_get_context(GoalInfo, Context),
+ set__init(EmptySet),
+ warn_singletons(Vars, GoalInfo, EmptySet, SubGoalVars, VarSet,
+ Context, PredCallId, !IO),
+ set__insert_list(QuantVars, Vars, SubQuantVars)
+ ;
+ SubQuantVars = QuantVars
+ ),
+ warn_singletons_in_goal(SubGoal, SubQuantVars, VarSet, PredCallId, MI,
+ !IO).
+warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = if_then_else(Vars, Cond, Then, Else),
+ %
+ % warn if any quantified variables do not occur in the condition
+ % or the "then" part of the if-then-else
+ %
+ (
+ Vars = [_ | _],
+ quantification__goal_vars(Cond, CondVars),
+ quantification__goal_vars(Then, ThenVars),
+ set__union(CondVars, ThenVars, CondThenVars),
+ goal_info_get_context(GoalInfo, Context),
+ set__init(EmptySet),
+ warn_singletons(Vars, GoalInfo, EmptySet, CondThenVars, VarSet,
+ Context, PredCallId, !IO)
+ ;
+ Vars = []
+ ),
+ set__insert_list(QuantVars, Vars, QuantVars1),
+ warn_singletons_in_goal(Cond, QuantVars1, VarSet, PredCallId, MI, !IO),
+ warn_singletons_in_goal(Then, QuantVars1, VarSet, PredCallId, MI, !IO),
+ warn_singletons_in_goal(Else, QuantVars, VarSet, PredCallId, MI, !IO).
+warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
+ _, !IO) :-
+ Goal = call(_, _, Args, _, _, _),
+ goal_info_get_nonlocals(GoalInfo, NonLocals),
+ goal_info_get_context(GoalInfo, Context),
+ warn_singletons(Args, GoalInfo, NonLocals, QuantVars, VarSet, Context,
+ PredCallId, !IO).
+warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
+ _, !IO) :-
+ Goal = generic_call(GenericCall, Args0, _, _),
+ goal_util__generic_call_vars(GenericCall, Args1),
+ list__append(Args0, Args1, Args),
+ goal_info_get_nonlocals(GoalInfo, NonLocals),
+ goal_info_get_context(GoalInfo, Context),
+ warn_singletons(Args, GoalInfo, NonLocals, QuantVars, VarSet, Context,
+ PredCallId, !IO).
+warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = unify(Var, RHS, _, _, _),
+ warn_singletons_in_unify(Var, RHS, GoalInfo, QuantVars, VarSet,
+ PredCallId, MI, !IO).
+warn_singletons_in_goal_2(Goal, GoalInfo, _QuantVars, _VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = foreign_proc(Attrs, _, _, Args, _, PragmaImpl),
+ goal_info_get_context(GoalInfo, Context),
+ Lang = foreign_language(Attrs),
+ NamesModes = list__map(foreign_arg_maybe_name_mode, Args),
+ warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang,
+ NamesModes, Context, PredCallId, MI, !IO).
+warn_singletons_in_goal_2(Goal, GoalInfo, QuantVars, VarSet, PredCallId,
+ MI, !IO) :-
+ Goal = shorthand(ShorthandGoal),
+ warn_singletons_in_goal_2_shorthand(ShorthandGoal, GoalInfo,
+ QuantVars, VarSet, PredCallId, MI, !IO).
+
+:- pred warn_singletons_in_goal_2_shorthand(shorthand_goal_expr::in,
+ hlds_goal_info::in, set(prog_var)::in, prog_varset::in,
+ simple_call_id::in, module_info::in, io::di, io::uo) is det.
+
+warn_singletons_in_goal_2_shorthand(bi_implication(LHS, RHS), _GoalInfo,
+ QuantVars, VarSet, PredCallId, MI, !IO) :-
+ warn_singletons_in_goal_list([LHS, RHS], QuantVars, VarSet,
+ PredCallId, MI, !IO).
+
+:- pred warn_singletons_in_goal_list(list(hlds_goal)::in, set(prog_var)::in,
+ prog_varset::in, simple_call_id::in, module_info::in,
+ io::di, io::uo) is det.
+
+warn_singletons_in_goal_list([], _, _, _, _, !IO).
+warn_singletons_in_goal_list([Goal | Goals], QuantVars, VarSet, CallPredId,
+ MI, !IO) :-
+ warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI, !IO),
+ warn_singletons_in_goal_list(Goals, QuantVars, VarSet, CallPredId, MI,
+ !IO).
+
+:- pred warn_singletons_in_cases(list(case)::in, set(prog_var)::in,
+ prog_varset::in, simple_call_id::in, module_info::in,
+ io::di, io::uo) is det.
+
+warn_singletons_in_cases([], _, _, _, _, !IO).
+warn_singletons_in_cases([Case | Cases], QuantVars, VarSet, CallPredId, MI,
+ !IO) :-
+ Case = case(_ConsId, Goal),
+ warn_singletons_in_goal(Goal, QuantVars, VarSet, CallPredId, MI, !IO),
+ warn_singletons_in_cases(Cases, QuantVars, VarSet, CallPredId, MI, !IO).
+
+:- pred warn_singletons_in_unify(prog_var::in, unify_rhs::in,
+ hlds_goal_info::in, set(prog_var)::in, prog_varset::in,
+ simple_call_id::in, module_info::in, io::di, io::uo) is det.
+
+warn_singletons_in_unify(X, var(Y), GoalInfo, QuantVars, VarSet, CallPredId, _,
+ !IO) :-
+ goal_info_get_nonlocals(GoalInfo, NonLocals),
+ goal_info_get_context(GoalInfo, Context),
+ warn_singletons([X, Y], GoalInfo, NonLocals, QuantVars, VarSet,
+ Context, CallPredId, !IO).
+warn_singletons_in_unify(X, functor(_ConsId, _, Vars), GoalInfo,
+ QuantVars, VarSet, CallPredId, _, !IO) :-
+ goal_info_get_nonlocals(GoalInfo, NonLocals),
+ goal_info_get_context(GoalInfo, Context),
+ warn_singletons([X | Vars], GoalInfo, NonLocals, QuantVars, VarSet,
+ Context, CallPredId, !IO).
+warn_singletons_in_unify(X, lambda_goal(_Purity, _PredOrFunc, _Eval, _Fix,
+ _NonLocals, LambdaVars, _Modes, _Det, LambdaGoal),
+ GoalInfo, QuantVars, VarSet, CallPredId, MI, !IO) :-
+ %
+ % warn if any lambda-quantified variables occur only in the quantifier
+ %
+ LambdaGoal = _ - LambdaGoalInfo,
+ goal_info_get_nonlocals(LambdaGoalInfo, LambdaNonLocals),
+ goal_info_get_context(GoalInfo, Context),
+ warn_singletons(LambdaVars, GoalInfo, LambdaNonLocals, QuantVars,
+ VarSet, Context, CallPredId, !IO),
+
+ %
+ % warn if X (the variable we're unifying the lambda expression with)
+ % is singleton
+ %
+ goal_info_get_nonlocals(GoalInfo, NonLocals),
+ warn_singletons([X], GoalInfo, NonLocals, QuantVars, VarSet, Context,
+ CallPredId, !IO),
+ % Warn if the lambda-goal contains singletons.
+ warn_singletons_in_goal(LambdaGoal, QuantVars, VarSet, CallPredId, MI, !IO).
+
+%-----------------------------------------------------------------------------%
+
+maybe_warn_pragma_singletons(PragmaImpl, Lang, ArgInfo, Context, CallId, MI,
+ !IO) :-
+ globals__io_lookup_bool_option(warn_singleton_vars, WarnSingletonVars,
+ !IO),
+ ( WarnSingletonVars = yes ->
+ warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang,
+ ArgInfo, Context, CallId, MI, !IO)
+ ;
+ true
+ ).
+
+ % warn_singletons_in_pragma_foreign_proc checks to see if each variable
+ % is mentioned at least once in the foreign code fragments that ought to
+ % mention it. If not, it gives a warning.
+ %
+ % (Note that for some foreign languages it might not be appropriate
+ % to do this check, or you may need to add a transformation to map
+ % Mercury variable names into identifiers for that foreign language).
+ %
+:- pred warn_singletons_in_pragma_foreign_proc(pragma_foreign_code_impl::in,
+ foreign_language::in, list(maybe(pair(string, mode)))::in,
+ prog_context::in, simple_call_id::in, module_info::in,
+ io::di, io::uo) is det.
+
+warn_singletons_in_pragma_foreign_proc(PragmaImpl, Lang, Args, Context,
+ PredOrFuncCallId, ModuleInfo, !IO) :-
+ LangStr = foreign_language_string(Lang),
+ (
+ PragmaImpl = ordinary(C_Code, _),
+ c_code_to_name_list(C_Code, C_CodeList),
+ Filter = (pred(Name::out) is nondet :-
+ list__member(yes(Name - _), Args),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, C_CodeList)
+ ),
+ solutions(Filter, UnmentionedVars),
+ (
+ UnmentionedVars = []
+ ;
+ UnmentionedVars = [_ | _],
+ prog_out__write_context(Context, !IO),
+ io__write_string("In the " ++ LangStr ++ " code for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ write_variable_warning_start(UnmentionedVars, !IO),
+ io__write_string("not occur in the " ++ LangStr ++ " code.\n", !IO)
+ )
+ ;
+ PragmaImpl = nondet(_, _, FirstCode, _, LaterCode, _, _, SharedCode,
+ _),
+ c_code_to_name_list(FirstCode, FirstCodeList),
+ c_code_to_name_list(LaterCode, LaterCodeList),
+ c_code_to_name_list(SharedCode, SharedCodeList),
+ InputFilter = (pred(Name::out) is nondet :-
+ list__member(yes(Name - Mode), Args),
+ mode_is_input(ModuleInfo, Mode),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, FirstCodeList)
+ ),
+ solutions(InputFilter, UnmentionedInputVars),
+ ( UnmentionedInputVars = [] ->
+ true
+ ;
+ prog_out__write_context(Context, !IO),
+ io__write_string("In the " ++ LangStr ++ " code for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ write_variable_warning_start(UnmentionedInputVars, !IO),
+ io__write_string("not occur in the first " ++
+ LangStr ++ " code.\n ", !IO)
+ ),
+ FirstOutputFilter = (pred(Name::out) is nondet :-
+ list__member(yes(Name - Mode), Args),
+ mode_is_output(ModuleInfo, Mode),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, FirstCodeList),
+ \+ list__member(Name, SharedCodeList)
+ ),
+ solutions(FirstOutputFilter, UnmentionedFirstOutputVars),
+ (
+ UnmentionedFirstOutputVars = []
+ ;
+ UnmentionedFirstOutputVars = [_ | _],
+ prog_out__write_context(Context, !IO),
+ io__write_string("In the " ++ LangStr ++ " code for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ write_variable_warning_start(UnmentionedFirstOutputVars, !IO),
+ io__write_string("not occur in the first " ++ LangStr ++
+ " code or the shared " ++ LangStr ++ " code.\n ", !IO)
+ ),
+ LaterOutputFilter = (pred(Name::out) is nondet :-
+ list__member(yes(Name - Mode), Args),
+ mode_is_output(ModuleInfo, Mode),
+ \+ string__prefix(Name, "_"),
+ \+ list__member(Name, LaterCodeList),
+ \+ list__member(Name, SharedCodeList)
+ ),
+ solutions(LaterOutputFilter, UnmentionedLaterOutputVars),
+ (
+ UnmentionedLaterOutputVars = []
+ ;
+ UnmentionedLaterOutputVars = [_ | _],
+ prog_out__write_context(Context, !IO),
+ io__write_string("In the " ++ LangStr ++ " code for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ write_variable_warning_start(UnmentionedLaterOutputVars, !IO),
+ io__write_string("not occur in the retry " ++ LangStr ++
+ " code or the shared " ++ LangStr ++ " code.\n ", !IO)
+ )
+ ;
+ PragmaImpl = import(_, _, _, _)
+ ).
+
+:- pred write_variable_warning_start(list(string)::in, io::di, io::uo) is det.
+
+write_variable_warning_start(UnmentionedVars, !IO) :-
+ ( UnmentionedVars = [_] ->
+ io__write_string(" warning: variable `", !IO),
+ write_string_list(UnmentionedVars, !IO),
+ io__write_string("' does ", !IO)
+ ;
+ io__write_string(" warning: variables `", !IO),
+ write_string_list(UnmentionedVars, !IO),
+ io__write_string("' do ", !IO)
+ ).
+
+ % c_code_to_name_list(Code, List) is true iff List is a list of the
+ % identifiers used in the C code in Code.
+ %
+:- pred c_code_to_name_list(string::in, list(string)::out) is det.
+
+c_code_to_name_list(Code, List) :-
+ string__to_char_list(Code, CharList),
+ c_code_to_name_list_2(CharList, List).
+
+:- pred c_code_to_name_list_2(list(char)::in, list(string)::out) is det.
+
+c_code_to_name_list_2(C_Code, List) :-
+ get_first_c_name(C_Code, NameCharList, TheRest),
+ (
+ NameCharList = [],
+ % no names left
+ List = []
+ ;
+ NameCharList = [_ | _],
+ c_code_to_name_list_2(TheRest, Names),
+ string__from_char_list(NameCharList, Name),
+ List = [Name | Names]
+ ).
+
+:- pred get_first_c_name(list(char)::in, list(char)::out, list(char)::out)
+ is det.
+
+get_first_c_name([], [], []).
+get_first_c_name([C | CodeChars], NameCharList, TheRest) :-
+ ( char__is_alnum_or_underscore(C) ->
+ get_first_c_name_in_word(CodeChars, NameCharList0, TheRest),
+ NameCharList = [C | NameCharList0]
+ ;
+ % strip off any characters in the C code which
+ % don't form part of an identifier.
+ get_first_c_name(CodeChars, NameCharList, TheRest)
+ ).
+
+:- pred get_first_c_name_in_word(list(char)::in, list(char)::out,
+ list(char)::out) is det.
+
+get_first_c_name_in_word([], [], []).
+get_first_c_name_in_word([C | CodeChars], NameCharList, TheRest) :-
+ ( char__is_alnum_or_underscore(C) ->
+ % There are more characters in the word
+ get_first_c_name_in_word(CodeChars, NameCharList0, TheRest),
+ NameCharList = [C|NameCharList0]
+ ;
+ % The word is finished
+ NameCharList = [],
+ TheRest = CodeChars
+ ).
+
+:- pred generate_singleton_vars(list(prog_var)::in, set(prog_var)::in,
+ set(prog_var)::in, prog_varset::in, prog_var::out) is nondet.
+
+generate_singleton_vars(GoalVars, NonLocals, QuantVars, VarSet, Var) :-
+ list__member(Var, GoalVars),
+ \+ set__member(Var, NonLocals),
+ varset__search_name(VarSet, Var, Name),
+ \+ string__prefix(Name, "_"),
+ \+ string__prefix(Name, "DCG_"),
+ \+ (
+ set__member(QuantVar, QuantVars),
+ varset__search_name(VarSet, QuantVar, Name)
+ ).
+
+:- pred generate_multi_vars(list(prog_var)::in, set(prog_var)::in,
+ prog_varset::in, prog_var::out) is nondet.
+
+generate_multi_vars(GoalVars, NonLocals, VarSet, Var) :-
+ list__member(Var, GoalVars),
+ set__member(Var, NonLocals),
+ varset__search_name(VarSet, Var, Name),
+ string__prefix(Name, "_").
+
+ % warn_singletons(Vars, GoalInfo, NonLocals, QuantVars, ...):
+ %
+ % Warn if any of the non-underscore variables in Vars don't occur in
+ % NonLocals and don't have the same name as any variable in QuantVars,
+ % or if any of the underscore variables in Vars do occur in NonLocals.
+ % Omit the warning if GoalInfo says we should.
+ %
+:- pred warn_singletons(list(prog_var)::in, hlds_goal_info::in,
+ set(prog_var)::in, set(prog_var)::in, prog_varset::in,
+ prog_context::in, simple_call_id::in, io::di, io::uo) is det.
+
+warn_singletons(GoalVars, GoalInfo, NonLocals, QuantVars, VarSet, Context,
+ PredOrFuncCallId, !IO) :-
+ % Find all the variables in the goal that don't occur outside the goal
+ % (i.e. are singleton), have a variable name that doesn't start with "_"
+ % or "DCG_", and don't have the same name as any variable in QuantVars
+ % (i.e. weren't explicitly quantified).
+
+ solutions(generate_singleton_vars(GoalVars, NonLocals, QuantVars, VarSet),
+ SingletonVars),
+
+ % if there were any such variables, issue a warning
+
+ (
+ (
+ SingletonVars = []
+ ;
+ goal_info_has_feature(GoalInfo, dont_warn_singleton)
+ )
+ ->
+ true
+ ;
+ prog_out__write_context(Context, !IO),
+ io__write_string("In clause for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ ( SingletonVars = [_] ->
+ io__write_string(" warning: variable `", !IO),
+ mercury_output_vars(SingletonVars, VarSet, no, !IO),
+ report_warning("' occurs only once in this scope.\n", !IO)
+ ;
+ io__write_string(" warning: variables `", !IO),
+ mercury_output_vars(SingletonVars, VarSet, no, !IO),
+ report_warning("' occur only once in this scope.\n", !IO)
+ )
+ ),
+
+ % Find all the variables in the goal that do occur outside the goal
+ % (i.e. are not singleton) and have a variable name that starts
+ % with "_". If there were any such variables, issue a warning.
+
+ solutions(generate_multi_vars(GoalVars, NonLocals, VarSet), MultiVars),
+ (
+ MultiVars = []
+ ;
+ MultiVars = [_ | _],
+ prog_out__write_context(Context, !IO),
+ io__write_string("In clause for ", !IO),
+ hlds_out__write_simple_call_id(PredOrFuncCallId, !IO),
+ io__write_string(":\n", !IO),
+ prog_out__write_context(Context, !IO),
+ ( MultiVars = [_] ->
+ io__write_string(" warning: variable `", !IO),
+ mercury_output_vars(MultiVars, VarSet, no, !IO),
+ report_warning("' occurs more than once in this scope.\n", !IO)
+ ;
+ io__write_string(" warning: variables `", !IO),
+ mercury_output_vars(MultiVars, VarSet, no, !IO),
+ report_warning("' occur more than once in this scope.\n", !IO)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Promise_ex error checking.
+%
+% The following predicates are used to perform extra error checking specific
+% to promise ex declarations (see notes/promise_ex.html). Currently, the
+% following checks are performed:
+%
+% - check for universally quantified variables
+% - check if universal quantification is placed in the wrong position
+% (i.e. after the `promise_exclusive' rather than before it)
+% - check that its goal is a disjunction and that each arm of the
+% disjunction has at most one call, and otherwise has only unifications.
+
+check_promise_ex_decl(UnivVars, PromiseType, Goal, Context, !IO) :-
+ % are universally quantified variables present?
+ (
+ UnivVars = [],
+ promise_ex_error(PromiseType, Context,
+ "declaration has no universally quantified variables", !IO)
+ ;
+ UnivVars = [_ | _]
+ ),
+ check_promise_ex_goal(PromiseType, Goal, !IO).
+
+ % Check for misplaced universal quantification, otherwise find the
+ % disjunction, flatten it out into list form and perform further checks.
+ %
+:- pred check_promise_ex_goal(promise_type::in, goal::in, io::di, io::uo)
+ is det.
+
+check_promise_ex_goal(PromiseType, GoalExpr - Context, !IO) :-
+ ( GoalExpr = some(_, Goal) -> check_promise_ex_goal(PromiseType, Goal, !IO)
+ ; GoalExpr = ( _ ; _ ) ->
+ flatten_to_disj_list(GoalExpr - Context, DisjList),
+ list__map(flatten_to_conj_list, DisjList, DisjConjList),
+ check_disjunction(PromiseType, DisjConjList, !IO)
+ ; GoalExpr = all(_UnivVars, Goal) ->
+ promise_ex_error(PromiseType, Context,
+ "universal quantification should come before " ++
+ "the declaration name", !IO),
+ check_promise_ex_goal(PromiseType, Goal, !IO)
+ ;
+ promise_ex_error(PromiseType, Context,
+ "goal in declaration is not a disjunction", !IO)
+ ).
+
+ % Turns the goal of a promise_ex declaration into a list of goals,
+ % where each goal is an arm of the disjunction.
+ %
+:- pred flatten_to_disj_list(goal::in, goals::out) is det.
+
+flatten_to_disj_list(GoalExpr - Context, GoalList) :-
+ ( GoalExpr = ( GoalA ; GoalB ) ->
+ flatten_to_disj_list(GoalA, GoalListA),
+ flatten_to_disj_list(GoalB, GoalListB),
+ GoalList = GoalListA ++ GoalListB
+ ;
+ GoalList = [GoalExpr - Context]
+ ).
+
+ % Takes a goal representing an arm of a disjunction and turns it into
+ % a list of conjunct goals.
+ %
+:- pred flatten_to_conj_list(goal::in, goals::out) is det.
+
+flatten_to_conj_list(GoalExpr - Context, GoalList) :-
+ ( GoalExpr = ( GoalA , GoalB ) ->
+ flatten_to_conj_list(GoalA, GoalListA),
+ flatten_to_conj_list(GoalB, GoalListB),
+ GoalList = GoalListA ++ GoalListB
+ ;
+ GoalList = [GoalExpr - Context]
+ ).
+
+ % Taking a list of arms of the disjunction, check each arm individually.
+ %
+:- pred check_disjunction(promise_type::in, list(goals)::in, io::di, io::uo)
+ is det.
+
+check_disjunction(PromiseType, DisjConjList, !IO) :-
+ (
+ DisjConjList = []
+ ;
+ DisjConjList = [ConjList | Rest],
+ check_disj_arm(PromiseType, ConjList, no, !IO),
+ check_disjunction(PromiseType, Rest, !IO)
+ ).
+
+ % Only one goal in an arm is allowed to be a call, the rest must be
+ % unifications.
+ %
+:- pred check_disj_arm(promise_type::in, goals::in, bool::in,
+ io::di, io::uo) is det.
+
+check_disj_arm(PromiseType, Goals, CallUsed, !IO) :-
+ (
+ Goals = []
+ ;
+ Goals = [GoalExpr - Context | Rest],
+ ( GoalExpr = unify(_, _, _) ->
+ check_disj_arm(PromiseType, Rest, CallUsed, !IO)
+ ; GoalExpr = some(_, Goal) ->
+ check_disj_arm(PromiseType, [Goal | Rest], CallUsed, !IO)
+ ; GoalExpr = call(_, _, _) ->
+ (
+ CallUsed = no
+ ;
+ CallUsed = yes,
+ promise_ex_error(PromiseType, Context,
+ "disjunct contains more than one call", !IO)
+ ),
+ check_disj_arm(PromiseType, Rest, yes, !IO)
+ ;
+ promise_ex_error(PromiseType, Context,
+ "disjunct is not a call or unification", !IO),
+ check_disj_arm(PromiseType, Rest, CallUsed, !IO)
+ )
+ ).
+
+ % Called for any error in the above checks.
+ %
+:- pred promise_ex_error(promise_type::in, prog_context::in, string::in,
+ io::di, io::uo) is det.
+
+promise_ex_error(PromiseType, Context, Message, !IO) :-
+ ErrorPieces = [
+ words("In"),
+ fixed("`" ++ prog_out__promise_to_string(PromiseType) ++ "'"),
+ words("declaration:"),
+ nl,
+ words("error:"),
+ words(Message)
+ ],
+ error_util__write_error_pieces(Context, 0, ErrorPieces, !IO).
+
+check_not_exported(Status, Context, Message, !IO) :-
+ ( Status = exported ->
+ prog_out__write_context(Context, !IO),
+ string__append_list(["Warning: ", Message, " in module interface.\n"],
+ WarningMessage),
+ report_warning(WarningMessage, !IO)
+ ;
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
Index: compiler/make_tags.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/make_tags.m,v
retrieving revision 1.45
diff -u -b -r1.45 make_tags.m
--- compiler/make_tags.m 22 Mar 2005 06:40:07 -0000 1.45
+++ compiler/make_tags.m 25 Apr 2005 14:44:49 -0000
@@ -7,50 +7,50 @@
% file: make_tags.m.
% main author: fjh.
- % This module is where we determine the representation for
- % discriminated union types. Each d.u. type is represented as
- % a word. In the case of functors with arguments, we allocate
- % the arguments on the heap, and the word contains a pointer to
- % those arguments.
- %
- % For types which are just enumerations (all the constructors
- % are constants), we just assign a different value for each
- % constructor.
- %
- % For types which have only one functor of arity one, there is
- % no need to store the functor, and we just store the argument
- % value directly; construction and deconstruction unifications
- % on these type are no-ops.
- %
- % For other types, we use a couple of bits of the word as a
- % tag. We split the constructors into constants and functors,
- % and assign tag zero to the constants (if any). If there is
- % more than one constant, we distinguish between the different
- % constants by the value of the rest of the word. Then we
- % assign one tag bit each to the first few functors. The
- % remaining functors all get the last remaining two-bit tag.
- % These functors are distinguished by a secondary tag which is
- % the first word of the argument vector for those functors.
- %
- % If there are no tag bits available, then we try using reserved
- % addresses (e.g. NULL, (void *)1, (void *)2, etc.) instead.
- % We split the constructors into constants and functors,
- % and assign numerical reserved addresses to the first constants,
- % up to the limit set by --num-reserved-addresses.
- % After that, for the MLDS back-end, we assign symbolic reserved
- % addresses to the remaining constants, up to the limit set by
- % --num-reserved-objects; these symbolic reserved addresses
- % are the addresses of global variables that we generate specially
- % for this purpose. Finally, the functors and any remaining
- % constants are distinguished by a secondary tag, if there are more
- % than one of them.
-
- % If there is a `pragma reserve_tag' declaration for the type,
- % or if the `--reserve-tag' option is set,
- % then we reserve the first primary tag (for representing
- % unbound variables). This is used by HAL, for Herbrand constraints
- % (i.e. Prolog-style logic variables).
- % This also disables enumerations and no_tag types.
+% This module is where we determine the representation for
+% discriminated union types. Each d.u. type is represented as
+% a word. In the case of functors with arguments, we allocate
+% the arguments on the heap, and the word contains a pointer to
+% those arguments.
+%
+% For types which are just enumerations (all the constructors
+% are constants), we just assign a different value for each
+% constructor.
+%
+% For types which have only one functor of arity one, there is
+% no need to store the functor, and we just store the argument
+% value directly; construction and deconstruction unifications
+% on these type are no-ops.
+%
+% For other types, we use a couple of bits of the word as a
+% tag. We split the constructors into constants and functors,
+% and assign tag zero to the constants (if any). If there is
+% more than one constant, we distinguish between the different
+% constants by the value of the rest of the word. Then we
+% assign one tag bit each to the first few functors. The
+% remaining functors all get the last remaining two-bit tag.
+% These functors are distinguished by a secondary tag which is
+% the first word of the argument vector for those functors.
+%
+% If there are no tag bits available, then we try using reserved
+% addresses (e.g. NULL, (void *)1, (void *)2, etc.) instead.
+% We split the constructors into constants and functors,
+% and assign numerical reserved addresses to the first constants,
+% up to the limit set by --num-reserved-addresses.
+% After that, for the MLDS back-end, we assign symbolic reserved
+% addresses to the remaining constants, up to the limit set by
+% --num-reserved-objects; these symbolic reserved addresses
+% are the addresses of global variables that we generate specially
+% for this purpose. Finally, the functors and any remaining
+% constants are distinguished by a secondary tag, if there are more
+% than one of them.
+%
+% If there is a `pragma reserve_tag' declaration for the type,
+% or if the `--reserve-tag' option is set,
+% then we reserve the first primary tag (for representing
+% unbound variables). This is used by HAL, for Herbrand constraints
+% (i.e. Prolog-style logic variables).
+% This also disables enumerations and no_tag types.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -96,8 +96,8 @@
assign_constructor_tags(Ctors, TypeCtor, ReservedTagPragma, Globals,
CtorTags, IsEnum) :-
- % work out how many tag bits and reserved addresses
- % we've got to play with
+ % Work out how many tag bits and reserved addresses
+ % we've got to play with.
globals__lookup_int_option(Globals, num_tag_bits, NumTagBits),
globals__lookup_int_option(Globals, num_reserved_addresses,
NumReservedAddresses),
@@ -105,8 +105,8 @@
NumReservedObjects),
globals__lookup_bool_option(Globals, highlevel_code, HighLevelCode),
- % determine if we need to reserve a tag for use by HAL's
- % Herbrand constraint solver
+ % Determine if we need to reserve a tag for use by HAL's
+ % Herbrand constraint solver.
% (This also disables enumerations and no_tag types.)
globals__lookup_bool_option(Globals, reserve_tag, GlobalReserveTag),
ReserveTag = GlobalReserveTag `or` ReservedTagPragma,
@@ -143,13 +143,14 @@
;
NumTagBits = 0
->
- ( ReserveTag = yes ->
+ (
+ ReserveTag = yes,
% XXX Need to fix this.
% This occurs for the .NET and Java backends
sorry("make_tags",
"--reserve-tag with num_tag_bits = 0")
;
- true
+ ReserveTag = no
),
% assign reserved addresses to the constants,
% if possible
@@ -157,13 +158,15 @@
assign_reserved_numeric_addresses(Constants,
LeftOverConstants0, CtorTags0, CtorTags1,
0, NumReservedAddresses),
- ( HighLevelCode = yes ->
+ (
+ HighLevelCode = yes,
assign_reserved_symbolic_addresses(
LeftOverConstants0,
LeftOverConstants, TypeCtor,
CtorTags1, CtorTags2,
0, NumReservedObjects)
;
+ HighLevelCode = no,
% reserved symbolic addresses are not
% supported for the LLDS back-end
LeftOverConstants = LeftOverConstants0,
@@ -258,9 +261,11 @@
% is more efficient.
assign_constant_tags(Constants, !CtorTags, InitTag, NextTag) :-
- ( Constants = [] ->
+ (
+ Constants = [],
NextTag = InitTag
;
+ Constants = [_ | _],
NextTag = InitTag + 1,
assign_shared_local_tags(Constants,
InitTag, 0, !CtorTags)
@@ -284,7 +289,7 @@
map__set(!.CtorTags, ConsId, Tag, !:CtorTags)
% if we're about to run out of unshared tags, start assigning
% shared remote tags instead
- ; Val = MaxTag, Rest \= [] ->
+ ; Val = MaxTag, Rest = [_ | _] ->
assign_shared_remote_tags([Ctor | Rest], MaxTag, 0,
ReservedAddresses, !CtorTags)
;
@@ -326,11 +331,13 @@
:- func maybe_add_reserved_addresses(list(reserved_address), cons_tag) =
cons_tag.
-maybe_add_reserved_addresses(ReservedAddresses, Tag) =
- ( ReservedAddresses = [] ->
- Tag
+maybe_add_reserved_addresses(ReservedAddresses, Tag0) = Tag :-
+ (
+ ReservedAddresses = [],
+ Tag = Tag0
;
- shared_with_reserved_addresses(ReservedAddresses, Tag)
+ ReservedAddresses = [_ | _],
+ Tag = shared_with_reserved_addresses(ReservedAddresses, Tag0)
).
%-----------------------------------------------------------------------------%
@@ -359,10 +366,12 @@
separate_out_constants([Ctor | Ctors], Constants, Functors) :-
separate_out_constants(Ctors, Constants0, Functors0),
Args = Ctor ^ cons_args,
- ( Args = [] ->
+ (
+ Args = [],
Constants = [Ctor | Constants0],
Functors = Functors0
;
+ Args = [_ | _],
Constants = Constants0,
Functors = [Ctor | Functors0]
).
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.336
diff -u -b -r1.336 mercury_compile.m
--- compiler/mercury_compile.m 11 Jul 2005 16:11:12 -0000 1.336
+++ compiler/mercury_compile.m 25 Jul 2005 04:03:53 -0000
@@ -1671,7 +1671,7 @@
%-----------------------------------------------------------------------------%
:- pred mercury_compile__pre_hlds_pass(module_imports::in, bool::in,
- module_info::out, qual_info::out, maybe(module_timestamps)::out,
+ module_info::out, make_hlds_qual_info::out, maybe(module_timestamps)::out,
bool::out, bool::out, bool::out, io::di, io::uo) is det.
mercury_compile__pre_hlds_pass(ModuleImports0, DontWriteDFile0, HLDS1,
@@ -1860,8 +1860,9 @@
maybe_report_stats(Stats, !IO).
:- pred mercury_compile__make_hlds(module_name::in, item_list::in, mq_info::in,
- eqv_map::in, bool::in, bool::in, module_info::out, qual_info::out,
- bool::out, bool::out, bool::out, io::di, io::uo) is det.
+ eqv_map::in, bool::in, bool::in, module_info::out,
+ make_hlds_qual_info::out, bool::out, bool::out, bool::out, io::di, io::uo)
+ is det.
mercury_compile__make_hlds(Module, Items, MQInfo, EqvMap, Verbose, Stats,
HLDS, QualInfo, UndefTypes, UndefModes, FoundSemanticError, !IO) :-
@@ -1887,8 +1888,8 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-:- pred mercury_compile__frontend_pass(qual_info::in, bool::in, bool::in,
- bool::in, bool::out, module_info::in, module_info::out,
+:- pred mercury_compile__frontend_pass(make_hlds_qual_info::in,
+ bool::in, bool::in, bool::in, bool::out, module_info::in, module_info::out,
io::di, io::uo) is det.
mercury_compile__frontend_pass(QualInfo0, FoundUndefTypeError,
@@ -1911,7 +1912,7 @@
check_typeclass__check_typeclasses(QualInfo0, QualInfo, !HLDS,
FoundTypeclassError, !IO),
mercury_compile__maybe_dump_hlds(!.HLDS, 5, "typeclass", !IO),
- make_hlds__set_module_recompilation_info(QualInfo, !HLDS),
+ set_module_recomp_info(QualInfo, !HLDS),
%
% We can't continue after a typeclass error, since typecheck
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.129
diff -u -b -r1.129 prog_data.m
--- compiler/prog_data.m 13 Jul 2005 11:41:45 -0000 1.129
+++ compiler/prog_data.m 21 Jul 2005 11:31:09 -0000
@@ -1392,6 +1392,8 @@
:- type type_ctor == pair(sym_name, arity).
+:- type tvar_name_map == map(string, tvar).
+
% existq_tvars is used to record the set of type variables which are
% existentially quantified
:- type existq_tvars == list(tvar).
Index: compiler/prog_mode.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_mode.m,v
retrieving revision 1.5
diff -u -b -r1.5 prog_mode.m
--- compiler/prog_mode.m 22 Mar 2005 06:40:20 -0000 1.5
+++ compiler/prog_mode.m 21 Jul 2005 12:35:55 -0000
@@ -19,6 +19,7 @@
% Construct a mode corresponding to the standard
% `in', `out', `uo' or `unused' mode.
+ %
:- pred in_mode((mode)::out) is det.
:- func in_mode = (mode).
:- func in_mode(inst) = (mode).
@@ -39,6 +40,7 @@
% Construct the modes used for `aditi__state' arguments.
% XXX These should be unique, but are not yet because that
% would require alias tracking.
+ %
:- func aditi_mui_mode = (mode).
:- func aditi_ui_mode = (mode).
:- func aditi_di_mode = (mode).
@@ -53,14 +55,15 @@
% iff Mode is the mode that results from substituting all
% occurrences of Params in Mode0 with the corresponding
% value in Args.
-
+ %
:- pred mode_substitute_arg_list((mode)::in, list(inst_var)::in,
list(inst)::in, (mode)::out) is det.
% inst_lists_to_mode_list(InitialInsts, FinalInsts, Modes):
- % Given two lists of corresponding initial and final
- % insts, return a list of modes which maps from the
- % initial insts to the final insts.
+ %
+ % Given two lists of corresponding initial and final insts, return
+ % a list of modes which maps from the initial insts to the final insts.
+ %
:- pred inst_lists_to_mode_list(list(inst)::in, list(inst)::in,
list(mode)::out) is det.
@@ -72,19 +75,19 @@
% iff Inst is the inst that results from substituting all
% occurrences of Params in Inst0 with the corresponding
% value in Args.
-
+ %
:- pred inst_substitute_arg_list((inst)::in, list(inst_var)::in,
list(inst)::in, (inst)::out) is det.
% inst_list_apply_substitution(Insts0, Subst, Insts) is true
% iff Inst is the inst that results from applying Subst to Insts0.
-
+ %
:- pred inst_list_apply_substitution(list(inst)::in, inst_var_sub::in,
list(inst)::out) is det.
% mode_list_apply_substitution(Modes0, Subst, Modes) is true
% iff Mode is the mode that results from applying Subst to Modes0.
-
+ %
:- pred mode_list_apply_substitution(list(mode)::in, inst_var_sub::in,
list(mode)::out) is det.
@@ -101,6 +104,7 @@
% Given an expanded inst and a cons_id and its arity, return the
% insts of the arguments of the top level functor, failing if the
% inst could not be bound to the functor.
+ %
:- pred get_arg_insts((inst)::in, cons_id::in, arity::in, list(inst)::out)
is semidet.
@@ -112,7 +116,7 @@
% Predicates to make error messages more readable by stripping
% "builtin:" module qualifiers from modes.
-
+ %
:- pred strip_builtin_qualifier_from_cons_id(cons_id::in, cons_id::out) is det.
:- pred strip_builtin_qualifiers_from_mode_list(list(mode)::in,
Index: compiler/prog_out.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_out.m,v
retrieving revision 1.58
diff -u -b -r1.58 prog_out.m
--- compiler/prog_out.m 7 Jun 2005 02:59:56 -0000 1.58
+++ compiler/prog_out.m 21 Jul 2005 12:16:50 -0000
@@ -70,6 +70,8 @@
:- pred prog_out__write_list(list(T)::in,
pred(T, io, io)::in(pred(in, di, uo) is det), io::di, io::uo) is det.
+:- pred write_string_list(list(string)::in, io::di, io::uo) is det.
+
:- pred prog_out__write_promise_type(promise_type::in, io::di, io::uo) is det.
:- func prog_out__promise_to_string(promise_type) = string.
@@ -261,6 +263,14 @@
call(Writer, Import, !IO).
prog_out__write_list([], _, !IO) :-
error("prog_out__write_module_list").
+
+write_string_list([], !IO).
+write_string_list([Name], !IO) :-
+ io__write_string(Name, !IO).
+write_string_list([Name1, Name2 | Names], !IO) :-
+ io__write_string(Name1, !IO),
+ io__write_string(", ", !IO),
+ write_string_list([Name2 | Names], !IO).
prog_out__promise_to_string(true) = "promise".
prog_out__promise_to_string(exclusive) = "promise_exclusive".
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.77
diff -u -b -r1.77 prog_util.m
--- compiler/prog_util.m 14 Jun 2005 08:15:04 -0000 1.77
+++ compiler/prog_util.m 21 Jul 2005 15:56:38 -0000
@@ -1,4 +1,6 @@
%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
% Copyright (C) 1994-2001, 2003-2005 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.
@@ -17,6 +19,7 @@
:- import_module parse_tree__prog_data.
:- import_module list.
+:- import_module map.
:- import_module std_util.
:- import_module term.
:- import_module varset.
@@ -24,16 +27,18 @@
%-----------------------------------------------------------------------------%
% Given a symbol name, return its unqualified name.
-
+ %
:- pred unqualify_name(sym_name::in, string::out) is det.
- % sym_name_get_module_name(SymName, ModName):-
+ % sym_name_get_module_name(SymName, ModName):
+ %
% Given a symbol name, return the module qualifiers(s).
% Fails if the symbol is unqualified.
%
:- pred sym_name_get_module_name(sym_name::in, module_name::out) is semidet.
% sym_name_get_module_name(SymName, DefaultModName, ModName):
+ %
% Given a symbol name, return the module qualifier(s).
% If the symbol is unqualified, then return the specified default
% module name.
@@ -42,7 +47,8 @@
module_name::out) is det.
% match_sym_name(PartialSymName, CompleteSymName):
- % succeeds iff there is some sequence of module qualifiers
+ %
+ % Succeeds iff there is some sequence of module qualifiers
% which when prefixed to PartialSymName gives CompleteSymName.
%
:- pred match_sym_name(sym_name::in, sym_name::in) is semidet.
@@ -52,7 +58,8 @@
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName0 has the given prefix
% and the unqualified part of SymName is the unqualified
- % part of SymName0 with the prefix removed
+ % part of SymName0 with the prefix removed.
+ %
:- pred remove_sym_name_prefix(sym_name, string, sym_name).
:- mode remove_sym_name_prefix(in, in, out) is semidet.
:- mode remove_sym_name_prefix(out, in, in) is det.
@@ -62,7 +69,8 @@
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName0 has the given suffix
% and the unqualified part of SymName is the unqualified
- % part of SymName0 with the suffix removed
+ % part of SymName0 with the suffix removed.
+ %
:- pred remove_sym_name_suffix(sym_name::in, string::in, sym_name::out)
is semidet.
@@ -70,7 +78,8 @@
% succeeds iff
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName is the unqualified
- % part of SymName0 with the suffix added
+ % part of SymName0 with the suffix added.
+ %
:- pred add_sym_name_suffix(sym_name::in, string::in, sym_name::out) is det.
% transform_sym_base_name(TransformFunc, SymName0) = SymName
@@ -78,12 +87,13 @@
% SymName and SymName0 have the same module qualifier
% and the unqualified part of SymName is the result of applying
% TransformFunc to the unqualified part of SymName0.
+ %
:- func transform_sym_base_name(func(string) = string, sym_name) = sym_name.
% Given a possible module qualified sym_name and a list of
% argument types and a context, construct a term. This is
% used to construct types.
-
+ %
:- pred construct_qualified_term(sym_name::in, list(term(T))::in,
term(T)::out) is det.
@@ -91,6 +101,7 @@
prog_context::in, term(T)::out) is det.
% Given a sym_name return the top level qualifier of that name.
+ %
:- func outermost_qualifier(sym_name) = string.
%-----------------------------------------------------------------------------%
@@ -100,6 +111,7 @@
% We internally store the arity as the length of the argument
% list including the return value, which is one more than the
% arity of the function reported in error messages.
+ %
:- pred adjust_func_arity(pred_or_func, int, int).
:- mode adjust_func_arity(in, in, out) is det.
:- mode adjust_func_arity(in, out, in) is det.
@@ -111,6 +123,7 @@
%
% Create a predicate name with context, e.g. for introduced
% lambda or deforestation predicates.
+ %
:- pred make_pred_name(module_name::in, string::in, maybe(pred_or_func)::in,
string::in, new_pred_id::in, sym_name::out) is det.
@@ -119,6 +132,7 @@
%
% Create a predicate name with context, e.g. for introduced
% lambda or deforestation predicates.
+ %
:- pred make_pred_name_with_context(module_name::in, string::in,
pred_or_func::in, string::in, int::in, int::in, sym_name::out) is det.
@@ -132,12 +146,10 @@
% A pred declaration may contains just types, as in
% :- pred list__append(list(T), list(T), list(T)).
% or it may contain both types and modes, as in
- % :- pred list__append(list(T)::in, list(T)::in,
- % list(T)::output).
+ % :- pred list__append(list(T)::in, list(T)::in, list(T)::output).
%
- % This predicate takes the argument list of a pred declaration,
- % splits it into two separate lists for the types and (if present)
- % the modes.
+ % This predicate takes the argument list of a pred declaration, splits it
+ % into two separate lists for the types and (if present) the modes.
:- type maybe_modes == maybe(list(mode)).
@@ -150,7 +162,7 @@
%-----------------------------------------------------------------------------%
% Perform a substitution on a goal.
-
+ %
:- pred prog_util__rename_in_goal(prog_var::in, prog_var::in,
goal::in, goal::out) is det.
@@ -160,29 +172,29 @@
% Given a cons_id and a list of argument terms, convert it into a
% term. Fails if the cons_id is a pred_const, or type_ctor_info_const.
-
+ %
:- pred cons_id_and_args_to_term(cons_id::in, list(term(T))::in, term(T)::out)
is semidet.
% Get the arity of a cons_id, aborting on pred_const and
% type_ctor_info_const.
-
+ %
:- func cons_id_arity(cons_id) = arity.
% Get the arity of a cons_id. Return a `no' on those cons_ids
% where cons_id_arity/2 would normally abort.
-
+ %
:- func cons_id_maybe_arity(cons_id) = maybe(arity).
% The reverse conversion - make a cons_id for a functor.
% Given a const and an arity for the functor, create a cons_id.
-
+ %
:- func make_functor_cons_id(const, arity) = cons_id.
% Another way of making a cons_id from a functor.
% Given the name, argument types, and type_ctor of a functor,
% create a cons_id for that functor.
-
+ %
:- func make_cons_id(sym_name, list(constructor_arg), type_ctor) = cons_id.
% Another way of making a cons_id from a functor.
@@ -193,7 +205,7 @@
% to be already module qualified, which means that it does not
% need the module qualification of the type, (b) it can compute the
% arity from any list of the right length.
-
+ %
:- func make_cons_id_from_qualified_sym_name(sym_name, list(_)) = cons_id.
%-----------------------------------------------------------------------------%
@@ -203,23 +215,56 @@
% `VarSet0'. The variables will be named "<Name>1", "<Name>2",
% "<Name>3", and so on, where <Name> is the value of `Name'.
% `VarSet' is the resulting varset.
-
+ %
:- pred make_n_fresh_vars(string::in, int::in, list(var(T))::out,
varset(T)::in, varset(T)::out) is det.
- % given the list of predicate arguments for a predicate that
+ % Given the list of predicate arguments for a predicate that
% is really a function, split that list into the function arguments
% and the function return type.
+ %
:- pred pred_args_to_func_args(list(T)::in, list(T)::out, T::out) is det.
% Get the last two arguments from the list, failing if there
% aren't at least two arguments.
+ %
:- pred get_state_args(list(T)::in, list(T)::out, T::out, T::out) is semidet.
% Get the last two arguments from the list, aborting if there
% aren't at least two arguments.
+ %
:- pred get_state_args_det(list(T)::in, list(T)::out, T::out, T::out) is det.
+ % Parse a term of the form `Head :- Body', treating a term not in that form
+ % as `Head :- true'.
+ %
+:- pred parse_rule_term(term__context::in, term(T)::in, term(T)::out,
+ term(T)::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % Add new type variables for those introduced by a type qualification.
+ %
+:- pred get_new_tvars(list(tvar)::in, tvarset::in, tvarset::in, tvarset::out,
+ tvar_name_map::in, tvar_name_map::out,
+ map(tvar, tvar)::in, map(tvar, tvar)::out) is det.
+
+ % substitute_vars(Vars0, Subst, Vars):
+ %
+ % Apply substitution `Subst' (which must only rename vars) to `Vars0',
+ % and return the result in `Vars'.
+ %
+:- pred substitute_vars(list(var(T))::in, substitution(T)::in,
+ list(var(T))::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+ % We need to "unparse" the sym_name to construct the properly
+ % module qualified term.
+ %
+:- func sym_name_and_args_to_term(sym_name, list(term(T)), prog_context) =
+ term(T).
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -230,6 +275,7 @@
:- import_module bool.
:- import_module int.
+:- import_module svmap.
:- import_module require.
:- import_module string.
:- import_module varset.
@@ -286,12 +332,10 @@
split_type_and_mode(TM, Result0, T, M, Result1),
split_types_and_modes_2(TMs, Result1, Ts, Ms, Result).
- % if a pred declaration specifies modes for some but
- % not all of the arguments, then the modes are ignored
- % - should this be an error instead?
- % trd: this should never happen because prog_io.m will detect
- % these cases
-
+ % If a pred declaration specifies modes for some but not all of the
+ % arguments, then the modes are ignored - should this be an error instead?
+ % trd: this should never happen because prog_io.m will detect these cases.
+ %
:- pred split_type_and_mode(type_and_mode::in, bool::in,
(type)::out, (mode)::out, bool::out) is det.
@@ -399,10 +443,11 @@
%-----------------------------------------------------------------------------%
-% match_sym_name(PartialSymName, CompleteSymName):
-% succeeds iff there is some sequence of module qualifiers
-% which when prefixed to PartialSymName gives CompleteSymName.
-
+ % match_sym_name(PartialSymName, CompleteSymName):
+ %
+ % Succeeds iff there is some sequence of module qualifiers
+ % which when prefixed to PartialSymName gives CompleteSymName.
+ %
match_sym_name(qualified(Module1, Name), qualified(Module2, Name)) :-
match_sym_name(Module1, Module2).
match_sym_name(unqualified(Name), unqualified(Name)).
@@ -464,8 +509,7 @@
SubstElem = Var - Type,
varset__lookup_name(VarSet, Var, VarName),
TypeString = mercury_type_to_string(VarSet, Type),
- string__append_list([VarName, " = ", TypeString],
- SubstStr)
+ string__append_list([VarName, " = ", TypeString], SubstStr)
),
list_to_string(SubstToString, TypeSubst, PredIdStr)
;
@@ -587,7 +631,7 @@
varset(T)::in, varset(T)::out) is det.
make_n_fresh_vars_2(BaseName, N, Max, Vars, !VarSet) :-
- (N = Max ->
+ ( N = Max ->
Vars = []
;
N1 = N + 1,
@@ -622,6 +666,82 @@
;
error("hlds_pred__get_state_args_det")
).
+
+%-----------------------------------------------------------------------------%
+
+parse_rule_term(Context, RuleTerm, HeadTerm, GoalTerm) :-
+ ( RuleTerm = term__functor(term__atom(":-"), [HeadTerm0, GoalTerm0], _) ->
+ HeadTerm = HeadTerm0,
+ GoalTerm = GoalTerm0
+ ;
+ HeadTerm = RuleTerm,
+ GoalTerm = term__functor(term__atom("true"), [], Context)
+ ).
+
+get_new_tvars([], _, !TVarSet, !TVarNameMap, !TVarRenaming).
+get_new_tvars([TVar | TVars], VarSet, !TVarSet, !TVarNameMap, !TVarRenaming) :-
+ ( map__contains(!.TVarRenaming, TVar) ->
+ true
+ ;
+ ( varset__search_name(VarSet, TVar, TVarName) ->
+ ( map__search(!.TVarNameMap, TVarName, TVarSetVar) ->
+ svmap__det_insert(TVar, TVarSetVar, !TVarRenaming)
+ ;
+ varset__new_var(!.TVarSet, NewTVar, !:TVarSet),
+ varset__name_var(!.TVarSet, NewTVar, TVarName, !:TVarSet),
+ svmap__det_insert(TVarName, NewTVar, !TVarNameMap),
+ svmap__det_insert(TVar, NewTVar, !TVarRenaming)
+ )
+ ;
+ varset__new_var(!.TVarSet, NewTVar, !:TVarSet),
+ svmap__det_insert(TVar, NewTVar, !TVarRenaming)
+ )
+ ),
+ get_new_tvars(TVars, VarSet, !TVarSet, !TVarNameMap, !TVarRenaming).
+
+%-----------------------------------------------------------------------------%
+
+substitute_vars(Vars0, Subst, Vars) :-
+ Vars = list__map(substitute_var(Subst), Vars0).
+
+:- func substitute_var(substitution(T), var(T)) = var(T).
+
+substitute_var(Subst, Var0) = Var :-
+ term__apply_substitution(term__variable(Var0), Subst, Term),
+ ( Term = term__variable(Var1) ->
+ Var = Var1
+ ;
+ error("substitute_var: invalid substitution")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+sym_name_and_args_to_term(unqualified(Name), Xs, Context) =
+ term__functor(term__atom(Name), Xs, Context).
+
+sym_name_and_args_to_term(qualified(ModuleNames, Name), Xs, Context) =
+ sym_name_and_term_to_term(ModuleNames,
+ term__functor(term__atom(Name), Xs, Context), Context).
+
+:- func sym_name_and_term_to_term(module_specifier, term(T), prog_context) =
+ term(T).
+
+sym_name_and_term_to_term(unqualified(ModuleName), Term, Context) =
+ term__functor(
+ term__atom("."),
+ [term__functor(term__atom(ModuleName), [], Context), Term],
+ Context
+ ).
+sym_name_and_term_to_term(qualified(ModuleNames, ModuleName), Term, Context) =
+ term__functor(
+ term__atom("."),
+ [sym_name_and_term_to_term(
+ ModuleNames,
+ term__functor(term__atom(ModuleName), [], Context),
+ Context),
+ Term],
+ Context
+ ).
%-----------------------------------------------------------------------------%
:- end_module prog_util.
Index: compiler/qual_info.m
===================================================================
RCS file: compiler/qual_info.m
diff -N compiler/qual_info.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/qual_info.m 21 Jul 2005 14:54:49 -0000
@@ -0,0 +1,282 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2005 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: qual_info.m.
+% Main author: fjh.
+
+:- module hlds__make_hlds__qual_info.
+:- interface.
+
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_module.
+:- import_module hlds__hlds_pred.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__equiv_type.
+:- import_module parse_tree__module_qual.
+:- import_module parse_tree__prog_data.
+:- import_module recompilation.
+
+:- import_module bool.
+:- import_module io.
+:- import_module list.
+:- import_module map.
+
+:- type qual_info.
+
+:- pred init_qual_info(mq_info::in, eqv_map::in, qual_info::out) is det.
+
+ % Update the qual_info when processing a new clause.
+:- pred update_qual_info(tvar_name_map::in, tvarset::in,
+ map(prog_var, type)::in, import_status::in,
+ qual_info::in, qual_info::out) is det.
+
+:- pred qual_info_get_tvarset(qual_info::in, tvarset::out) is det.
+:- pred qual_info_get_var_types(qual_info::in, vartypes::out) is det.
+:- pred qual_info_get_mq_info(qual_info::in, mq_info::out) is det.
+:- pred qual_info_get_import_status(qual_info::in, import_status::out) is det.
+:- pred qual_info_get_found_syntax_error(qual_info::in, bool::out) is det.
+
+:- pred qual_info_set_mq_info(mq_info::in, qual_info::in, qual_info::out)
+ is det.
+:- pred qual_info_set_var_types(vartypes::in, qual_info::in, qual_info::out)
+ is det.
+:- pred qual_info_set_found_syntax_error(bool::in,
+ qual_info::in, qual_info::out) is det.
+
+:- pred apply_to_recompilation_info(
+ pred(recompilation_info, recompilation_info)::in(pred(in, out) is det),
+ qual_info::in, qual_info::out) is det.
+
+ % Move the recompilation_info from the qual_info to the module_info
+ % after make_hlds is finished with it and the qual_info is dead.
+ %
+:- pred set_module_recompilation_info(qual_info::in,
+ module_info::in, module_info::out) is det.
+
+ % Process an explicit type qualification.
+ %
+:- pred process_type_qualification(prog_var::in, (type)::in, tvarset::in,
+ prog_context::in, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, io::di, io::uo) is det.
+
+:- pred make_atomic_unification(prog_var::in, unify_rhs::in, prog_context::in,
+ unify_main_context::in, unify_sub_contexts::in, hlds_goal::out,
+ qual_info::in, qual_info::out) is det.
+
+:- pred record_called_pred_or_func(pred_or_func::in, sym_name::in, arity::in,
+ qual_info::in, qual_info::out) is det.
+
+:- pred construct_pred_or_func_call(pred_id::in, pred_or_func::in,
+ sym_name::in, list(prog_var)::in, hlds_goal_info::in, hlds_goal::out,
+ qual_info::in, qual_info::out) is det.
+
+:- pred do_construct_pred_or_func_call(pred_id::in, pred_or_func::in,
+ sym_name::in, list(prog_var)::in, hlds_goal_info::in, hlds_goal::out)
+ is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module hlds__hlds_data.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_util.
+
+:- import_module std_util.
+:- import_module term.
+:- import_module varset.
+
+ % Information used to process explicit type qualifications.
+:- type qual_info
+ ---> qual_info(
+ eqv_map :: eqv_map,
+ % Used to expand equivalence types.
+
+ tvarset :: tvarset,
+ % All type variables for predicate.
+
+ tvar_renaming :: map(tvar, tvar),
+ % Map from clause type variable to
+ % actual type variable in tvarset.
+
+ tvar_name_map :: tvar_name_map,
+ % Type variables in tvarset occurring
+ % in the predicate's argument types
+ % indexed by name.
+
+ vartypes :: vartypes,
+
+ mq_info :: mq_info,
+ % Module qualification info.
+
+ import_status :: import_status,
+
+ found_syntax_error :: bool
+ % Was there a syntax error in an Aditi
+ % update.
+ ).
+
+init_qual_info(MQInfo0, EqvMap, QualInfo) :-
+ mq_info_set_need_qual_flag(may_be_unqualified, MQInfo0, MQInfo),
+ varset__init(TVarSet),
+ map__init(Renaming),
+ map__init(Index),
+ map__init(VarTypes),
+ FoundSyntaxError = no,
+ QualInfo = qual_info(EqvMap, TVarSet, Renaming, Index, VarTypes,
+ MQInfo, local, FoundSyntaxError).
+
+update_qual_info(TVarNameMap, TVarSet, VarTypes, Status, !QualInfo) :-
+ !.QualInfo = qual_info(EqvMap, _TVarSet0, _Renaming0, _TVarNameMap0,
+ _VarTypes0, MQInfo, _Status, _FoundError),
+ % The renaming for one clause is useless in the others.
+ map__init(Renaming),
+ !:QualInfo = qual_info(EqvMap, TVarSet, Renaming, TVarNameMap,
+ VarTypes, MQInfo, Status, no).
+
+qual_info_get_tvarset(Info, Info ^ tvarset).
+qual_info_get_var_types(Info, Info ^ vartypes).
+qual_info_get_mq_info(Info, Info ^ mq_info).
+qual_info_get_import_status(Info, Info ^ import_status).
+qual_info_get_found_syntax_error(Info, Info ^ found_syntax_error).
+
+qual_info_set_mq_info(MQInfo, Info, Info ^ mq_info := MQInfo).
+qual_info_set_var_types(VarTypes, Info, Info ^ vartypes := VarTypes).
+qual_info_set_found_syntax_error(FoundError, Info,
+ Info ^ found_syntax_error := FoundError).
+
+apply_to_recompilation_info(Pred, !QualInfo) :-
+ MQInfo0 = !.QualInfo ^ mq_info,
+ mq_info_get_recompilation_info(MQInfo0, MaybeRecompInfo0),
+ (
+ MaybeRecompInfo0 = yes(RecompInfo0),
+ Pred(RecompInfo0, RecompInfo),
+ mq_info_set_recompilation_info(yes(RecompInfo), MQInfo0, MQInfo),
+ !:QualInfo = !.QualInfo ^ mq_info := MQInfo
+ ;
+ MaybeRecompInfo0 = no
+ ).
+
+set_module_recompilation_info(QualInfo, !ModuleInfo) :-
+ mq_info_get_recompilation_info(QualInfo ^ mq_info, RecompInfo),
+ module_info_set_maybe_recompilation_info(RecompInfo, !ModuleInfo).
+
+%-----------------------------------------------------------------------------%
+
+process_type_qualification(Var, Type0, VarSet, Context, !ModuleInfo,
+ !QualInfo, !IO) :-
+ !.QualInfo = qual_info(EqvMap, TVarSet0, TVarRenaming0,
+ TVarNameMap0, VarTypes0, MQInfo0, Status, FoundError),
+ ( Status = opt_imported ->
+ % Types in `.opt' files should already be fully module qualified.
+ Type1 = Type0,
+ MQInfo = MQInfo0
+ ;
+ module_qual__qualify_type_qualification(Type0, Type1,
+ Context, MQInfo0, MQInfo, !IO)
+ ),
+
+ % Find any new type variables introduced by this type, and
+ % add them to the var-name index and the variable renaming.
+ term__vars(Type1, TVars),
+ get_new_tvars(TVars, VarSet, TVarSet0, TVarSet1,
+ TVarNameMap0, TVarNameMap, TVarRenaming0, TVarRenaming),
+
+ % Apply the updated renaming to convert type variables in
+ % the clause to type variables in the tvarset.
+ term__apply_variable_renaming(Type1, TVarRenaming, Type2),
+
+ % Expand equivalence types.
+ % We don't need to record the expanded types for smart recompilation
+ % because at the moment no recompilation.item_id can depend on a
+ % clause item.
+ RecordExpanded = no,
+ equiv_type__replace_in_type(EqvMap, Type2, Type, _, TVarSet1, TVarSet,
+ RecordExpanded, _),
+ update_var_types(Var, Type, Context, VarTypes0, VarTypes, !IO),
+ !:QualInfo = qual_info(EqvMap, TVarSet, TVarRenaming,
+ TVarNameMap, VarTypes, MQInfo, Status, FoundError).
+
+:- pred update_var_types(prog_var::in, (type)::in, prog_context::in,
+ vartypes::in, vartypes::out, io::di, io::uo) is det.
+
+update_var_types(Var, Type, Context, !VarTypes, !IO) :-
+ ( map__search(!.VarTypes, Var, Type0) ->
+ ( Type = Type0 ->
+ true
+ ;
+ prog_out__write_context(Context, !IO),
+ io__write_string("Error: explicit type qualification does\n", !IO),
+ prog_out__write_context(Context, !IO),
+ io__write_string(" not match prior qualification.\n", !IO),
+ io__set_exit_status(1, !IO)
+ )
+ ;
+ map__det_insert(!.VarTypes, Var, Type, !:VarTypes)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+make_atomic_unification(Var, Rhs, Context, MainContext, SubContext,
+ Goal, !QualInfo) :-
+ (
+ Rhs = var(_)
+ ;
+ Rhs = lambda_goal(_, _, _, _, _, _, _, _, _)
+ ;
+ Rhs = functor(ConsId, _, _),
+ record_used_functor(ConsId, !QualInfo)
+ ),
+ hlds_goal__create_atomic_unification(Var, Rhs, Context,
+ MainContext, SubContext, Goal).
+
+record_called_pred_or_func(PredOrFunc, SymName, Arity, !QualInfo) :-
+ Id = SymName - Arity,
+ apply_to_recompilation_info(recompilation__record_used_item(
+ pred_or_func_to_item_type(PredOrFunc), Id, Id), !QualInfo).
+
+:- pred record_used_functor(cons_id::in, qual_info::in, qual_info::out) is det.
+
+record_used_functor(ConsId, !QualInfo) :-
+ ( ConsId = cons(SymName, Arity) ->
+ Id = SymName - Arity,
+ apply_to_recompilation_info(
+ recompilation__record_used_item(functor, Id, Id), !QualInfo)
+ ;
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
+
+construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args, GoalInfo, Goal,
+ !QualInfo) :-
+ do_construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args,
+ GoalInfo, Goal),
+ list__length(Args, Arity),
+ adjust_func_arity(PredOrFunc, OrigArity, Arity),
+ record_called_pred_or_func(PredOrFunc, SymName, OrigArity, !QualInfo).
+
+do_construct_pred_or_func_call(PredId, PredOrFunc, SymName, Args,
+ GoalInfo, Goal) :-
+ (
+ PredOrFunc = predicate,
+ Goal = call(PredId, invalid_proc_id, Args, not_builtin, no, SymName)
+ - GoalInfo
+ ;
+ PredOrFunc = function,
+ pred_args_to_func_args(Args, FuncArgs, RetArg),
+ list__length(FuncArgs, Arity),
+ ConsId = cons(SymName, Arity),
+ goal_info_get_context(GoalInfo, Context),
+ hlds_goal__create_atomic_unification(RetArg,
+ functor(ConsId, no, FuncArgs), Context,
+ explicit, [], GoalExpr - _),
+ Goal = GoalExpr - GoalInfo
+ ).
+
+%-----------------------------------------------------------------------------%
Index: compiler/quantification.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/quantification.m,v
retrieving revision 1.92
diff -u -b -r1.92 quantification.m
--- compiler/quantification.m 24 Mar 2005 05:34:14 -0000 1.92
+++ compiler/quantification.m 25 Apr 2005 11:10:57 -0000
@@ -40,7 +40,6 @@
:- import_module list.
:- import_module set.
- %
% When the compiler performs structure reuse, using
% the ordinary non-locals during code generation
% causes variables taken from the reused cell in
@@ -76,6 +75,7 @@
vartypes::in, vartypes::out) is det.
% As above, with `ordinary_nonlocals' passed as the first argument.
+ %
:- pred implicitly_quantify_clause_body(list(prog_var)::in,
list(quant_warning)::out, hlds_goal::in, hlds_goal::out,
prog_varset::in, prog_varset::out, vartypes::in, vartypes::out) is det.
@@ -86,6 +86,7 @@
vartypes::in, vartypes::out) is det.
% As above, with `ordinary_nonlocals' passed as the first argument.
+ %
:- pred implicitly_quantify_goal(set(prog_var)::in, list(quant_warning)::out,
hlds_goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
vartypes::in, vartypes::out) is det.
@@ -94,6 +95,7 @@
proc_info::in, proc_info::out) is det.
% As above, with `ordinary_nonlocals' passed as the first argument.
+ %
:- pred requantify_proc(proc_info::in, proc_info::out) is det.
% We return a list of warnings back to make_hlds.m.
@@ -104,12 +106,13 @@
---> warn_overlap(list(prog_var), prog_context).
% quantification__goal_vars(Goal, Vars):
- % Vars is the set of variables that are free (unquantified)
- % in Goal.
+ % Vars is the set of variables that are free (unquantified) in Goal.
+ %
:- pred quantification__goal_vars(nonlocals_to_recompute::in,
hlds_goal::in, set(prog_var)::out) is det.
% As above, with `ordinary_nonlocals' passed as the first argument.
+ %
:- pred quantification__goal_vars(hlds_goal::in, set(prog_var)::out) is det.
%-----------------------------------------------------------------------------%
Index: compiler/state_var.m
===================================================================
RCS file: compiler/state_var.m
diff -N compiler/state_var.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/state_var.m 21 Jul 2005 14:40:00 -0000
@@ -0,0 +1,1086 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2005 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: state_var.m.
+% Main author: rafe.
+
+:- module hlds__make_hlds__state_var.
+:- interface.
+
+:- import_module hlds__hlds_goal.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module io.
+:- import_module list.
+:- import_module map.
+:- import_module set.
+
+ % This synonym improves code legibility.
+ %
+:- type svar == prog_var.
+
+:- type svars == list(svar).
+
+ % A set of state variables.
+ %
+:- type svar_set == set(svar).
+
+ % A mapping from state variables to logical variables.
+ %
+:- type svar_map == map(svar, prog_var).
+
+ % This controls how state variables are dealt with.
+ %
+:- type svar_ctxt
+ ---> in_head
+ % In the head of a clause or lambda.
+
+ ; in_body
+ % In the body of a clause or lambda.
+
+ ; in_atom(
+ % In the context of an atomic goal at the level of the
+ % source code.
+ had_colon_reference :: svar_set,
+ % The set of state variables X that
+ % have been referenced as !:X in the
+ % parameters of the atomic goal.
+ parent_svar_info :: svar_info
+ % The parent svar_info, used to keep
+ % track of nesting in subterms of
+ % an atomic formula.
+ ).
+
+:- type svar_info
+ ---> svar_info(
+ ctxt :: svar_ctxt,
+
+ num :: int,
+ % This is used to number state variables and
+ % is incremented for each source-level
+ % conjunct.
+
+ external_dot :: svar_map,
+ % The "read only" state variables in
+ % scope (e.g. external state variables
+ % visible from within a lambda body or
+ % condition of an if-then-else expression.)
+
+ dot :: svar_map,
+ colon :: svar_map
+ % The "read/write" state variables in scope.
+ ).
+
+ % When collecting the arms of a disjunction we also need to
+ % collect the resulting svar_infos.
+ %
+:- type hlds_goal_svar_info == {hlds_goal, svar_info}.
+
+:- type hlds_goal_svar_infos == list(hlds_goal_svar_info).
+
+ % Create a new svar_info set up to start processing a clause head.
+ %
+:- func new_svar_info = svar_info.
+
+ % Obtain the mapping for a !.X state variable reference and
+ % update the svar_info.
+ %
+ % If we are processing the head of a clause or lambda, we
+ % incrementally accumulate the mappings.
+ %
+ % Otherwise, the mapping must already be present for a local
+ % or `external' state variable (i.e. one that may be visible,
+ % but not updatable, in the current context.)
+ %
+ % Note that if !.X does not appear in the head then !:X must
+ % appear before !.X can be referenced.
+ %
+:- pred dot(prog_context::in, svar::in, prog_var::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
+ io::di, io::uo) is det.
+
+ % Obtain the mapping for a !:X state variable reference.
+ %
+ % If we are processing the head of a clause or lambda, we
+ % incrementally accumulate the mappings.
+ %
+ % Otherwise, the mapping must already be present for a local
+ % state variable (`externally' visible state variables cannot
+ % be updated.)
+ %
+ % We also keep track of which state variables have been updated
+ % in an atomic context.
+ %
+:- pred colon(prog_context::in, svar::in, prog_var::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
+ io::di, io::uo) is det.
+
+ % Prepare for the head of a new clause.
+ %
+:- pred prepare_for_head(svar_info::out) is det.
+
+ % We need to make the current !.Xs external
+ % ("read-only") and clear the !.Xs and !:Xs.
+ %
+ % While processing the head, any state variables therein are
+ % implicitly scoped over the body and have !. and !: mappings
+ % set up.
+ %
+:- pred prepare_for_lambda(svar_info::in, svar_info::out) is det.
+
+ % Having processed the head of a clause, prepare for the first
+ % (source-level) atomic conjunct. We return the final !:
+ % mappings identified while processing the head.
+ %
+:- pred prepare_for_body(svar_map::out, prog_varset::in, prog_varset::out,
+ svar_info::in, svar_info::out) is det.
+
+ % We have to conjoin the head and body and add unifiers to tie up all
+ % the final values of the state variables to the head variables.
+ %
+:- pred finish_head_and_body(prog_context::in, svar_map::in,
+ hlds_goal::in, hlds_goal::in, hlds_goal::out, svar_info::in) is det.
+
+ % Add some local state variables.
+ %
+:- pred prepare_for_local_state_vars(svars::in,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
+
+ % Remove some local state variables.
+ %
+:- pred finish_local_state_vars(svars::in, prog_vars::out,
+ svar_info::in, svar_info::in, svar_info::out) is det.
+
+ % We have to add unifiers to the Then and Else arms of an
+ % if-then-else to make sure all the state variables match up.
+ %
+ % More to the point, we have to add unifiers to the Then arm
+ % for any new state variable mappings produced in the condition.
+ %
+ % We construct new mappings for the state variables and then
+ % add unifiers.
+ %
+:- pred finish_if_then_else(prog_context::in, hlds_goal::in, hlds_goal::out,
+ hlds_goal::in, hlds_goal::out, svar_info::in,
+ svar_info::in, svar_info::in, svar_info::in, svar_info::out,
+ prog_varset::in, prog_varset::out) is det.
+
+:- pred finish_if_then_else_goal_condition(svars::in,
+ svar_info::in, svar_info::in, svar_info::out, svar_info::out) is det.
+
+:- pred finish_if_then_else_expr_condition(svar_info::in,
+ svar_info::in, svar_info::out) is det.
+
+:- pred finish_if_then_else_expr_then_goal(svars::in,
+ svar_info::in, svar_info::in, svar_info::out) is det.
+
+ % We assume that a negation updates all state variables in scope,
+ % so we construct new mappings for the state variables and then
+ % add unifiers from their pre-negated goal mappings.
+ %
+:- pred finish_negation(svar_info::in, svar_info::in, svar_info::out) is det.
+
+ % We have to make sure that all arms of a disjunction produce the
+ % same state variable bindings by adding unifiers as necessary.
+ %
+:- pred finish_disjunction(prog_context::in, prog_varset::in,
+ hlds_goal_svar_infos::in, hlds_goals::out, svar_info::out) is det.
+
+ % We treat equivalence goals as if they were negations (they are
+ % in a negated context after all.)
+ %
+:- pred finish_equivalence(svar_info::in, svar_info::in, svar_info::out)
+ is det.
+
+ % We prepare for a call by setting the ctxt to in_atom. If we're
+ % already in an atom then we inherit the parent's set of "updated"
+ % state variables.
+ %
+:- pred prepare_for_call(svar_info::in, svar_info::out) is det.
+
+ % When we finish a call, we're either still inside the
+ % atomic formula, in which case we simply propagate the set of
+ % "updated" state variables, or we've just emerged, in which case
+ % we need to set up the svar_info for the next conjunct.
+ %
+ % (We can still be in an atomic context if, for example, we've
+ % been processing a function call which must appear as an
+ % expression and hence occur inside an atomic context.)
+ %
+:- pred finish_call(prog_varset::in, prog_varset::out,
+ svar_info::in, svar_info::out) is det.
+
+:- pred prepare_for_if_then_else_goal(svars::in,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
+
+:- pred finish_if_then_else_goal_then_goal(svars::in,
+ svar_info::in, svar_info::in, svar_info::out) is det.
+
+ % The condition of an if-then-else expression is a goal in which
+ % only !.X state variables in scope are visible (although the goal
+ % may use local state variables introduced via an explicit
+ % quantifier.) The StateVars are local to the condition and then-goal.
+ %
+:- pred prepare_for_if_then_else_expr(svars::in,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
+
+ % Having finished processing one source-level atomic conjunct, prepare
+ % for the next. Note that if !:X was not seen in the conjunct we've
+ % just processed, then we can reuse the !.X and !:X mappings.
+ %
+ % p(!.X) where [!.X -> X0, !:X -> X1]
+ %
+ % can yield
+ %
+ % p(X0) and [!.X -> X0, !:X -> X2]
+ %
+ % but
+ %
+ % p(!.X, !:X) where [!.X -> X0, !:X -> X1]
+ %
+ % will yield
+ %
+ % p(X0, X1) and [!.X -> X1, !:X -> X2]
+ %
+:- pred prepare_for_next_conjunct(svar_set::in,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
+ is det.
+
+ % Given a list of argument terms, substitute !.X and !:X with
+ % the corresponding state variable mappings. Any !X should
+ % already have been expanded into !.X, !:X via a call to
+ % expand_bang_state_var_args/1.
+ %
+:- pred substitute_state_var_mappings(list(prog_term)::in,
+ list(prog_term)::out, prog_varset::in, prog_varset::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+:- pred substitute_state_var_mapping(prog_term::in, prog_term::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
+ io::di, io::uo) is det.
+
+ % Replace !X args with two args !.X, !:X in that order.
+ %
+:- func expand_bang_state_var_args(list(prog_term)) = list(prog_term).
+
+:- func expand_bang_state_var_args_in_instance_method_heads(instance_body) =
+ instance_body.
+
+:- pred illegal_state_var_func_result(pred_or_func::in, list(prog_term)::in,
+ svar::out) is semidet.
+
+ % We do not allow !X to appear as a lambda head argument.
+ % We might extend the syntax still further to accommodate
+ % this as an option, e.g. !IO::(di, uo).
+ %
+:- pred lambda_args_contain_bang_state_var(list(prog_term)::in, prog_var::out)
+ is semidet.
+
+:- pred report_illegal_state_var_update(prog_context::in, prog_varset::in,
+ svar::in, io::di, io::uo) is det.
+
+:- pred report_illegal_func_svar_result(prog_context::in, prog_varset::in,
+ svar::in, io::di, io::uo) is det.
+
+:- pred report_illegal_bang_svar_lambda_arg(prog_context::in, prog_varset::in,
+ svar::in, io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_util.
+
+:- import_module char.
+:- import_module int.
+:- import_module require.
+:- import_module std_util.
+:- import_module string.
+:- import_module term.
+:- import_module varset.
+
+new_svar_info = svar_info(in_head, 0, map__init, map__init, map__init).
+
+:- pred svar_info `has_svar_colon_mapping_for` svar.
+:- mode in `has_svar_colon_mapping_for` in is semidet.
+
+SInfo `has_svar_colon_mapping_for` StateVar :-
+ SInfo ^ colon `contains` StateVar.
+SInfo `has_svar_colon_mapping_for` StateVar :-
+ SInfo ^ ctxt = in_atom(_, ParentSInfo),
+ ParentSInfo `has_svar_colon_mapping_for` StateVar.
+
+:- func svar_info `with_updated_svar` svar = svar_info.
+
+SInfo `with_updated_svar` StateVar =
+ ( SInfo ^ ctxt = in_atom(UpdatedStateVars, ParentSInfo) ->
+ SInfo ^ ctxt := in_atom(set__insert(UpdatedStateVars, StateVar),
+ ParentSInfo)
+ ;
+ SInfo
+ ).
+
+%-----------------------------------------------------------------------------%
+
+dot(Context, StateVar, Var, !VarSet, !SInfo, !IO) :-
+ ( !.SInfo ^ ctxt = in_head ->
+ ( !.SInfo ^ dot ^ elem(StateVar) = Var0 ->
+ Var = Var0
+ ;
+ new_dot_state_var(StateVar, Var, !VarSet, !SInfo)
+ )
+ ;
+ ( !.SInfo ^ dot ^ elem(StateVar) = Var0 ->
+ Var = Var0
+ ; !.SInfo ^ external_dot ^ elem(StateVar) = Var0 ->
+ Var = Var0
+ ; !.SInfo `has_svar_colon_mapping_for` StateVar ->
+ new_dot_state_var(StateVar, Var, !VarSet, !SInfo),
+ report_unitialized_state_var(Context, !.VarSet, StateVar, !IO)
+ ;
+ Var = StateVar,
+ report_non_visible_state_var(".", Context, !.VarSet, StateVar, !IO)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+colon(Context, StateVar, Var, !VarSet, !SInfo, !IO) :-
+ ( !.SInfo ^ ctxt = in_head ->
+ ( !.SInfo ^ colon ^ elem(StateVar) = Var0 ->
+ Var = Var0
+ ;
+ new_final_state_var(StateVar, Var, !VarSet, !SInfo)
+ )
+ ;
+ ( !.SInfo ^ colon ^ elem(StateVar) = Var0 ->
+ Var = Var0,
+ !:SInfo = !.SInfo `with_updated_svar` StateVar
+ ;
+ Var = StateVar,
+ % Set up a dummy mapping: there's no point
+ % in mentioning this error twice.
+ !:SInfo = ( !.SInfo ^ colon ^ elem(StateVar) := Var ),
+ ( !.SInfo ^ external_dot `contains` StateVar ->
+ PError = report_illegal_state_var_update
+ ;
+ PError = report_non_visible_state_var(":")
+ ),
+ PError(Context, !.VarSet, StateVar, !IO)
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % Construct the initial and final mappings for a state variable.
+ %
+:- pred new_local_state_var(svar::in, prog_var::out, prog_var::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
+ is det.
+
+new_local_state_var(StateVar, VarD, VarC, !VarSet, !SInfo) :-
+ new_dot_state_var(StateVar, VarD, !VarSet, !SInfo),
+ new_final_state_var(StateVar, VarC, !VarSet, !SInfo).
+
+ % Construct the initial and final mappings for a state variable.
+ %
+:- pred new_dot_state_var(svar::in, prog_var::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
+ is det.
+
+new_dot_state_var(StateVar, VarD, !VarSet, !SInfo) :-
+ N = !.SInfo ^ num,
+ Name = varset__lookup_name(!.VarSet, StateVar),
+ NameD = string__format("STATE_VARIABLE_%s_%d", [s(Name), i(N)]),
+ varset__new_named_var(!.VarSet, NameD, VarD, !:VarSet),
+ !:SInfo = ( !.SInfo ^ dot ^ elem(StateVar) := VarD ).
+
+:- pred new_colon_state_var(svar::in, prog_var::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
+ is det.
+
+new_colon_state_var(StateVar, VarC, !VarSet, !SInfo) :-
+ N = !.SInfo ^ num,
+ Name = varset__lookup_name(!.VarSet, StateVar),
+ NameC = string__format("STATE_VARIABLE_%s_%d", [s(Name), i(N)]),
+ varset__new_named_var(!.VarSet, NameC, VarC, !:VarSet),
+ !:SInfo = ( !.SInfo ^ colon ^ elem(StateVar) := VarC ).
+
+:- pred new_final_state_var(svar::in, prog_var::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out)
+ is det.
+
+new_final_state_var(StateVar, VarC, !VarSet, !SInfo) :-
+ Name = varset__lookup_name(!.VarSet, StateVar),
+ NameC = string__format("STATE_VARIABLE_%s", [s(Name)]),
+ varset__new_named_var(!.VarSet, NameC, VarC, !:VarSet),
+ !:SInfo = ( !.SInfo ^ colon ^ elem(StateVar) := VarC ).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_head(new_svar_info).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_lambda(!SInfo) :-
+ !:SInfo = ( new_svar_info ^ external_dot := !.SInfo ^ dot ).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_body(FinalMap, !VarSet, !SInfo) :-
+ FinalMap = !.SInfo ^ colon,
+ N = !.SInfo ^ num + 1,
+ StateVars = list__merge_and_remove_dups(map__keys(!.SInfo ^ colon),
+ map__keys(!.SInfo ^ dot)),
+ next_svar_mappings(N, StateVars, !VarSet, Colon),
+ !:SInfo = !.SInfo ^ ctxt := in_body,
+ !:SInfo = !.SInfo ^ num := N,
+ !:SInfo = !.SInfo ^ colon := Colon.
+
+%-----------------------------------------------------------------------------%
+
+finish_head_and_body(Context, FinalSVarMap, Head, Body, Goal, SInfo) :-
+ goal_info_init(Context, GoalInfo),
+ goal_to_conj_list(Head, HeadGoals),
+ goal_to_conj_list(Body, BodyGoals),
+ Unifiers = svar_unifiers(yes(dont_warn_singleton), Context, FinalSVarMap,
+ SInfo ^ dot),
+ conj_list_to_goal(HeadGoals ++ BodyGoals ++ Unifiers, GoalInfo, Goal).
+
+:- func svar_unifiers(maybe(goal_feature), prog_context, svar_map, svar_map)
+ = hlds_goals.
+
+svar_unifiers(MaybeFeature, Context, LHSMap, RHSMap) =
+ map__foldl(add_svar_unifier(MaybeFeature, RHSMap, Context), LHSMap, []).
+
+:- func add_svar_unifier(maybe(goal_feature), svar_map, prog_context,
+ svar, prog_var, hlds_goals) = hlds_goals.
+
+add_svar_unifier(MaybeFeature, RHSMap, Context, StateVar, Var, Unifiers0)
+ = Unifiers :-
+ ( RHSVar = RHSMap ^ elem(StateVar) ->
+ Unifier = svar_unification(MaybeFeature, Context, Var, RHSVar),
+ Unifiers = [Unifier | Unifiers0]
+ ;
+ Unifiers = Unifiers0
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- func svar_unification(maybe(goal_feature), prog_context, prog_var, prog_var)
+ = hlds_goal.
+
+svar_unification(MaybeFeature, Context, SVar, Var) = Unification :-
+ hlds_goal__create_atomic_unification(SVar, var(Var), Context,
+ implicit("state variable"), [], Unification0),
+ (
+ MaybeFeature = no,
+ Unification = Unification0
+ ;
+ MaybeFeature = yes(Feature),
+ goal_add_feature(Unification0, Feature, Unification)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_local_state_vars(StateVars, !VarSet, !SInfo) :-
+ list__foldl2(add_new_local_state_var, StateVars, !VarSet, !SInfo).
+
+:- pred add_new_local_state_var(svar::in,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out) is det.
+
+add_new_local_state_var(StateVar, !VarSet, !SInfo) :-
+ new_colon_state_var(StateVar, _, !VarSet, !SInfo).
+
+%-----------------------------------------------------------------------------%
+
+finish_local_state_vars(StateVars, Vars, SInfoBefore, !SInfo) :-
+ InitDot = !.SInfo ^ dot,
+ InitColon = !.SInfo ^ colon,
+ Dots = svar_mappings(InitDot, StateVars),
+ Colons = svar_mappings(InitColon, StateVars),
+ Vars = list__sort_and_remove_dups(Dots ++ Colons),
+ !:SInfo = !.SInfo ^ dot :=
+ del_locals(StateVars, SInfoBefore ^ dot, InitDot),
+ !:SInfo = !.SInfo ^ colon :=
+ del_locals(StateVars, SInfoBefore ^ colon, InitColon).
+
+:- func svar_mappings(svar_map, svars) = svars.
+
+svar_mappings(_, []) = [].
+svar_mappings(Map, [StateVar | StateVars]) =
+ ( Map ^ elem(StateVar) = Var ->
+ [Var | svar_mappings(Map, StateVars)]
+ ;
+ svar_mappings(Map, StateVars)
+ ).
+
+:- func del_locals(svars, svar_map, svar_map) = svar_map.
+
+del_locals(StateVars, MapBefore, Map) =
+ list__foldl(
+ func(K, M) =
+ ( if MapBefore ^ elem(K) = V
+ then M ^ elem(K) := V
+ else map__delete(M, K)
+ ),
+ StateVars,
+ Map
+ ).
+
+%-----------------------------------------------------------------------------%
+
+finish_if_then_else(Context, Then0, Then, Else0, Else,
+ SInfo0, SInfoC, SInfoT0, SInfoE, SInfo, !VarSet) :-
+
+ % Add unifiers to the Then arm for state variables that
+ % acquired new mappings in the condition, but not in the
+ % Them arm itself. This is because the new mappings
+ % appear only in a negated context.
+ %
+ StateVars = list__merge_and_remove_dups(map__keys(SInfoT0 ^ dot),
+ map__keys(SInfoE ^ dot)),
+ Then0 = _ - GoalInfo,
+ goal_to_conj_list(Then0, Thens0),
+ add_then_arm_specific_unifiers(Context, StateVars,
+ SInfo0, SInfoC, SInfoT0, SInfoT, Thens0, Thens, !VarSet),
+ conj_list_to_goal(Thens, GoalInfo, Then1),
+
+ % Calculate the svar_info with the highest numbered
+ % mappings from each arm.
+ %
+ DisjSInfos = [{Then1, SInfoT}, {Else0, SInfoE}],
+ SInfo = reconciled_disj_svar_info(!.VarSet, DisjSInfos),
+
+ % Add unifiers to each arm to ensure they both construct
+ % the same final state variable mappings.
+ %
+ Then = add_disj_unifiers(Context, SInfo, StateVars,
+ {Then1, SInfoT}),
+ Else = add_disj_unifiers(Context, SInfo, StateVars,
+ {Else0, SInfoE}).
+
+ % If a new mapping was produced for state variable X in the
+ % condition-goal (i.e. the condition refers to !:X), but not
+ % in the then-goal, then we have to add a new unifier !:X = !.X
+ % to the then-goal because the new mapping was created in a
+ % negated context.
+ %
+:- pred add_then_arm_specific_unifiers(prog_context::in, svars::in,
+ svar_info::in, svar_info::in, svar_info::in, svar_info::out,
+ hlds_goals::in, hlds_goals::out, prog_varset::in, prog_varset::out) is det.
+
+add_then_arm_specific_unifiers(_, [], _, _, SInfoT, SInfoT,
+ Thens, Thens, VarSet, VarSet).
+
+add_then_arm_specific_unifiers(Context, [StateVar | StateVars],
+ SInfo0, SInfoC, !SInfoT, !Thens, !VarSet) :-
+ ( % the condition refers to !:X, but the then-goal doesn't
+ SInfoC ^ dot ^ elem(StateVar) \= SInfo0 ^ dot ^ elem(StateVar),
+ !.SInfoT ^ dot ^ elem(StateVar) = SInfoC ^ dot ^ elem(StateVar)
+ ->
+ % add a new unifier !:X = !.X
+ Dot0 = !.SInfoT ^ dot ^ det_elem(StateVar),
+ new_colon_state_var(StateVar, Dot, !VarSet, !SInfoT),
+ !:Thens = [svar_unification(yes(dont_warn_singleton), Context,
+ Dot, Dot0) | !.Thens],
+ prepare_for_next_conjunct(set__make_singleton_set(StateVar),
+ !VarSet, !SInfoT)
+ ;
+ true
+ ),
+ add_then_arm_specific_unifiers(Context, StateVars,
+ SInfo0, SInfoC, !SInfoT, !Thens, !VarSet).
+
+%-----------------------------------------------------------------------------%
+
+:- pred next_svar_mappings(int::in, svars::in,
+ prog_varset::in, prog_varset::out, svar_map::out) is det.
+
+next_svar_mappings(N, StateVars, VarSet0, VarSet, Map) :-
+ next_svar_mappings_2(N, StateVars, VarSet0, VarSet, map__init, Map).
+
+:- pred next_svar_mappings_2(int::in, svars::in,
+ prog_varset::in, prog_varset::out, svar_map::in, svar_map::out) is det.
+
+next_svar_mappings_2(_, [], !VarSet, !Map).
+next_svar_mappings_2(N, [StateVar | StateVars], !VarSet, !Map) :-
+ next_svar_mapping(N, StateVar, _, !VarSet, !Map),
+ next_svar_mappings_2(N, StateVars, !VarSet, !Map).
+
+%-----------------------------------------------------------------------------%
+
+finish_negation(SInfoBefore, SInfoNeg, SInfo) :-
+ SInfo = (( SInfoBefore ^ num := SInfoNeg ^ num )
+ ^ colon := SInfoNeg ^ colon ).
+
+%-----------------------------------------------------------------------------%
+
+finish_disjunction(Context, VarSet, DisjSInfos, Disjs, SInfo) :-
+ SInfo = reconciled_disj_svar_info(VarSet, DisjSInfos),
+ StateVars = map__keys(SInfo ^ dot),
+ Disjs = list__map( add_disj_unifiers(Context, SInfo, StateVars),
+ DisjSInfos).
+
+ % Each arm of a disjunction may have a different mapping for
+ % !.X and/or !:X. The reconciled svar_info for the disjunction
+ % takes the highest numbered mapping for each disjunct (each
+ % state variable mapping for !.X or !:X will have a name of
+ % the form `STATE_VARIABLE_X_n' for some number `n'.)
+ %
+:- func reconciled_disj_svar_info(prog_varset, hlds_goal_svar_infos) =
+ svar_info.
+
+reconciled_disj_svar_info(_, []) = _ :-
+ error("make_hlds__reconciled_disj_svar_info: empty disjunct list").
+
+reconciled_disj_svar_info(VarSet, [{_, SInfo0} | DisjSInfos]) = SInfo :-
+
+ % We compute the set of final !. and !: state variables
+ % over the whole disjunction (not all arms will necessarily
+ % include !. and !: mappings for all state variables).
+ %
+ Dots0 = set__sorted_list_to_set(map__keys(SInfo0 ^ dot)),
+ Colons0 = set__sorted_list_to_set(map__keys(SInfo0 ^ colon)),
+ Dots = union_dot_svars(Dots0, DisjSInfos),
+ Colons = union_colon_svars(Colons0, DisjSInfos),
+
+ % Then we update SInfo0 to take the highest numbered
+ % !. and !: mapping for each state variable.
+ %
+ SInfo = list__foldl(reconciled_svar_infos(VarSet, Dots, Colons),
+ DisjSInfos, SInfo0).
+
+:- func union_dot_svars(svar_set, hlds_goal_svar_infos) = svar_set.
+
+union_dot_svars(Dots, [] ) = Dots.
+union_dot_svars(Dots, [{_, SInfo} | DisjSInfos]) =
+ union_dot_svars(
+ Dots `union` set__sorted_list_to_set(map__keys(SInfo ^ dot)),
+ DisjSInfos
+ ).
+
+:- func union_colon_svars(svar_set, hlds_goal_svar_infos) = svar_set.
+
+union_colon_svars(Colons, [] ) = Colons.
+union_colon_svars(Colons, [{_, SInfo} | DisjSInfos]) =
+ union_colon_svars(
+ Colons `union` set__sorted_list_to_set(map__keys(SInfo ^ colon)),
+ DisjSInfos
+ ).
+
+:- func reconciled_svar_infos(prog_varset, svar_set, svar_set,
+ hlds_goal_svar_info, svar_info) = svar_info.
+
+reconciled_svar_infos(VarSet, Dots, Colons,
+ {_, SInfoX}, SInfo0) = SInfo :-
+ SInfo1 = set__fold(reconciled_svar_infos_dots(VarSet, SInfoX),
+ Dots, SInfo0),
+ SInfo2 = set__fold(reconciled_svar_infos_colons(VarSet, SInfoX),
+ Colons, SInfo1),
+ SInfo = ( SInfo2 ^ num := max(SInfo0 ^ num, SInfoX ^ num) ).
+
+:- func reconciled_svar_infos_dots(prog_varset, svar_info, svar, svar_info)
+ = svar_info.
+
+reconciled_svar_infos_dots(VarSet, SInfoX, StateVar, SInfo0) = SInfo :-
+ (
+ DotX = SInfoX ^ dot ^ elem(StateVar),
+ Dot0 = SInfo0 ^ dot ^ elem(StateVar)
+ ->
+ NameX = varset__lookup_name(VarSet, DotX) `with_type` string,
+ Name0 = varset__lookup_name(VarSet, Dot0) `with_type` string,
+ compare_svar_names(RDot, NameX, Name0),
+ (
+ RDot = (<),
+ SInfo = ( SInfo0 ^ dot ^ elem(StateVar) := Dot0 )
+ ;
+ RDot = (=),
+ SInfo = SInfo0
+ ;
+ RDot = (>),
+ SInfo = ( SInfo0 ^ dot ^ elem(StateVar) := DotX )
+ )
+ ;
+ SInfo = SInfo0
+ ).
+
+:- func reconciled_svar_infos_colons(prog_varset, svar_info, svar, svar_info)
+ = svar_info.
+
+reconciled_svar_infos_colons(VarSet, SInfoX, StateVar, SInfo0) = SInfo :-
+ (
+ ColonX = SInfoX ^ colon ^ elem(StateVar),
+ Colon0 = SInfo0 ^ colon ^ elem(StateVar)
+ ->
+ NameX = varset__lookup_name(VarSet, ColonX) `with_type` string,
+ Name0 = varset__lookup_name(VarSet, Colon0) `with_type` string,
+ compare_svar_names(RColon, NameX, Name0),
+ (
+ RColon = (<),
+ SInfo = ( SInfo0 ^ colon ^ elem(StateVar) := Colon0 )
+ ;
+ RColon = (=),
+ SInfo = SInfo0
+ ;
+ RColon = (>),
+ SInfo = ( SInfo0 ^ colon ^ elem(StateVar) := ColonX )
+ )
+ ;
+ SInfo = SInfo0
+ ).
+
+:- func add_disj_unifiers(prog_context, svar_info, svars, hlds_goal_svar_info)
+ = hlds_goal.
+
+add_disj_unifiers(Context, SInfo, StateVars, {GoalX, SInfoX}) = Goal :-
+ Unifiers = list__foldl(add_disj_unifier(Context, SInfo, SInfoX),
+ StateVars, []),
+ GoalX = _ - GoalInfo,
+ goal_to_conj_list(GoalX, GoalsX),
+ conj_list_to_goal(GoalsX ++ Unifiers, GoalInfo, Goal).
+
+:- func add_disj_unifier(prog_context, svar_info, svar_info, svar, hlds_goals)
+ = hlds_goals.
+
+add_disj_unifier(Context, SInfo, SInfoX, StateVar, Unifiers) =
+ (
+ Dot = SInfo ^ dot ^ elem(StateVar),
+ DotX = SInfoX ^ dot ^ elem(StateVar),
+ Dot \= DotX
+ ->
+ [svar_unification(yes(dont_warn_singleton), Context, Dot, DotX)
+ | Unifiers]
+ ;
+ Unifiers
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % We implement a special purpose comparison for state variable
+ % names that compares the numbers appended at the right hand
+ % ends of the name strings.
+ %
+ % NOTE state variable names are either "..._X" or "..._X_N"
+ % where X is the name of the program variable used for the
+ % state variable and N is a decimal number with no leading
+ % zeroes.
+ %
+:- pred compare_svar_names(comparison_result::out, string::in, string::in)
+ is det.
+
+compare_svar_names(R, A, B) :-
+ compare(R, int_suffix_of(A), int_suffix_of(B)).
+
+ % Find the number suffix at the end of a string as an int.
+ %
+:- func int_suffix_of(string) = int.
+
+int_suffix_of(S) = int_suffix_2(S, length(S) - 1, 1, 0).
+
+ % int_suffix_2(String, Index, RadixOfIndexDigit, IntSoFar) = IntSuffix
+ %
+:- func int_suffix_2(string, int, int, int) = int.
+
+int_suffix_2(S, I, R, N) =
+ (
+ 0 =< I,
+ digit_to_int(S `unsafe_index` I, D),
+ D < 10
+ ->
+ int_suffix_2(S, I - 1, 10 * R, (R * D) + N)
+ ;
+ N
+ ).
+
+%-----------------------------------------------------------------------------%
+
+finish_equivalence(SInfoBefore, SInfoEqv, SInfo) :-
+ finish_negation(SInfoBefore, SInfoEqv, SInfo).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_call(ParentSInfo, SInfo) :-
+ ( ParentSInfo ^ ctxt = in_atom(UpdatedStateVars, _GrandparentSInfo) ->
+ Ctxt = in_atom(UpdatedStateVars, ParentSInfo)
+ ;
+ Ctxt = in_atom(set__init, ParentSInfo)
+ ),
+ SInfo = ParentSInfo ^ ctxt := Ctxt.
+
+%-----------------------------------------------------------------------------%
+
+finish_call(!VarSet, !SInfo) :-
+ ( !.SInfo ^ ctxt = in_atom(UpdatedStateVars, ParentSInfo0) ->
+ ParentSInfo = ( ParentSInfo0 ^ dot := !.SInfo ^ dot ),
+ ( ParentSInfo ^ ctxt = in_atom(_, GrandParentSInfo) ->
+ !:SInfo = ( ParentSInfo ^ ctxt :=
+ in_atom(UpdatedStateVars, GrandParentSInfo) )
+ ;
+ prepare_for_next_conjunct(UpdatedStateVars, !VarSet, ParentSInfo,
+ !:SInfo)
+ )
+ ;
+ error("make_hlds__finish_call: ctxt is not in_atom")
+ ).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_if_then_else_goal(StateVars, !VarSet, !SInfo) :-
+ prepare_for_local_state_vars(StateVars, !VarSet, !SInfo).
+
+%-----------------------------------------------------------------------------%
+
+finish_if_then_else_goal_condition(StateVars, SInfoBefore, SInfoA0, SInfoA,
+ SInfoB) :-
+ SInfoB = SInfoA0,
+ finish_local_state_vars(StateVars, _, SInfoBefore, SInfoA0, SInfoA).
+
+%-----------------------------------------------------------------------------%
+
+finish_if_then_else_goal_then_goal(StateVars, SInfoBefore, SInfoB0, SInfoB) :-
+ finish_local_state_vars(StateVars, _, SInfoBefore, SInfoB0, SInfoB).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_if_then_else_expr(StateVars, !VarSet, !SInfo) :-
+ SInfo0 = !.SInfo,
+ !:SInfo = new_svar_info ^ ctxt := in_body,
+ !:SInfo = !.SInfo ^ external_dot := SInfo0 ^ dot,
+ !:SInfo = !.SInfo ^ num := SInfo0 ^ num,
+ prepare_for_local_state_vars(StateVars, !VarSet, !SInfo).
+
+%-----------------------------------------------------------------------------%
+
+finish_if_then_else_expr_condition(Before, !SInfo) :-
+ SInfo0 = !.SInfo,
+ !:SInfo = !.SInfo ^ external_dot := Before ^ external_dot,
+ !:SInfo = !.SInfo ^ dot := (SInfo0 ^ dot) `overlay` (Before ^ dot),
+ !:SInfo = !.SInfo ^ colon := (SInfo0 ^ colon) `overlay` (Before ^ colon),
+ !:SInfo = !.SInfo ^ ctxt := Before ^ ctxt.
+
+%-----------------------------------------------------------------------------%
+
+finish_if_then_else_expr_then_goal(StateVars, SInfoBefore, !SInfo) :-
+ finish_local_state_vars(StateVars, _, SInfoBefore, !SInfo).
+
+%-----------------------------------------------------------------------------%
+
+prepare_for_next_conjunct(UpdatedStateVars, !VarSet, !SInfo) :-
+ Dot0 = !.SInfo ^ dot,
+ Colon0 = !.SInfo ^ colon,
+ N = !.SInfo ^ num + 1,
+ map__init(Nil),
+ map__foldl(next_dot_mapping(UpdatedStateVars, Dot0, Colon0), Colon0,
+ Nil, Dot),
+ map__foldl2(next_colon_mapping(UpdatedStateVars, Colon0, N), Colon0,
+ !VarSet, Nil, Colon),
+ !:SInfo = !.SInfo ^ ctxt := in_body,
+ !:SInfo = !.SInfo ^ num := N,
+ !:SInfo = !.SInfo ^ dot := Dot,
+ !:SInfo = !.SInfo ^ colon := Colon.
+
+ % If the state variable has been updated (i.e. there was a !:X
+ % reference) then the next !.X mapping will be the current !:X
+ % mapping.
+ % Otherwise, preserve the current !.X mapping, if any (there
+ % may be none if, for example, the head only references !:X
+ % and there have been no prior references to !:X in the body.)
+ %
+:- pred next_dot_mapping(svar_set::in, svar_map::in, svar_map::in, svar::in,
+ prog_var::in, svar_map::in, svar_map::out) is det.
+
+next_dot_mapping(UpdatedStateVars, OldDot, OldColon, StateVar, _, Dot0, Dot) :-
+ ( UpdatedStateVars `contains` StateVar ->
+ Var = OldColon ^ det_elem(StateVar),
+ Dot = ( Dot0 ^ elem(StateVar) := Var )
+ ; Var = OldDot ^ elem(StateVar) ->
+ Dot = ( Dot0 ^ elem(StateVar) := Var )
+ ;
+ Dot = Dot0
+ ).
+
+ % If the state variable has been updated (i.e. there was a !:X
+ % reference) then create a new mapping for the next !:X.
+ % Otherwise, the next !:X mapping is the same as the current
+ % !:X mapping.
+ %
+:- pred next_colon_mapping(svar_set::in, svar_map::in, int::in, svar::in,
+ prog_var::in, prog_varset::in, prog_varset::out,
+ svar_map::in, svar_map::out) is det.
+
+next_colon_mapping(UpdatedStateVars, OldColon, N, StateVar, _,
+ !VarSet, !Colon) :-
+ ( UpdatedStateVars `contains` StateVar ->
+ next_svar_mapping(N, StateVar, _Var, !VarSet, !Colon)
+ ;
+ !:Colon = ( !.Colon ^ elem(StateVar) := OldColon ^ det_elem(StateVar) )
+ ).
+
+:- pred next_svar_mapping(int::in, svar::in, prog_var::out,
+ prog_varset::in, prog_varset::out, svar_map::in, svar_map::out) is det.
+
+next_svar_mapping(N, StateVar, Var, !VarSet, !Map) :-
+ Name = string__format("STATE_VARIABLE_%s_%d",
+ [s(varset__lookup_name(!.VarSet, StateVar)), i(N)]),
+ varset__new_named_var(!.VarSet, Name, Var, !:VarSet),
+ !:Map = ( !.Map ^ elem(StateVar) := Var ).
+
+%-----------------------------------------------------------------------------%
+
+expand_bang_state_var_args(Args) =
+ list__foldr(expand_bang_state_var, Args, []).
+
+:- func expand_bang_state_var(prog_term, list(prog_term)) = list(prog_term).
+
+expand_bang_state_var(T @ variable(_), Ts) = [T | Ts].
+
+expand_bang_state_var(T @ functor(Const, Args, Ctxt), Ts) =
+ (
+ Const = atom("!"),
+ Args = [variable(_StateVar)]
+ ->
+ [functor(atom("!."), Args, Ctxt), functor(atom("!:"), Args, Ctxt) | Ts]
+ ;
+ [T | Ts]
+ ).
+
+%-----------------------------------------------------------------------------%
+
+expand_bang_state_var_args_in_instance_method_heads(abstract) = abstract.
+
+expand_bang_state_var_args_in_instance_method_heads(concrete(Methods)) =
+ concrete(list__map(expand_method_bsvs, Methods)).
+
+:- func expand_method_bsvs(instance_method) = instance_method.
+
+expand_method_bsvs(IM) = IM :-
+ IM = instance_method(_, _, name(_), _, _).
+
+expand_method_bsvs(IM0) = IM :-
+ IM0 = instance_method(PredOrFunc, Method, clauses(Cs0), Arity0, Ctxt),
+ Cs = list__map(expand_item_bsvs, Cs0),
+ % Note that the condition should always succeed...
+ %
+ ( Cs = [clause(_, _, _, Args, _) | _] ->
+ adjust_func_arity(PredOrFunc, Arity, list__length(Args))
+ ;
+ Arity = Arity0
+ ),
+ IM = instance_method(PredOrFunc, Method, clauses(Cs), Arity, Ctxt).
+
+ % The instance method clause items will all be clause items.
+ %
+:- func expand_item_bsvs(item) = item.
+
+expand_item_bsvs(Item) =
+ ( Item = clause(VarSet, PredOrFunc, SymName, Args, Body) ->
+ clause(VarSet, PredOrFunc, SymName, expand_bang_state_var_args(Args),
+ Body)
+ ;
+ Item
+ ).
+
+%-----------------------------------------------------------------------------%
+
+substitute_state_var_mappings([], [], !VarSet, !SInfo, !IO).
+substitute_state_var_mappings([Arg0 | Args0], [Arg | Args],
+ !VarSet, !SInfo, !IO) :-
+ substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO),
+ substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO).
+
+substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO) :-
+ (
+ Arg0 = functor(atom("!."), [variable(StateVar)], Context)
+ ->
+ dot(Context, StateVar, Var, !VarSet, !SInfo, !IO),
+ Arg = variable(Var)
+ ;
+ Arg0 = functor(atom("!:"), [variable(StateVar)], Context)
+ ->
+ colon(Context, StateVar, Var, !VarSet, !SInfo, !IO),
+ Arg = variable(Var)
+ ;
+ Arg = Arg0
+ ).
+
+%-----------------------------------------------------------------------------%
+
+illegal_state_var_func_result(function, Args, StateVar) :-
+ list__last(Args, functor(atom("!"), [variable(StateVar)], _Ctxt)).
+
+%-----------------------------------------------------------------------------%
+
+lambda_args_contain_bang_state_var([Arg | Args], StateVar) :-
+ ( Arg = functor(atom("!"), [variable(StateVar0)], _) ->
+ StateVar = StateVar0
+ ;
+ lambda_args_contain_bang_state_var(Args, StateVar)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+report_illegal_state_var_update(Context, VarSet, StateVar, !IO) :-
+ Name = varset__lookup_name(VarSet, StateVar),
+ % XXX: why the nl here?
+ Pieces = [nl, words("Error: cannot use"), fixed("!:" ++ Name),
+ words("in this context;"), nl,
+ words("however"), fixed("!." ++ Name), words("may be used here.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pred report_non_visible_state_var(string::in, prog_context::in,
+ prog_varset::in, svar::in, io::di, io::uo) is det.
+
+report_non_visible_state_var(DorC, Context, VarSet, StateVar, !IO) :-
+ Name = varset__lookup_name(VarSet, StateVar),
+ Pieces = [words("Error: state variable"),
+ fixed("!" ++ DorC ++ Name), words("is not visible in this context.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+%-----------------------------------------------------------------------------%
+
+:- pred report_unitialized_state_var(prog_context::in, prog_varset::in,
+ svar::in, io::di, io::uo) is det.
+
+report_unitialized_state_var(Context, VarSet, StateVar, !IO) :-
+ Name = varset__lookup_name(VarSet, StateVar),
+ Pieces = [words("Warning: reference to unitialized state variable"),
+ fixed("!." ++ Name), suffix("."), nl],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ record_warning(!IO).
+
+%-----------------------------------------------------------------------------%
+
+report_illegal_func_svar_result(Context, VarSet, StateVar, !IO) :-
+ Name = varset__lookup_name(VarSet, StateVar),
+ Pieces = [words("Error:"), fixed("!" ++ Name),
+ words("cannot be a function result."), nl,
+ words("You probably meant"), fixed("!." ++ Name),
+ words("or"), fixed("!:" ++ Name), suffix("."), nl],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+%-----------------------------------------------------------------------------%
+
+report_illegal_bang_svar_lambda_arg(Context, VarSet, StateVar, !IO) :-
+ Name = varset__lookup_name(VarSet, StateVar),
+ Pieces = [words("Error:"), fixed("!" ++ Name),
+ words("cannot be a lambda argument."), nl,
+ words("Perhaps you meant"), fixed("!." ++ Name),
+ words("or"), fixed("!:" ++ Name), suffix("."), nl],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io__set_exit_status(1, !IO).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: compiler/superhomogeneous.m
===================================================================
RCS file: compiler/superhomogeneous.m
diff -N compiler/superhomogeneous.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/superhomogeneous.m 25 Jul 2005 08:26:38 -0000
@@ -0,0 +1,827 @@
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2005 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: superhomogeneous.m.
+% Main author: fjh.
+
+% This module performs the conversion of clause bodies
+% to superhomogeneous form.
+
+:- module hlds__make_hlds__superhomogeneous.
+
+:- interface.
+
+:- import_module hlds__hlds_goal.
+:- import_module hlds__hlds_pred.
+:- import_module hlds__hlds_module.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module hlds__make_hlds__state_var.
+:- import_module mdbcomp__prim_data.
+:- import_module parse_tree__prog_data.
+
+:- import_module assoc_list.
+:- import_module io.
+:- import_module list.
+
+:- type arg_context
+ ---> head(pred_or_func, arity)
+ % the arguments in the head of the clause
+
+ ; call(call_id)
+ % the arguments in a call to a predicate
+
+ ; functor( % the arguments in a functor
+ cons_id,
+ unify_main_context,
+ unify_sub_contexts
+ ).
+
+ % `insert_arg_unifications' takes a list of variables,
+ % a list of terms to unify them with, and a goal, and
+ % inserts the appropriate unifications onto the front of
+ % the goal. It calls `unravel_unification' to ensure
+ % that each unification gets reduced to superhomogeneous form.
+ % It also gets passed an `arg_context', which indicates
+ % where the terms came from.
+ %
+ % We never insert unifications of the form X = X.
+ %
+:- pred insert_arg_unifications(list(prog_var)::in, list(prog_term)::in,
+ prog_context::in, arg_context::in,
+ hlds_goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+:- pred insert_arg_unifications_with_supplied_contexts(list(prog_var)::in,
+ list(prog_term)::in, assoc_list(int, arg_context)::in, prog_context::in,
+ hlds_goal::in, hlds_goal::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+ % append_arg_unifications is the same as insert_arg_unifications,
+ % except that the unifications are added after the goal rather
+ % than before the goal.
+ %
+:- pred append_arg_unifications(list(prog_var)::in, list(prog_term)::in,
+ prog_context::in, arg_context::in, hlds_goal::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+:- pred unravel_unification(prog_term::in, prog_term::in, prog_context::in,
+ unify_main_context::in, unify_sub_contexts::in, purity::in,
+ hlds_goal::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+ % make_fresh_arg_vars(Args, VarSet0, Vars, VarSet, !SInfo, !IO):
+ % `Vars' is a list of distinct variables corresponding to
+ % the terms in `Args'. For each term in `Args', if
+ % the term is a variable V which is distinct from the
+ % variables already produced, then the corresponding
+ % variable in `Vars' is just V, otherwise a fresh variable
+ % is allocated from `VarSet0'. `VarSet' is the resulting
+ % varset after all the necessary variables have been allocated.
+ % !SInfo and !IO are required to handle state variables.
+ %
+ % For efficiency, the list `Vars' is constructed backwards
+ % and then reversed to get the correct order.
+ %
+:- pred make_fresh_arg_vars(list(prog_term)::in, list(prog_var)::out,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
+ io::di, io::uo) is det.
+
+:- pred make_fresh_arg_var(prog_term::in, prog_var::out, list(prog_var)::in,
+ prog_varset::in, prog_varset::out, svar_info::in, svar_info::out,
+ io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module check_hlds__purity.
+:- import_module hlds__goal_util.
+:- import_module hlds__make_hlds__add_clause.
+:- import_module hlds__make_hlds__field_access.
+:- import_module hlds__make_hlds__qual_info.
+:- import_module parse_tree__error_util.
+:- import_module parse_tree__module_qual.
+:- import_module parse_tree__prog_io.
+:- import_module parse_tree__prog_io_goal.
+:- import_module parse_tree__prog_io_dcg.
+:- import_module parse_tree__prog_io_util.
+:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_util.
+
+:- import_module bool.
+:- import_module int.
+:- import_module map.
+:- import_module require.
+:- import_module set.
+:- import_module std_util.
+:- import_module term.
+:- import_module varset.
+
+insert_arg_unifications(HeadVars, Args0, Context, ArgContext,
+ !Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ (
+ HeadVars = []
+ ;
+ HeadVars = [_ | _],
+ !.Goal = _ - GoalInfo0,
+ goal_to_conj_list(!.Goal, Goals0),
+ substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO),
+ insert_arg_unifications_2(HeadVars, Args, Context, ArgContext,
+ 0, Goals0, Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_info_set_context(GoalInfo0, Context, GoalInfo),
+ conj_list_to_goal(Goals, GoalInfo, !:Goal)
+ ).
+
+:- pred insert_arg_unifications_2(list(prog_var)::in, list(prog_term)::in,
+ prog_context::in, arg_context::in, int::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+insert_arg_unifications_2([], [_ | _], _, _, _, _, _, _, _, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ error("insert_arg_unifications_2: length mismatch").
+insert_arg_unifications_2([_ | _], [], _, _, _, _, _, _, _, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ error("insert_arg_unifications_2: length mismatch").
+insert_arg_unifications_2([], [], _, _, _, !Goals, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO).
+insert_arg_unifications_2([Var | Vars], [Arg | Args], Context, ArgContext,
+ N0, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ N1 = N0 + 1,
+ insert_arg_unification(Var, Arg, Context, ArgContext, N1,
+ !VarSet, ArgUnifyConj, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ (
+ ArgUnifyConj = [],
+ % Allow the recursive call to be tail recursive.
+ insert_arg_unifications_2(Vars, Args, Context, ArgContext,
+ N1, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ ArgUnifyConj = [_ | _],
+ insert_arg_unifications_2(Vars, Args, Context, ArgContext,
+ N1, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ list__append(ArgUnifyConj, !.Goals, !:Goals)
+ ).
+
+insert_arg_unifications_with_supplied_contexts(ArgVars, ArgTerms0, ArgContexts,
+ Context, !Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo,
+ !IO) :-
+ (
+ ArgVars = []
+ ;
+ ArgVars = [_ | _],
+ !.Goal = _ - GoalInfo0,
+ goal_to_conj_list(!.Goal, GoalList0),
+ substitute_state_var_mappings(ArgTerms0, ArgTerms, !VarSet, !SInfo,
+ !IO),
+ insert_arg_unifications_with_supplied_contexts_2(ArgVars, ArgTerms,
+ ArgContexts, Context, GoalList0, GoalList, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_info_set_context(GoalInfo0, Context, GoalInfo),
+ conj_list_to_goal(GoalList, GoalInfo, !:Goal)
+ ).
+
+:- pred insert_arg_unifications_with_supplied_contexts_2(list(prog_var)::in,
+ list(prog_term)::in, assoc_list(int, arg_context)::in, prog_context::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+insert_arg_unifications_with_supplied_contexts_2(Vars, Terms, ArgContexts,
+ Context, !Goals, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ (
+ Vars = [],
+ Terms = [],
+ ArgContexts = []
+ ->
+ true
+ ;
+ Vars = [Var | VarsTail],
+ Terms = [Term | TermsTail],
+ ArgContexts = [ArgNumber - ArgContext | ArgContextsTail]
+ ->
+ insert_arg_unification(Var, Term, Context, ArgContext, ArgNumber,
+ !VarSet, UnifyConj, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ insert_arg_unifications_with_supplied_contexts_2(VarsTail, TermsTail,
+ ArgContextsTail, Context, !Goals, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO),
+ list__append(UnifyConj, !.Goals, !:Goals)
+ ;
+ error("insert_arg_unifications_with_supplied_contexts")
+ ).
+
+:- pred insert_arg_unification(prog_var::in, prog_term::in, prog_context::in,
+ arg_context::in, int::in, prog_varset::in, prog_varset::out,
+ list(hlds_goal)::out, module_info::in, module_info::out,
+ qual_info::in, qual_info::out, svar_info::in, svar_info::out,
+ io::di, io::uo) is det.
+
+insert_arg_unification(Var, Arg, Context, ArgContext, N1, !VarSet,
+ ArgUnifyConj, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ ( Arg = term__variable(Var) ->
+ % Skip unifications of the form `X = X'
+ ArgUnifyConj = []
+ ;
+ arg_context_to_unify_context(ArgContext, N1, UnifyMainContext,
+ UnifySubContext),
+ unravel_unification(term__variable(Var), Arg, Context,
+ UnifyMainContext, UnifySubContext, pure, Goal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_to_conj_list(Goal, ArgUnifyConj)
+ ).
+
+append_arg_unifications(HeadVars, Args0, Context, ArgContext,
+ !Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ (
+ HeadVars = []
+ ;
+ HeadVars = [_ | _],
+ !.Goal = _ - GoalInfo,
+ goal_to_conj_list(!.Goal, List0),
+ substitute_state_var_mappings(Args0, Args, !VarSet,
+ !SInfo, !IO),
+ append_arg_unifications_2(HeadVars, Args, Context, ArgContext,
+ 0, List0, List, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ conj_list_to_goal(List, GoalInfo, !:Goal)
+ ).
+
+:- pred append_arg_unifications_2(list(prog_var)::in, list(prog_term)::in,
+ prog_context::in, arg_context::in, int::in,
+ list(hlds_goal)::in, list(hlds_goal)::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+append_arg_unifications_2([], [_|_], _, _, _, _, _, _, _, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ error("append_arg_unifications_2: length mismatch").
+append_arg_unifications_2([_|_], [], _, _, _, _, _, _, _, !ModuleInfo,
+ !QualInfo, !SInfo, !IO) :-
+ error("append_arg_unifications_2: length mismatch").
+append_arg_unifications_2([], [], _, _, _, !List, !VarSet, !ModuleInfo,
+ !QualInfo, !SInfo, !IO).
+append_arg_unifications_2([Var|Vars], [Arg|Args], Context, ArgContext,
+ N0, !List, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ N1 = N0 + 1,
+ append_arg_unification(Var, Arg, Context, ArgContext, N1, ConjList,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ list__append(!.List, ConjList, !:List),
+ append_arg_unifications_2(Vars, Args, Context, ArgContext, N1,
+ !List, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+
+:- pred append_arg_unification(prog_var::in, prog_term::in, prog_context::in,
+ arg_context::in, int::in, list(hlds_goal)::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+append_arg_unification(Var, Arg, Context, ArgContext, N1, ConjList,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ ( Arg = term__variable(Var) ->
+ % skip unifications of the form `X = X'
+ ConjList = []
+ ;
+ arg_context_to_unify_context(ArgContext, N1, UnifyMainContext,
+ UnifySubContext),
+ unravel_unification(term__variable(Var), Arg, Context,
+ UnifyMainContext, UnifySubContext, pure, Goal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_to_conj_list(Goal, ConjList)
+ ).
+
+:- pred arg_context_to_unify_context(arg_context::in, int::in,
+ unify_main_context::out, unify_sub_contexts::out) is det.
+
+arg_context_to_unify_context(head(PredOrFunc, Arity), ArgNum,
+ ArgContext, []) :-
+ ( PredOrFunc = function, ArgNum = Arity ->
+ % it's the function result term in the head
+ ArgContext = head_result
+ ;
+ % it's a head argument
+ ArgContext = head(ArgNum)
+ ).
+arg_context_to_unify_context(call(PredId), ArgNum, call(PredId, ArgNum), []).
+arg_context_to_unify_context(functor(ConsId, MainContext, SubContexts), ArgNum,
+ MainContext, [ConsId - ArgNum | SubContexts]).
+
+%-----------------------------------------------------------------------------%
+
+make_fresh_arg_vars(Args, Vars, !VarSet, !SInfo, !IO) :-
+ make_fresh_arg_vars_2(Args, [], Vars1, !VarSet, !SInfo, !IO),
+ list__reverse(Vars1, Vars).
+
+:- pred make_fresh_arg_vars_2(list(prog_term)::in, list(prog_var)::in,
+ list(prog_var)::out, prog_varset::in,prog_varset::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+make_fresh_arg_vars_2([], Vars, Vars, !VarSet, !SInfo, !IO).
+make_fresh_arg_vars_2([Arg | Args], Vars0, Vars, !VarSet, !SInfo, !IO) :-
+ make_fresh_arg_var(Arg, Var, Vars0, !VarSet, !SInfo, !IO),
+ make_fresh_arg_vars_2(Args, [Var | Vars0], Vars, !VarSet, !SInfo, !IO).
+
+make_fresh_arg_var(Arg0, Var, Vars0, !VarSet, !SInfo, !IO) :-
+ substitute_state_var_mapping(Arg0, Arg, !VarSet, !SInfo, !IO),
+ (
+ Arg = term__variable(ArgVar),
+ \+ list__member(ArgVar, Vars0)
+ ->
+ Var = ArgVar
+ ;
+ varset__new_var(!.VarSet, Var, !:VarSet)
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ %
+ % XXX We could do better on the error messages for
+ % lambda expressions and field extraction and update expressions.
+ %
+
+unravel_unification(LHS0, RHS0, Context, MainContext, SubContext,
+ Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ substitute_state_var_mapping(LHS0, LHS, !VarSet, !SInfo, !IO),
+ substitute_state_var_mapping(RHS0, RHS, !VarSet, !SInfo, !IO),
+ unravel_unification_2(LHS, RHS, Context, MainContext, SubContext,
+ Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+
+:- pred unravel_unification_2(prog_term::in, prog_term::in, prog_context::in,
+ unify_main_context::in, unify_sub_contexts::in, purity::in,
+ hlds_goal::out, prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, svar_info::out, io::di, io::uo) is det.
+
+ % `X = Y' needs no unravelling.
+
+unravel_unification_2(term__variable(X), term__variable(Y), Context,
+ MainContext, SubContext, Purity, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ make_atomic_unification(X, var(Y), Context, MainContext, SubContext, Goal,
+ !QualInfo),
+ check_expr_purity(Purity, Context, !ModuleInfo, !IO).
+
+ % If we find a unification of the form
+ % X = f(A1, A2, A3)
+ % we replace it with
+ % X = f(NewVar1, NewVar2, NewVar3),
+ % NewVar1 = A1,
+ % NewVar2 = A2,
+ % NewVar3 = A3.
+ % In the trivial case `X = c', no unravelling occurs.
+
+unravel_unification_2(term__variable(X), RHS, Context, MainContext, SubContext,
+ Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ RHS = term__functor(F, Args1, FunctorContext),
+ substitute_state_var_mappings(Args1, Args, !VarSet, !SInfo, !IO),
+ (
+ % Handle explicit type qualification.
+ F = term__atom("with_type"),
+ Args = [RVal, DeclType0]
+ ->
+ convert_type(DeclType0, DeclType),
+ varset__coerce(!.VarSet, DeclVarSet),
+ process_type_qualification(X, DeclType, DeclVarSet,
+ Context, !ModuleInfo, !QualInfo, !IO),
+ unravel_unification(term__variable(X), RVal, Context,
+ MainContext, SubContext, Purity, Goal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ % Handle unification expressions.
+ F = term__atom("@"),
+ Args = [LVal, RVal]
+ ->
+ unravel_unification(term__variable(X), LVal, Context,
+ MainContext, SubContext, Purity, Goal1,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ unravel_unification(term__variable(X), RVal, Context,
+ MainContext, SubContext, Purity, Goal2,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_info_init(GoalInfo),
+ goal_to_conj_list(Goal1, ConjList1),
+ goal_to_conj_list(Goal2, ConjList2),
+ list__append(ConjList1, ConjList2, ConjList),
+ conj_list_to_goal(ConjList, GoalInfo, Goal)
+ ;
+ (
+ % handle lambda expressions
+ parse_lambda_eval_method(RHS, EvalMethod0, RHS1),
+ RHS1 = term__functor(term__atom("lambda"), Args1, _),
+ Args1 = [LambdaExpressionTerm0, GoalTerm0],
+ term__coerce(LambdaExpressionTerm0, LambdaExpressionTerm),
+ parse_lambda_expression(LambdaExpressionTerm, Vars0, Modes0, Det0)
+ ->
+ LambdaPurity = (pure),
+ PredOrFunc = predicate,
+ EvalMethod = EvalMethod0,
+ Vars1 = Vars0,
+ Modes1 = Modes0,
+ Det1 = Det0,
+ GoalTerm1 = GoalTerm0,
+ WarnDeprecatedLambda = yes
+ ;
+ % handle higher-order pred and func expressions -
+ % same semantics as lambda expressions, different
+ % syntax (the original lambda expression syntax
+ % is now deprecated)
+ parse_rule_term(Context, RHS, HeadTerm0, GoalTerm1),
+ term__coerce(HeadTerm0, HeadTerm1),
+ parse_purity_annotation(HeadTerm1, LambdaPurity,
+ HeadTerm),
+ (
+ parse_pred_expression(HeadTerm, EvalMethod0,
+ Vars0, Modes0, Det0)
+ ->
+ PredOrFunc = predicate,
+ EvalMethod = EvalMethod0,
+ Vars1 = Vars0,
+ Modes1 = Modes0,
+ Det1 = Det0
+ ;
+ parse_func_expression(HeadTerm, EvalMethod,
+ Vars1, Modes1, Det1),
+ PredOrFunc = function
+ ),
+ WarnDeprecatedLambda = no
+ )
+ ->
+ (
+ WarnDeprecatedLambda = yes,
+ report_warning(Context, 0,
+ [words("Warning:"),
+ words("deprecated lambda expression syntax."),
+ nl,
+ words("Lambda expressions with lambda as the"),
+ words("top-level functor are deprecated;"),
+ words("please use the form"),
+ words("using pred instead.")],
+ !IO)
+ ;
+ WarnDeprecatedLambda = no
+ ),
+ check_expr_purity(Purity, Context, !ModuleInfo, !IO),
+ add_clause__qualify_lambda_mode_list(Modes1, Modes, Context,
+ !QualInfo, !IO),
+ Det = Det1,
+ term__coerce(GoalTerm1, GoalTerm),
+ parse_goal(GoalTerm, ParsedGoal, !VarSet),
+ build_lambda_expression(X, LambdaPurity, PredOrFunc, EvalMethod,
+ Vars1, Modes, Det, ParsedGoal, Context, MainContext,
+ SubContext, Goal, !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO)
+ ;
+ % handle higher-order dcg pred expressions -
+ % same semantics as higher-order pred expressions,
+ % but has two extra arguments, and the goal is expanded
+ % as a DCG goal.
+ F = term__atom("-->"),
+ Args = [PredTerm0, GoalTerm0],
+ term__coerce(PredTerm0, PredTerm1),
+ parse_purity_annotation(PredTerm1, DCGLambdaPurity, PredTerm),
+ parse_dcg_pred_expression(PredTerm, EvalMethod, Vars0, Modes0, Det)
+ ->
+ add_clause__qualify_lambda_mode_list(Modes0, Modes, Context, !QualInfo,
+ !IO),
+ term__coerce(GoalTerm0, GoalTerm),
+ parse_dcg_pred_goal(GoalTerm, ParsedGoal, DCG0, DCGn, !VarSet),
+ list__append(Vars0, [term__variable(DCG0), term__variable(DCGn)],
+ Vars1),
+ build_lambda_expression(X, DCGLambdaPurity, predicate, EvalMethod,
+ Vars1, Modes, Det, ParsedGoal, Context, MainContext, SubContext,
+ Goal0, !VarSet, !ModuleInfo, !QualInfo, !.SInfo, !IO),
+ Goal0 = GoalExpr - GoalInfo0,
+ add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo),
+ Goal = GoalExpr - GoalInfo
+ ;
+ % handle if-then-else expressions
+ (
+ F = term__atom("else"),
+ IfThenTerm = term__functor(
+ term__atom("if"),
+ [term__functor(term__atom("then"), [IfTerm0, ThenTerm], _)],
+ _),
+ Args = [IfThenTerm, ElseTerm]
+ ;
+ F = term__atom(";"),
+ Args = [term__functor(term__atom("->"), [IfTerm0, ThenTerm], _),
+ ElseTerm]
+ ),
+ term__coerce(IfTerm0, IfTerm),
+ parse_some_vars_goal(IfTerm, Vars, StateVars, IfParseTree, !VarSet)
+ ->
+ BeforeSInfo = !.SInfo,
+ prepare_for_if_then_else_expr(StateVars, !VarSet, !SInfo),
+
+ check_expr_purity(Purity, Context, !ModuleInfo, !IO),
+ map__init(EmptySubst),
+ transform_goal(IfParseTree, EmptySubst, IfGoal, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ finish_if_then_else_expr_condition(BeforeSInfo, !SInfo),
+
+ unravel_unification(term__variable(X), ThenTerm,
+ Context, MainContext, SubContext, pure, ThenGoal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ finish_if_then_else_expr_then_goal(StateVars, BeforeSInfo, !SInfo),
+
+ unravel_unification(term__variable(X), ElseTerm,
+ Context, MainContext, SubContext, pure,
+ ElseGoal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ IfThenElse = if_then_else(StateVars ++ Vars, IfGoal, ThenGoal,
+ ElseGoal),
+ goal_info_init(Context, GoalInfo),
+ Goal = IfThenElse - GoalInfo
+ ;
+ % handle field extraction expressions
+ F = term__atom("^"),
+ Args = [InputTerm, FieldNameTerm],
+ parse_field_list(FieldNameTerm, FieldNameResult),
+ FieldNameResult = ok(FieldNames)
+ ->
+ check_expr_purity(Purity, Context, !ModuleInfo, !IO),
+ make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo, !IO),
+ expand_get_field_function_call(Context, MainContext, SubContext,
+ FieldNames, X, InputTermVar, !VarSet, Functor, _, Goal0,
+ !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ ArgContext = functor(Functor, MainContext, SubContext),
+ insert_arg_unifications([InputTermVar], [InputTerm],
+ FunctorContext, ArgContext, Goal0, Goal,
+ !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ % handle field update expressions
+ F = term__atom(":="),
+ Args = [FieldDescrTerm, FieldValueTerm],
+ FieldDescrTerm = term__functor(term__atom("^"),
+ [InputTerm, FieldNameTerm], _),
+ parse_field_list(FieldNameTerm, FieldNameResult),
+ FieldNameResult = ok(FieldNames)
+ ->
+ check_expr_purity(Purity, Context, !ModuleInfo, !IO),
+ make_fresh_arg_var(InputTerm, InputTermVar, [], !VarSet, !SInfo, !IO),
+ make_fresh_arg_var(FieldValueTerm, FieldValueVar, [InputTermVar],
+ !VarSet, !SInfo, !IO),
+
+ expand_set_field_function_call(Context, MainContext, SubContext,
+ FieldNames, FieldValueVar, InputTermVar, X, !VarSet,
+ Functor, InnerFunctor - FieldSubContext, Goal0,
+ !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ TermArgContext = functor(Functor, MainContext, SubContext),
+ TermArgNumber = 1,
+ FieldArgContext = functor(InnerFunctor, MainContext, FieldSubContext),
+ FieldArgNumber = 2,
+ ArgContexts = [TermArgNumber - TermArgContext,
+ FieldArgNumber - FieldArgContext],
+ insert_arg_unifications_with_supplied_contexts(
+ [InputTermVar, FieldValueVar],
+ [InputTerm, FieldValueTerm], ArgContexts, Context,
+ Goal0, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ % handle the usual case
+ parse_qualified_term(RHS, RHS, "", MaybeFunctor),
+ (
+ MaybeFunctor = ok(FunctorName, FunctorArgs),
+ list__length(FunctorArgs, Arity),
+ ConsId = cons(FunctorName, Arity)
+ ;
+ % float, int or string constant
+ % - any errors will be caught by typechecking
+ MaybeFunctor = error(_, _),
+ list__length(Args, Arity),
+ ConsId = make_functor_cons_id(F, Arity),
+ FunctorArgs = Args
+ ),
+ (
+ FunctorArgs = [],
+ make_atomic_unification(X, functor(ConsId, no, []), Context,
+ MainContext, SubContext, Goal0, !QualInfo),
+ Goal0 = GoalExpr - GoalInfo0,
+ add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo),
+ % We could attach the from_ground_term feature to Goal,
+ % but there would be no gain from doing so, whereas the
+ % increase would lead to a slight increase in memory and time
+ % requirements.
+ Goal = GoalExpr - GoalInfo
+ ;
+ FunctorArgs = [_ | _],
+ make_fresh_arg_vars(FunctorArgs, HeadVars, !VarSet, !SInfo, !IO),
+ make_atomic_unification(X, functor(ConsId, no, HeadVars), Context,
+ MainContext, SubContext, Goal0, !QualInfo),
+ ArgContext = functor(ConsId, MainContext, SubContext),
+ % Should this be insert_... rather than append_...?
+ % No, because that causes efficiency problems
+ % with type-checking :-(
+ % But for impure unifications, we need to do
+ % this, because mode reordering can't reorder
+ % around the functor unification.
+ ( Purity = pure ->
+ append_arg_unifications(HeadVars, FunctorArgs, FunctorContext,
+ ArgContext, Goal0, Goal2, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ;
+ Goal0 = GoalExpr0 - GoalInfo0,
+ add_goal_info_purity_feature(GoalInfo0, Purity, GoalInfo1),
+ Goal1 = GoalExpr0 - GoalInfo1,
+ insert_arg_unifications(HeadVars, FunctorArgs, FunctorContext,
+ ArgContext, Goal1, Goal2, !VarSet,
+ !ModuleInfo, !QualInfo, !SInfo, !IO)
+ ),
+ % This "optimization" is disabled, because the extra cost of
+ % traversing the scope goals in typechecking is more than the
+ % savings from the reduction in delays/wakeups in modechecking.
+ (
+ semidet_fail,
+ ground_terms(FunctorArgs)
+ ->
+ % This insertion of the `scope' goal is undone by the code
+ % handling `scope' goals in modecheck_goal_expr in modes.m.
+
+ Goal2 = _GoalExpr2 - GoalInfo,
+ GoalExpr = scope(from_ground_term(X), Goal2),
+ Goal = GoalExpr - GoalInfo
+ ;
+ Goal = Goal2
+ )
+ )
+ ).
+
+ % Handle `f(...) = X' in the same way as `X = f(...)'.
+
+unravel_unification_2(term__functor(F, As, FC), term__variable(Y), C, MC, SC,
+ Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ unravel_unification(term__variable(Y), term__functor(F, As, FC), C, MC, SC,
+ Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO).
+
+ % If we find a unification of the form `f1(...) = f2(...)',
+ % then we replace it with `Tmp = f1(...), Tmp = f2(...)',
+ % and then process it according to the rule above.
+ % Note that we can't simplify it yet, because we might simplify
+ % away type errors.
+
+unravel_unification_2(term__functor(LeftF, LeftAs, LeftC),
+ term__functor(RightF, RightAs, RightC),
+ Context, MainContext, SubContext,
+ Purity, Goal, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO) :-
+ varset__new_var(!.VarSet, TmpVar, !:VarSet),
+ unravel_unification(term__variable(TmpVar),
+ term__functor(LeftF, LeftAs, LeftC),
+ Context, MainContext, SubContext,
+ Purity, Goal0, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ unravel_unification(term__variable(TmpVar),
+ term__functor(RightF, RightAs, RightC),
+ Context, MainContext, SubContext,
+ Purity, Goal1, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+ goal_info_init(GoalInfo),
+ goal_to_conj_list(Goal0, ConjList0),
+ goal_to_conj_list(Goal1, ConjList1),
+ list__append(ConjList0, ConjList1, ConjList),
+ conj_list_to_goal(ConjList, GoalInfo, Goal).
+
+:- pred ground_term(term(T)::in) is semidet.
+
+ground_term(term__functor(_, Terms, _)) :-
+ ground_terms(Terms).
+
+:- pred ground_terms(list(term(T))::in) is semidet.
+
+ground_terms([]).
+ground_terms([Term | Terms]) :-
+ ground_term(Term),
+ ground_terms(Terms).
+
+%-----------------------------------------------------------------------------%
+:- pred build_lambda_expression(prog_var::in, purity::in, pred_or_func::in,
+ lambda_eval_method::in, list(prog_term)::in, list(mode)::in,
+ determinism::in, goal::in, prog_context::in, unify_main_context::in,
+ unify_sub_contexts::in, hlds_goal::out,
+ prog_varset::in, prog_varset::out,
+ module_info::in, module_info::out, qual_info::in, qual_info::out,
+ svar_info::in, io::di, io::uo) is det.
+
+build_lambda_expression(X, Purity, PredOrFunc, EvalMethod, Args0, Modes, Det,
+ ParsedGoal, Context, MainContext, SubContext, Goal, !VarSet,
+ !ModuleInfo, !QualInfo, !.SInfo, !IO) :-
+ %
+ % In the parse tree, the lambda arguments can be any terms.
+ % But in the HLDS, they must be distinct variables. So we introduce
+ % fresh variables for the lambda arguments, and add appropriate
+ % unifications.
+ %
+ % For example, we convert from
+ % X = (func(f(A, B), c) = D :- G)
+ % to
+ % X = (func(H1, H2) = H3 :-
+ % some [A, B] (H1 = f(A, B), H2 = c, H3 = D).
+ %
+ % Note that the quantification is important here.
+ % That's why we need to introduce the explicit `some [...]'.
+ % Variables in the argument positions are lambda-quantified,
+ % so when we move them to the body, we need to make them
+ % explicitly existentially quantified, to avoid capturing
+ % any variables of the same name that occur outside this scope.
+ %
+ % For predicates, all variables occuring in the lambda arguments
+ % are locally quantified to the lambda goal.
+ % For functions, we need to be careful because variables in
+ % arguments should similarly be quantified, but variables in
+ % the function return value term (and not in the arguments)
+ % should *not* be locally quantified.
+ %
+
+ %
+ % Create fresh variables, transform the goal to HLDS,
+ % and add unifications with the fresh variables.
+ % We use varset__new_vars rather than make_fresh_arg_vars,
+ % since for functions we need to ensure that the variable
+ % corresponding to the function result term is a new variable,
+ % to avoid the function result term becoming lambda-quantified.
+ %
+ (
+ illegal_state_var_func_result(PredOrFunc, Args0, StateVar)
+ ->
+ report_illegal_func_svar_result(Context, !.VarSet, StateVar, !IO),
+ true_goal(Goal)
+ ;
+ lambda_args_contain_bang_state_var(Args0, StateVar)
+ ->
+ report_illegal_bang_svar_lambda_arg(Context, !.VarSet, StateVar, !IO),
+ true_goal(Goal)
+ ;
+ prepare_for_lambda(!SInfo),
+ substitute_state_var_mappings(Args0, Args, !VarSet, !SInfo, !IO),
+
+ list__length(Args, NumArgs),
+ varset__new_vars(!.VarSet, NumArgs, LambdaVars, !:VarSet),
+ map__init(Substitution),
+ hlds_goal__true_goal(Head0),
+ ArgContext = head(PredOrFunc, NumArgs),
+
+ insert_arg_unifications(LambdaVars, Args, Context, ArgContext,
+ Head0, Head, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ prepare_for_body(FinalSVarMap, !VarSet, !SInfo),
+
+ transform_goal(ParsedGoal, Substitution,
+ Body, !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO),
+
+ finish_head_and_body(Context, FinalSVarMap,
+ Head, Body, HLDS_Goal0, !.SInfo),
+
+ %
+ % Now figure out which variables we need to
+ % explicitly existentially quantify.
+ %
+ (
+ PredOrFunc = predicate,
+ QuantifiedArgs = Args
+ ;
+ PredOrFunc = function,
+ pred_args_to_func_args(Args, QuantifiedArgs, _ReturnValTerm)
+ ),
+ term__vars_list(QuantifiedArgs, QuantifiedVars0),
+ list__sort_and_remove_dups(QuantifiedVars0, QuantifiedVars),
+
+ goal_info_init(Context, GoalInfo),
+ HLDS_Goal = scope(exist_quant(QuantifiedVars), HLDS_Goal0) - GoalInfo,
+
+ %
+ % We set the lambda nonlocals here to anything that
+ % could possibly be nonlocal. Quantification will
+ % reduce this down to the proper set of nonlocal arguments.
+ %
+ goal_util__goal_vars(HLDS_Goal, LambdaGoalVars0),
+ set__delete_list(LambdaGoalVars0, LambdaVars, LambdaGoalVars1),
+ set__delete_list(LambdaGoalVars1, QuantifiedVars, LambdaGoalVars2),
+ set__to_sorted_list(LambdaGoalVars2, LambdaNonLocals),
+
+ make_atomic_unification(X,
+ lambda_goal(Purity, PredOrFunc, EvalMethod, modes_are_ok,
+ LambdaNonLocals, LambdaVars, Modes, Det, HLDS_Goal),
+ Context, MainContext, SubContext, Goal, !QualInfo)
+ ).
+
+:- pred check_expr_purity(purity::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+check_expr_purity(Purity, Context, !ModuleInfo, !IO) :-
+ ( Purity \= pure ->
+ impure_unification_expr_error(Context, Purity, !IO),
+ module_info_incr_errors(!ModuleInfo)
+ ;
+ true
+ ).
+
+%-----------------------------------------------------------------------------%
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.151
diff -u -b -r1.151 type_util.m
--- compiler/type_util.m 22 Jul 2005 12:32:00 -0000 1.151
+++ compiler/type_util.m 25 Jul 2005 03:03:16 -0000
@@ -35,19 +35,21 @@
% Succeed iff type is an "atomic" type - one which can be
% unified using a simple_test rather than a complicated_unify.
-
+ %
:- pred type_is_atomic((type)::in, module_info::in) is semidet.
:- pred type_ctor_is_atomic(type_ctor::in, module_info::in) is semidet.
% The list of type_ctors which are builtins which do not have a
% hlds_type_defn.
+ %
:- func builtin_type_ctors_with_no_hlds_type_defn = list(type_ctor).
% Obtain the type definition and type definition body respectively,
% if known, for the principal type constructor of the given type.
%
% Fail if the given type is a type variable.
+ %
:- pred type_util__type_to_type_defn(module_info::in, (type)::in,
hlds_type_defn::out) is semidet.
@@ -64,6 +66,7 @@
%
% If the type is a type variable and thus has no principal type
% constructor, fail.
+ %
:- pred type_has_user_defined_equality_pred(module_info::in, (type)::in,
unify_compare::out) is semidet.
@@ -75,6 +78,7 @@
%
% If the type is a type variable and thus has no principal type
% constructor, fail.
+ %
:- pred type_util__type_is_solver_type(module_info::in, (type)::in) is semidet.
:- pred type_util__type_has_solver_type_details(module_info::in, (type)::in,
@@ -98,6 +102,7 @@
% there is no need to actually pass them, and so when
% importing or exporting procedures to/from C, we don't
% include arguments with these types.
+ %
:- pred type_util__is_dummy_argument_type((type)::in) is semidet.
:- pred type_util__constructors_are_dummy_argument_type(list(constructor)::in)
@@ -110,6 +115,7 @@
:- pred type_ctor_is_array(type_ctor::in) is semidet.
% Remove an `aditi:state' from the given list if one is present.
+ %
:- pred type_util__remove_aditi_state(list(type)::in, list(T)::in,
list(T)::out) is det.
@@ -117,7 +123,7 @@
% are `lies', i.e. they are not sufficiently accurate for RTTI
% structures describing the types. Since the RTTI will be hand defined,
% the compiler shouldn't generate RTTI for these types.
-
+ %
:- pred type_ctor_has_hand_defined_rtti(type_ctor::in, hlds_type_body::in)
is semidet.
@@ -126,7 +132,7 @@
% places. For example, mode inference never infers unique modes
% for these types, since it would not be useful, and since we
% want to minimize the number of different modes that we infer.
-
+ %
:- pred is_introduced_type_info_type((type)::in) is semidet.
:- pred is_introduced_type_info_type_ctor(type_ctor::in) is semidet.
@@ -138,6 +144,7 @@
% preceding the non-type_info-related variables (with the relative
% order of variables within each group being the same as in the
% original list).
+ %
:- func put_typeinfo_vars_first(list(prog_var), vartypes) = list(prog_var).
% In the forwards mode, this predicate checks for a "new " prefix
@@ -146,15 +153,18 @@
% In the reverse mode, this predicate prepends such a prefix.
% (These prefixes are used for construction unifications
% with existentially typed functors.)
+ %
:- pred remove_new_prefix(sym_name, sym_name).
:- mode remove_new_prefix(in, out) is semidet.
:- mode remove_new_prefix(out, in) is det.
% Given a type, determine what category its principal constructor
% falls into.
+ %
:- func classify_type(module_info, type) = type_category.
% Given a type_ctor, determine what sort it is.
+ %
:- func classify_type_ctor(module_info, type_ctor) = type_category.
:- type type_category
@@ -190,16 +200,17 @@
:- func aditi_state_type = (type).
% Construct type_infos and type_ctor_infos for the given types.
+ %
:- func type_info_type(type) = (type).
:- func type_ctor_info_type(type) = (type).
% Given a constant and an arity, return a type_ctor.
% Fails if the constant is not an atom.
-
+ %
:- pred make_type_ctor(const::in, int::in, type_ctor::out) is semidet.
% Given a type_ctor, look up its module/name/arity
-
+ %
:- pred type_util__type_ctor_module(module_info::in, type_ctor::in,
module_name::out) is det.
@@ -211,6 +222,7 @@
% If the type is a du type or a tuple type,
% return the list of its constructors.
+ %
:- pred type_constructors((type)::in, module_info::in, list(constructor)::out)
is semidet.
@@ -221,6 +233,7 @@
% float, and switch. One cannot have a switch on an abstract type,
% and equivalence types will have been expanded out by the time
% we consider switches.)
+ %
:- pred type_util__switch_type_num_functors(module_info::in, (type)::in,
int::out) is semidet.
@@ -230,18 +243,21 @@
% Note that this will substitute appropriate values for
% any type variables in the functor's argument types,
% to match their bindings in the functor's type.
+ %
:- pred type_util__get_cons_id_arg_types(module_info::in, (type)::in,
cons_id::in, list(type)::out) is det.
% The same as type_util__get_cons_id_arg_types except that it
% fails rather than aborting if the functor is existentially
% typed.
+ %
:- pred type_util__get_cons_id_non_existential_arg_types(module_info::in,
(type)::in, cons_id::in, list(type)::out) is semidet.
% The same as type_util__get_cons_id_arg_types except that the
% cons_id is output non-deterministically.
% The cons_id is not module-qualified.
+ %
:- pred type_util__cons_id_arg_types(module_info::in, (type)::in,
cons_id::out, list(type)::out) is nondet.
@@ -251,11 +267,13 @@
% functor's argument types; they will be left unbound,
% so the caller can find out the original types from the constructor
% definition. The caller must do that sustitution itself if required.
+ %
:- pred type_util__get_type_and_cons_defn(module_info::in, (type)::in,
cons_id::in, hlds_type_defn::out, hlds_cons_defn::out) is det.
% Like type_util__get_type_and_cons_defn (above), except that it
% only returns the definition of the constructor, not the type.
+ %
:- pred type_util__get_cons_defn(module_info::in, type_ctor::in, cons_id::in,
hlds_cons_defn::out) is semidet.
@@ -266,6 +284,7 @@
% The list(prog_var) is the list of arguments to the cons_id and is just
% used for obtaining the arity for typeclass_info and type_info
% cons_ids.
+ %
:- pred qualify_cons_id((type)::in, list(prog_var)::in, cons_id::in,
cons_id::out, cons_id::out) is det.
@@ -276,6 +295,7 @@
% functor's argument types; they will be left unbound,
% so the caller can find out the original types from the constructor
% definition. The caller must do that sustitution itself if required.
+ %
:- pred type_util__get_existq_cons_defn(module_info::in, (type)::in,
cons_id::in, ctor_defn::out) is semidet.
@@ -285,6 +305,7 @@
% This type is used to return information about a constructor
% definition, extracted from the hlds_type_defn and hlds_cons_defn
% data types.
+ %
:- type ctor_defn
---> ctor_defn(
tvarset,
@@ -298,7 +319,7 @@
% (i.e. one with only one constructor, and
% whose one constructor has only one argument),
% and if so, return its constructor symbol and argument type.
-
+ %
:- pred type_is_no_tag_type(module_info::in, (type)::in, sym_name::out,
(type)::out) is semidet.
@@ -312,19 +333,22 @@
% (such as turning off no_tag_types). If you want those checks
% you should use type_is_no_tag_type/4, or if you really know
% what you are doing, perform the checks yourself.
-
+ %
:- pred type_constructors_are_no_tag_type(list(constructor)::in, sym_name::out,
(type)::out, maybe(string)::out) is semidet.
% Given a list of constructors for a type, check whether that
% type is a private_builtin:type_info/n or similar type.
+ %
:- pred type_constructors_are_type_info(list(constructor)::in) is semidet.
% type_constructors_should_be_no_tag(Ctors, ReservedTag, Globals,
% FunctorName, FunctorArgType, MaybeFunctorArgName):
+ %
% Check whether some constructors are a no_tag type, and that this
% is compatible with the ReservedTag setting for this type and
% the grade options set in the globals.
+ %
:- pred type_constructors_should_be_no_tag(list(constructor)::in, bool::in,
globals::in, sym_name::out, (type)::out, maybe(string)::out)
is semidet.
@@ -333,7 +357,7 @@
% substitution and update the type bindings.
% The third argument is a list of type variables which cannot
% be bound (i.e. head type variables).
-
+ %
:- pred type_unify((type)::in, (type)::in, list(tvar)::in, tsubst::in,
tsubst::out) is semidet.
@@ -366,19 +390,20 @@
% arguments of the call. This checks that none
% of the existentially quantified type variables of
% the callee are bound.
+ %
:- pred arg_type_list_subsumes(tvarset::in, list(type)::in,
tvarset::in, existq_tvars::in, list(type)::in) is semidet.
% apply a type substitution (i.e. map from tvar -> type)
% to all the types in a variable typing (i.e. map from var -> type).
-
+ %
:- pred apply_substitution_to_type_map(map(prog_var, type)::in, tsubst::in,
map(prog_var, type)::out) is det.
% same thing as above, except for a recursive substitution
% (i.e. we keep applying the substitution recursively until
% there are no more changes).
-
+ %
:- pred apply_rec_substitution_to_type_map(map(prog_var, type)::in, tsubst::in,
map(prog_var, type)::out) is det.
@@ -430,12 +455,14 @@
:- pred apply_variable_renaming_to_constraint_map(map(tvar, tvar)::in,
constraint_map::in, constraint_map::out) is det.
-% Apply a renaming (partial map) to a list.
-% Useful for applying a variable renaming to a list of variables.
+ % Apply a renaming (partial map) to a list.
+ % Useful for applying a variable renaming to a list of variables.
+ %
:- pred apply_partial_map_to_list(list(T)::in, map(T, T)::in, list(T)::out)
is det.
% cons_id_adjusted_arity(ModuleInfo, Type, ConsId):
+ %
% Returns the number of arguments of specified constructor id,
% adjusted to include the extra typeclassinfo and typeinfo
% arguments inserted by polymorphism.m for existentially
@@ -450,6 +477,7 @@
% from the cons_id because the arity in the cons_id will not
% include any extra type_info arguments for existentially
% quantified types.
+ %
:- pred maybe_get_cons_id_arg_types(module_info::in, maybe(type)::in,
cons_id::in, arity::in, list(maybe(type))::out) is det.
cvs diff: Diffing compiler/notes
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.103
diff -u -b -r1.103 compiler_design.html
--- compiler/notes/compiler_design.html 8 Jul 2005 04:22:11 -0000 1.103
+++ compiler/notes/compiler_design.html 25 Jul 2005 09:06:42 -0000
@@ -360,32 +360,114 @@
which is defined in the hlds.m package.
<p>
-The last stage of parsing is this conversion to HLDS:
+The last stage of parsing is this conversion to HLDS,
+which is done mostly by the following submodules
+of the make_hlds module in the hlds package.
+<dl>
-<ul>
-<li><p> conversion to superhomogeneous form and into HLDS
+<dt>
+make_hlds_passes.m
+<dd>
+This submodule calls the others to perform the conversion, in several passes.
+(We cannot do everything in one pass;
+for example, we need to have seen a predicate's declaration
+before we can process its clauses.)
- <p>
- make_hlds.m transforms the clauses into superhomogeneous form,
- and at the same time converts the parse tree into the HLDS.
- It expands away state variable syntax, universal quantification
- (using `all [Vs] G' ===> `not (some [Vs] (not G))')
- and implication (using `A => B' ===> `not(A, not B)').
- It converts `pragma import', `pragma c_code' and `pragma fact_table'
- declarations into clauses with HLDS `pragma_c_code'
- instructions for bodies.
- The `pragma fact_table' conversion is done by calling fact_table.m
- (which is part of the ll_backend.m package); fact_table.m also
- reads the facts from the declared file and compiles them
- into a separate C file for which the `pragma_c_code' contains lookup
- code.
- make_hlds.m also calls make_tags.m which chooses the data
- representation for each discriminated union type by
- assigning tags to each functor.
- make_hlds.m also performs a number of semantic checks,
- such as checking for circular insts and modes
- and warning about singleton variables.
-</ul>
+<dt>
+superhomogeneous.m
+<dd>
+Performs the conversion of unifications into superhomogeneous form.
+
+<dt>
+state_var.m
+<dd>
+Expands away state variable syntax.
+
+<dt>
+field_access.m
+<dd>
+Expands away field access syntax.
+
+<dt>
+add_clause.m
+<dd>
+Converts clauses from parse_tree format to hlds format.
+Handles their addition to procedures,
+which is nontrivial in the presence of mode-specific clauses.
+Eliminates universal quantification
+(using `all [Vs] G' ===> `not (some [Vs] (not G))')
+and implication (using `A => B' ===> `not(A, not B)').
+
+<dt>
+add_aditi.m
+<dd>
+Expands out references to Aditi builtin operations.
+
+<dt>
+add_pred.m
+<dd>
+Handles type and mode declarations for predicates.
+
+<dt>
+add_type.m
+<dd>
+Handles the declarations of types.
+
+<dt>
+add_mode.m
+<dd>
+Handles the declarations of insts and modes,
+including checking for circular insts and modes.
+
+<dt>
+add_special_pred.m
+<dd>
+Adds unify, compare, and (if needed) index and init predicates
+to the HLDS as necessary.
+
+<dt>
+add_solver.m
+<dd>
+Adds the casting predicates needed by solver types to the HLDS as necessary.
+
+<dt>
+add_class.m
+<dd>
+Handles typeclass and instance declarations.
+
+<dt>
+qual_info.m
+<dd>
+Handles the abstract data types used for module qualication.
+
+<dt>
+make_hlds_warn.m
+<dd>
+Looks for constructs that merit warnings,
+such as singleton variables and variables with overlapping scopes.
+
+<dt>
+make_hlds_error.m
+<dd>
+Error messages used by more than one submodule of make_hlds.m.
+
+<dt>
+add_pragma.m
+<dd>
+Adds most kinds of pragmas to the HLDS,
+including import/export pragmas, tabling pragmas and foreign code.
+
+</dl>
+
+Fact table pragmas are handled by fact_table.m
+(which is part of the ll_backend.m package).
+That module also reads the facts from the declared file
+and compiles them into a separate C file
+used by the foreign_proc body of the relevant predicate.
+
+The conversion of the item list to HLDS also involves make_tags.m,
+which chooses the data representation for each discriminated union type
+by assigning tags to each functor.
<p>
The HLDS data structure itself is spread over four modules:
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
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