mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-18 07:15:19 +00:00
46a67b0b48
Estimated hours taken: 16
Branches: main
When the typechecker finds highly ambiguous overloading, print what symbols
were overloaded, and where they occurred. Without this information, it is
very hard to fix the error if the predicate body is at all large.
Fix some software engineering problems encountered during this process.
Modify some predicates in error_util in order to simplify their typical usage.
Change the type_ctor type to be not simply a sym_name - int pair but a type
with its own identifying type constructor. Change several other types that
were also sym_name - int pairs (mode_id, inst_id, item_name, module_qual.id
and the related simple_call_id) to have their own function symbols too.
compiler/typecheck_info.m:
Add a field to the typecheck_info structure that records the overloaded
symbols encountered.
compiler/typecheck.m:
When processing ambiguous predicate and function symbols, record this
fact in the typecheck_info.
Add a field to the cons_type_info structure to make this possible.
compiler/typecheck_errors.m:
When printing the message about highly ambiguous overloading,
what the overloaded symbols were and where they occurred.
compiler/error_util.m:
Make error_msg_specs usable with plain in and out modes by separating
out the capability requiring special modes (storing a higher order
value in a function symbol) into its own, rarely used type.
Make component_list_to_line_pieces a bit more flexible.
compiler/prog_data.m:
compiler/module_qual.m:
compiler/recompilation.m:
Change the types listed above from being equivalence types (pairs)
to being proper discriminated union types.
compiler/*.m:
Conform to the changes above.
In some cases, simplify the code's use of error_util.
tests/warnings/ambiguous_overloading.{m,exp}:
Greatly extend this test case to test the new functionality.
tests/recompilation/*.err_exp.2
Reflect the fact that the expected messages now use the standard
error_util way of quoting sym_name/arity pairs.
680 lines
27 KiB
Mathematica
680 lines
27 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1993-2006 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(mer_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(mer_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 hlds.hlds_data.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- 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 hlds.pred_table.
|
|
:- import_module libs.compiler_util.
|
|
:- import_module parse_tree.error_util.
|
|
:- import_module parse_tree.prog_out.
|
|
:- import_module parse_tree.prog_type.
|
|
:- import_module parse_tree.prog_type_subst.
|
|
:- import_module parse_tree.prog_util.
|
|
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module map.
|
|
:- import_module multi_map.
|
|
:- import_module pair.
|
|
:- import_module set.
|
|
:- import_module solutions.
|
|
:- import_module string.
|
|
:- import_module varset.
|
|
|
|
module_add_class_defn(Constraints, FunDeps, Name, Vars, Interface, VarSet,
|
|
Context, Status, !ModuleInfo, !IO) :-
|
|
module_info_get_class_table(!.ModuleInfo, Classes0),
|
|
module_info_get_superclass_table(!.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, _OldKinds, 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 = [],
|
|
% XXX kind inference:
|
|
% We set all the kinds to `star' at the moment. This should be
|
|
% done differently when we have a proper kind system.
|
|
Kinds = map.init,
|
|
Defn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
|
|
Ancestors, Vars, Kinds, ClassInterface, ClassMethods, VarSet,
|
|
Context),
|
|
map.set(Classes0, ClassId, Defn, Classes),
|
|
module_info_set_class_table(Classes, !ModuleInfo),
|
|
|
|
(
|
|
IsNewDefn = yes,
|
|
update_superclass_table(ClassId, Vars, VarSet, Constraints,
|
|
SuperClasses0, SuperClasses),
|
|
|
|
module_info_set_superclass_table(SuperClasses, !ModuleInfo),
|
|
|
|
% When we find the class declaration, make an
|
|
% entry for the instances.
|
|
module_info_get_instance_table(!.ModuleInfo, Instances0),
|
|
map.det_insert(Instances0, ClassId, [], Instances),
|
|
module_info_set_instance_table(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([], _, _) = _ :-
|
|
unexpected(this_file, "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) :-
|
|
tvarset_merge_renaming(VarSet, OldVarSet, _, Renaming),
|
|
apply_variable_renaming_to_prog_constraint_list(Renaming, OldConstraints0,
|
|
OldConstraints1),
|
|
apply_variable_renaming_to_tvar_list(Renaming, OldVars0, OldVars),
|
|
|
|
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,
|
|
class_methods::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) :-
|
|
list.filter(is_class_method_mode_item, Methods, ModeMethods,
|
|
PredOrFuncMethods),
|
|
some [!PPIds] (
|
|
add_class_pred_or_func_methods(Name, Vars, PredOrFuncMethods, Status,
|
|
!:PPIds, !ModuleInfo, !IO),
|
|
%
|
|
% Add the pred_or_func_mode decls. Since we have already added the
|
|
% predicate/function method decls there should already be an entry in
|
|
% the predicate table corresponding to the mode item we are about to
|
|
% add. If not, report an error.
|
|
%
|
|
list.foldl3(add_class_pred_or_func_mode_method(Name, Vars, Status),
|
|
ModeMethods, !PPIds, !ModuleInfo, !IO),
|
|
check_method_modes(Methods, !.PPIds, PredProcIds, !ModuleInfo, !IO)
|
|
).
|
|
|
|
:- pred is_class_method_mode_item(class_method::in) is semidet.
|
|
|
|
is_class_method_mode_item(Method) :-
|
|
Method = pred_or_func_mode(_, _, _, _, _, _, _, _).
|
|
|
|
:- pred add_class_pred_or_func_mode_method(sym_name::in,
|
|
list(tvar)::in, item_status::in, 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.
|
|
|
|
add_class_pred_or_func_mode_method(Name, Vars, Status, Method,
|
|
!PredProcIds, !ModuleInfo, !IO) :-
|
|
(
|
|
Method = pred_or_func(_, _, _, _, _, _, _, _, _, _, _, _, _),
|
|
unexpected(this_file, "add_class_pred_or_func_mode_method: " ++
|
|
"pred_or_func method item")
|
|
;
|
|
Method = pred_or_func_mode(_VarSet, MaybePredOrFunc, PredName,
|
|
Modes, _WithInst, _MaybeDet, _Cond, Context)
|
|
),
|
|
module_info_get_predicate_table(!.ModuleInfo, PredTable),
|
|
PredArity = list.length(Modes) : int,
|
|
(
|
|
% The only way this could have happened now is if a `with_inst`
|
|
% annotation was not expanded.
|
|
%
|
|
MaybePredOrFunc = no,
|
|
unexpected(this_file, "add_class_pred_or_func_mode_method: " ++
|
|
"unexpanded `with_inst` annotation")
|
|
;
|
|
MaybePredOrFunc = yes(PredOrFunc)
|
|
),
|
|
(
|
|
predicate_table_search_pf_sym_arity(PredTable, is_fully_qualified,
|
|
PredOrFunc, PredName, PredArity, Preds),
|
|
Preds \= []
|
|
->
|
|
(
|
|
% This case should have been caught above.
|
|
Preds = [],
|
|
unexpected(this_file, "empty list")
|
|
;
|
|
Preds = [PredId],
|
|
module_info_pred_info(!.ModuleInfo, PredId, PredInfo),
|
|
pred_info_get_markers(PredInfo, PredMarkers),
|
|
( check_marker(PredMarkers, class_method) ->
|
|
module_add_class_method(Method, Name, Vars, Status,
|
|
PredProcId, !ModuleInfo, !IO),
|
|
list.cons(PredProcId, !PredProcIds)
|
|
;
|
|
% XXX It may also be worth reporting that although there
|
|
% wasn't a matching class method, there was a matching
|
|
% predicate/function.
|
|
missing_pred_or_func_method_error(PredName, PredArity,
|
|
PredOrFunc, Context, !ModuleInfo, !IO)
|
|
)
|
|
;
|
|
% This shouldn't happen.
|
|
Preds = [_, _ | _],
|
|
unexpected(this_file, "multiple preds matching method mode")
|
|
)
|
|
;
|
|
missing_pred_or_func_method_error(PredName, PredArity,
|
|
PredOrFunc, Context, !ModuleInfo, !IO)
|
|
).
|
|
|
|
:- pred add_class_pred_or_func_methods(sym_name::in, list(tvar)::in,
|
|
class_methods::in, item_status::in,
|
|
list(maybe(pair(pred_id, proc_id)))::out,
|
|
module_info::in, module_info::out, io::di, io::uo) is det.
|
|
|
|
add_class_pred_or_func_methods(_, _, [], _, [], !ModuleInfo, !IO).
|
|
add_class_pred_or_func_methods(Name, Vars, [M | Ms], Status, [P | Ps],
|
|
!ModuleInfo, !IO) :-
|
|
module_add_class_method(M, Name, Vars, Status, P, !ModuleInfo, !IO),
|
|
add_class_pred_or_func_methods(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),
|
|
% XXX kind inference:
|
|
% We set the kinds to `star' at the moment. This will be different
|
|
% when we have a kind system.
|
|
prog_type.var_list_to_type_list(map.init, Vars, Args),
|
|
ClassContext = constraints(UnivCnstrs, ExistCnstrs),
|
|
NewUnivCnstrs = [constraint(Name, Args) | 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(class_methods::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.
|
|
unexpected(this_file,
|
|
"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_get_procedures(PredInfo0, Procs),
|
|
( map.is_empty(Procs) ->
|
|
pred_method_with_no_modes_error(PredInfo0, !IO)
|
|
;
|
|
true
|
|
)
|
|
)
|
|
;
|
|
unexpected(this_file, "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_get_class_table(!.ModuleInfo, Classes),
|
|
module_info_get_instance_table(!.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_instance_table(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
|
|
tvarset_merge_renaming(VarSet, OtherVarSet, _NewVarSet, Renaming),
|
|
apply_variable_renaming_to_type_list(Renaming, OtherTypes,
|
|
NewOtherTypes),
|
|
type_list_subsumes(Types, NewOtherTypes, _)
|
|
),
|
|
solutions.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(Context, GoalInfo0, GoalInfo1),
|
|
set.list_to_set(HeadVars, NonLocals),
|
|
goal_info_set_nonlocals(NonLocals, GoalInfo1, GoalInfo2),
|
|
( check_marker(Markers, is_impure) ->
|
|
goal_info_add_feature(impure_goal, GoalInfo2, GoalInfo)
|
|
; check_marker(Markers, is_semipure) ->
|
|
goal_info_add_feature(semipure_goal, GoalInfo2, 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(_Origin, 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),
|
|
|
|
SimpleCallId = simple_call_id(PredOrFunc, PredName, Arity),
|
|
|
|
% Warn about singleton variables.
|
|
maybe_warn_singletons(VarSet, SimpleCallId, !.ModuleInfo, Goal,
|
|
!IO),
|
|
|
|
% Warn about variables with overlapping scopes.
|
|
maybe_warn_overlap(Warnings, VarSet, SimpleCallId, !IO)
|
|
)
|
|
;
|
|
unexpected(this_file, "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, arity::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 missing_pred_or_func_method_error(sym_name::in, arity::in,
|
|
pred_or_func::in, prog_context::in, module_info::in, module_info::out,
|
|
io::di, io::uo) is det.
|
|
|
|
missing_pred_or_func_method_error(Name, Arity, PredOrFunc, Context,
|
|
!ModuleInfo, !IO) :-
|
|
NoPredOrFuncMsg = [
|
|
words("Error: mode declaration for type class method"),
|
|
sym_name_and_arity(Name / Arity),
|
|
words("without corresponding"),
|
|
pred_or_func(PredOrFunc),
|
|
words("method declaration.")
|
|
],
|
|
write_error_pieces(Context, 0, NoPredOrFuncMsg, !IO),
|
|
io.set_exit_status(1, !IO),
|
|
module_info_incr_errors(!ModuleInfo).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- func this_file = string.
|
|
|
|
this_file = "add_class.m".
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
:- end_module add_class.
|
|
%-----------------------------------------------------------------------------%
|