diff: typeclasses (round 2) [2/4]
David Glen JEFFERY
dgj at cs.mu.oz.au
Thu Dec 18 19:01:11 AEDT 1997
Here's the changes to the compiler:
-------------------------------------------------------------------------------
diff -u -r compiler/bytecode.m /home/pgrad/dgj/mer/work/mercury/compiler/bytecode.m
--- compiler/bytecode.m Wed Dec 17 13:25:43 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/bytecode.m Tue Nov 25 12:28:21 1997
@@ -729,8 +729,9 @@
{ char__to_int(Char, Byte) },
output_byte(Byte).
- % XXX FIX THIS
+ % XXX
output_cons_id(base_typeclass_info_const(_, _, _)) -->
+ { error("Sorry, bytecode for typeclass not yet implemented") },
output_byte(8).
:- pred debug_cons_id(byte_cons_id, io__state, io__state).
diff -u -r compiler/call_gen.m /home/pgrad/dgj/mer/work/mercury/compiler/call_gen.m
--- compiler/call_gen.m Wed Dec 17 13:25:43 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/call_gen.m Tue Nov 25 19:22:12 1997
@@ -270,8 +270,8 @@
% and pick up the outputs from the locations that we know
% runtime/call.mod leaves them in.
%
-call_gen__generate_class_method_call(_OuterCodeModel, TCVar, Num, Args, Types,
- Modes, Det, GoalInfo, Code) -->
+call_gen__generate_class_method_call(_OuterCodeModel, TCVar, MethodNum, Args,
+ Types, Modes, Det, GoalInfo, Code) -->
{ determinism_to_code_model(Det, InnerCodeModel) },
code_info__get_globals(Globals),
code_info__get_module_info(ModuleInfo),
@@ -280,19 +280,26 @@
ArgInfo) },
{ assoc_list__from_corresponding_lists(Args, ArgInfo, ArgsAndArgInfo) },
{ call_gen__partition_args(ArgsAndArgInfo, InVars, OutVars) },
- call_gen__generate_class_method_call2(InnerCodeModel, TCVar, Num,
- InVars, OutVars, GoalInfo, Code).
+ call_gen__generate_class_method_call_2(InnerCodeModel, TCVar,
+ MethodNum, InVars, OutVars, GoalInfo, Code).
- % XXX This assumes compact args!!!
- % XXX This assumes compact args!!!
- % XXX This assumes compact args!!!
-:- pred call_gen__generate_class_method_call2(code_model, var, int, list(var),
+ % XXX This assumes compact args
+:- pred call_gen__generate_class_method_call_2(code_model, var, int, list(var),
list(var), hlds_goal_info, code_tree, code_info, code_info).
-:- mode call_gen__generate_class_method_call2(in, in, in, in, in, in, out, in,
+:- mode call_gen__generate_class_method_call_2(in, in, in, in, in, in, out, in,
out) is det.
-call_gen__generate_class_method_call2(CodeModel, TCVar, Index, InVars, OutVars,
+call_gen__generate_class_method_call_2(CodeModel, TCVar, Index, InVars, OutVars,
GoalInfo, Code) -->
+ code_info__get_globals(Globals),
+ { globals__get_args_method(Globals, ArgsMethod) },
+ (
+ { ArgsMethod = compact }
+ ->
+ []
+ ;
+ { error("Sorry, typeclasses with simple args_method not yet implemented") }
+ ),
code_info__succip_is_used,
{ set__list_to_set(OutVars, OutArgs) },
call_gen__save_variables(OutArgs, SaveCode),
diff -u -r compiler/det_analysis.m /home/pgrad/dgj/mer/work/mercury/compiler/det_analysis.m
--- compiler/det_analysis.m Wed Dec 17 13:25:43 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/det_analysis.m Tue Dec 2 18:16:44 1997
@@ -474,8 +474,10 @@
NumSolns = at_most_many_cc,
SolnContext \= first_soln
->
- % XXX this will give a slightly misleading error
- % XXX message
+ % If called, this would give a slightly misleading
+ % error message. class_method_calls are introduced
+ % after det_analysis, though, so it doesn't really
+ % matter.
Msgs = [higher_order_cc_pred_in_wrong_context(GoalInfo, Det0)],
% Code elsewhere relies on the assumption that
% SolnContext \= first_soln => NumSolns \= at_most_many_cc,
@@ -1012,10 +1014,14 @@
get_all_pred_procs_2(_Preds, [], PredProcs, PredProcs).
get_all_pred_procs_2(Preds, [PredId|PredIds], PredProcs0, PredProcs) :-
map__lookup(Preds, PredId, Pred),
- pred_info_get_marker_list(Pred, Markers),
+ pred_info_get_markers(Pred, Markers),
(
- % ignore class members
- list__member(request(class_method), Markers)
+ % ignore class members, since their bodies are filled
+ % in after this pass, and the body is gauranteed to
+ % be determinism-correct. Determinism correctness of
+ % the methods in an instance declaration are check
+ % separately in check_typeclass.m
+ check_marker(Markers, class_method)
->
PredProcs1 = PredProcs0
;
diff -u -r compiler/det_report.m /home/pgrad/dgj/mer/work/mercury/compiler/det_report.m
--- compiler/det_report.m Thu Dec 18 15:31:49 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/det_report.m Thu Dec 18 18:41:53 1997
@@ -459,7 +459,6 @@
det_diagnose_goal_2(higher_order_call(_, _, _, _, _, _), GoalInfo,
Desired, Actual, _, _DetInfo, yes) -->
{ goal_info_get_context(GoalInfo, Context) },
- prog_out__write_context(Context),
det_diagnose_atomic_goal(Desired, Actual,
report_higher_order_call_context(Context), Context).
@@ -470,7 +469,6 @@
det_diagnose_goal_2(class_method_call(_, _, _, _, _, _), GoalInfo,
Desired, Actual, _, _MiscInfo, yes) -->
{ goal_info_get_context(GoalInfo, Context) },
- prog_out__write_context(Context),
det_diagnose_atomic_goal(Desired, Actual,
report_higher_order_call_context(Context), Context).
diff -u -r compiler/dnf.m /home/pgrad/dgj/mer/work/mercury/compiler/dnf.m
--- compiler/dnf.m Thu Dec 18 14:55:02 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/dnf.m Tue Dec 9 16:29:24 1997
@@ -137,10 +137,11 @@
pred_info_name(PredInfo0, PredName),
pred_info_typevarset(PredInfo0, TVarSet),
pred_info_get_markers(PredInfo0, Markers),
+ pred_info_get_class_context(PredInfo0, ClassContext),
proc_info_goal(ProcInfo0, Goal0),
proc_info_variables(ProcInfo0, VarSet),
proc_info_vartypes(ProcInfo0, VarTypes),
- DnfInfo = dnf_info(TVarSet, VarTypes, VarSet, Markers),
+ DnfInfo = dnf_info(TVarSet, VarTypes, ClassContext, VarSet, Markers),
proc_info_get_initial_instmap(ProcInfo0, ModuleInfo0, InstMap),
dnf__transform_goal(Goal0, InstMap, MaybeNonAtomic,
@@ -153,6 +154,7 @@
:- type dnf_info ---> dnf_info(
tvarset,
map(var, type),
+ list(class_constraint),
varset,
pred_markers
).
@@ -366,16 +368,13 @@
dnf__define_new_pred(Goal0, Goal, InstMap0, PredName, DnfInfo,
ModuleInfo0, ModuleInfo, PredId) :-
- DnfInfo = dnf_info(TVarSet, VarTypes, VarSet, Markers),
+ DnfInfo = dnf_info(TVarSet, VarTypes, ClassContext, VarSet, Markers),
Goal0 = _GoalExpr - GoalInfo,
goal_info_get_nonlocals(GoalInfo, NonLocals),
set__to_sorted_list(NonLocals, ArgVars),
- % XXX
- % XXX Does this new pred necessarily have an empty context?
- % XXX I would think not. The pred context should probably be
- % XXX added to the dnf_info.
- % XXX
- ClassContext = [],
+ % This ClassContext is a conservative approximation.
+ % We could get rid of some constraints on variables
+ % that are not part of the goal.
hlds_pred__define_new_pred(Goal0, Goal, ArgVars, InstMap0, PredName,
TVarSet, VarTypes, ClassContext, VarSet, Markers,
ModuleInfo0, ModuleInfo, PredProcId),
diff -u -r compiler/equiv_type.m /home/pgrad/dgj/mer/work/mercury/compiler/equiv_type.m
--- compiler/equiv_type.m Thu Dec 18 15:37:50 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/equiv_type.m Tue Dec 9 18:39:57 1997
@@ -113,9 +113,9 @@
TypeDefn, VarSet, ContainsCirc).
equiv_type__replace_in_item(
- pred(VarSet0, PredName, TypesAndModes0,
+ pred(VarSet0, PredName, TypesAndModes0,
Det, Cond, Purity, ClassContext),
- EqvMap,
+ EqvMap,
pred(VarSet, PredName, TypesAndModes,
Det, Cond, Purity, ClassContext),
no) :-
@@ -123,12 +123,14 @@
TypesAndModes, VarSet).
equiv_type__replace_in_item(
- func(VarSet0, PredName, TypesAndModes0, RetTypeAndMode0,
- Det, Cond, Purity, ClassContext),
- EqvMap,
- func(VarSet, PredName, TypesAndModes, RetTypeAndMode,
- Det, Cond, Purity, ClassContext),
- no) :-
+ func(VarSet0, PredName, TypesAndModes0,
+ RetTypeAndMode0, Det, Cond, Purity,
+ ClassContext),
+ EqvMap,
+ func(VarSet, PredName, TypesAndModes
+ , RetTypeAndMode, Det, Cond, Purity,
+ ClassContext),
+ no) :-
equiv_type__replace_in_tms(TypesAndModes0, VarSet0, EqvMap,
TypesAndModes, VarSet1),
equiv_type__replace_in_tm(RetTypeAndMode0, VarSet1, EqvMap,
diff -u -r compiler/higher_order.m /home/pgrad/dgj/mer/work/mercury/compiler/higher_order.m
--- compiler/higher_order.m Thu Dec 18 14:55:05 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/higher_order.m Wed Dec 10 17:04:25 1997
@@ -295,7 +295,7 @@
{ Goal0 = higher_order_call(_,_,_,_,_,_) - _ },
maybe_specialize_higher_order_call(Goal0, Goal, PredProcId, Changed).
- % For now, we do not specialize class method calls
+ % XXX For now, we do not specialize class method calls
traverse_goal(Goal, Goal, _, unchanged, 1) -->
{ Goal = class_method_call(_,_,_,_,_,_) - _ }.
@@ -845,6 +845,10 @@
pred_info_context(PredInfo0, Context),
pred_info_get_markers(PredInfo0, MarkerList),
pred_info_get_goal_type(PredInfo0, GoalType),
+ % When we start specialising class method calls, this
+ % context will need to be updated.
+ % cf. remove_listof_higher_order_args.
+ pred_info_get_class_context(PredInfo0, ClassContext),
Name = qualified(PredModule, PredName),
varset__init(EmptyVarSet),
map__init(EmptyVarTypes),
@@ -854,13 +858,9 @@
% hlds dumps if it's filled in.
ClausesInfo = clauses_info(EmptyVarSet, EmptyVarTypes,
EmptyVarTypes, [], []),
- % XXX
- % XXX This is not, in general, correct.
- % XXX
- TypeConstraints = [],
pred_info_init(PredModule, Name, Arity, Tvars,
Types, true, Context, ClausesInfo, local, MarkerList, GoalType,
- PredOrFunc, TypeConstraints, EmptyProofs, PredInfo1),
+ PredOrFunc, ClassContext, EmptyProofs, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo2),
pred_info_procedures(PredInfo2, Procs0),
next_mode_id(Procs0, no, NewProcId),
diff -u -r compiler/hlds_data.m /home/pgrad/dgj/mer/work/mercury/compiler/hlds_data.m
--- compiler/hlds_data.m Wed Dec 17 13:25:44 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/hlds_data.m Fri Nov 28 16:16:24 1997
@@ -707,7 +707,8 @@
list(class_constraint), % SuperClasses
list(var), % ClassVars
hlds_class_interface, % Methods
- varset % VarNames
+ varset, % VarNames
+ term__context % Location of declaration
).
:- type hlds_class_interface == list(hlds_class_proc).
diff -u -r compiler/hlds_out.m /home/pgrad/dgj/mer/work/mercury/compiler/hlds_out.m
--- compiler/hlds_out.m Thu Dec 18 15:39:55 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/hlds_out.m Thu Dec 18 18:37:29 1997
@@ -457,8 +457,8 @@
{ pred_info_get_markers(PredInfo, Markers) },
{ pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
{ pred_info_get_class_context(PredInfo, ClassContext) },
- mercury_output_pred_type(TVarSet, qualified(Module, PredName), ArgTypes,
- no, pure, ClassContext, Context),
+ mercury_output_pred_type(TVarSet, qualified(Module, PredName),
+ ArgTypes, no, pure, ClassContext, Context),
{ ClausesInfo = clauses_info(VarSet, _, VarTypes, HeadVars, Clauses) },
hlds_out__write_indent(Indent),
io__write_string("% pred id: "),
@@ -501,7 +501,7 @@
io__write_string("\n% Class Table:\n"),
{ module_info_classes(ModuleInfo, ClassTable) },
% XXX fix this up.
- io__write(ClassTable).
+ io__print(ClassTable).
:- pred hlds_out__write_marker_list(list(marker), io__state, io__state).
:- mode hlds_out__write_marker_list(in, di, uo) is det.
@@ -510,7 +510,6 @@
hlds_out__write_marker_list([Marker | Markers]) -->
hlds_out__write_marker(Marker),
hlds_out__write_marker_list(Markers).
-
hlds_out__marker_name(infer_type, "infer_type").
hlds_out__marker_name(infer_modes, "infer_modes").
diff -u -r compiler/hlds_pred.m /home/pgrad/dgj/mer/work/mercury/compiler/hlds_pred.m
--- compiler/hlds_pred.m Thu Dec 18 15:48:51 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/hlds_pred.m Mon Dec 15 17:42:33 1997
@@ -252,6 +252,9 @@
:- pred type_info_locn_var(type_info_locn::in, var::out) is det.
+:- pred type_info_locn_set_var(type_info_locn::in, var::in,
+ type_info_locn::out) is det.
+
% hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap, PredName,
% TVarSet, VarTypes, ClassContext, VarSet, Markers, ModuleInfo0,
% ModuleInfo, PredProcId)
@@ -381,15 +384,6 @@
:- pred pred_info_requested_no_inlining(pred_info).
:- mode pred_info_requested_no_inlining(in) is semidet.
-:- pred pred_info_get_purity(pred_info, purity).
-:- mode pred_info_get_purity(in, out) is det.
-
-:- pred pred_info_get_promised_pure(pred_info, bool).
-:- mode pred_info_get_promised_pure(in, out) is det.
-
-:- pred purity_to_markers(purity, pred_markers).
-:- mode purity_to_markers(in, out) is det.
-
:- pred pred_info_get_is_pred_or_func(pred_info, pred_or_func).
:- mode pred_info_get_is_pred_or_func(in, out) is det.
@@ -408,6 +402,15 @@
map(class_constraint, constraint_proof), pred_info).
:- mode pred_info_set_constraint_proofs(in, in, out) is det.
+:- pred pred_info_get_purity(pred_info, purity).
+:- mode pred_info_get_purity(in, out) is det.
+
+:- pred pred_info_get_promised_pure(pred_info, bool).
+:- mode pred_info_get_promised_pure(in, out) is det.
+
+:- pred purity_to_markers(purity, pred_markers).
+:- mode purity_to_markers(in, out) is det.
+
:- type pred_markers.
:- pred pred_info_get_markers(pred_info, pred_markers).
@@ -697,8 +700,7 @@
_, _, _).
pred_info_set_markers(PredInfo0, Markers, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, _,
- N, O, P),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O, P),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, Markers,
N, O, P).
@@ -728,6 +730,9 @@
type_info_locn_var(type_info(Var), Var).
type_info_locn_var(typeclass_info(Var, _), Var).
+
+type_info_locn_set_var(type_info(_), Var, type_info(Var)).
+type_info_locn_set_var(typeclass_info(_, Num), Var, typeclass_info(Var, Num)).
%-----------------------------------------------------------------------------%
:- type pred_markers == list(marker).
diff -u -r compiler/lambda.m /home/pgrad/dgj/mer/work/mercury/compiler/lambda.m
--- compiler/lambda.m Thu Dec 18 15:53:45 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/lambda.m Tue Dec 2 16:43:17 1997
@@ -28,6 +28,11 @@
%
% :- pred '__LambdaGoal__1'(int::in, int::out) is nondet.
% '__LambdaGoal__1'(X, Y) :- q(Y, X).
+%
+%
+%
+% Note: Support for lambda expressions which involve class constraints
+% is not yet complete.
%-----------------------------------------------------------------------------%
diff -u -r compiler/llds_out.m /home/pgrad/dgj/mer/work/mercury/compiler/llds_out.m
--- compiler/llds_out.m Thu Dec 18 14:55:11 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/llds_out.m Thu Dec 18 18:37:35 1997
@@ -3090,7 +3090,9 @@
ClassSym = unqualified(_),
error("llds_out__make_base_typeclass_info_name: unqualified name")
;
- ClassSym = qualified(ModuleName, ClassName),
+ ClassSym = qualified(ModuleName, ClassName0),
+ % Mangle the class name in case it is an operator
+ llds_out__name_mangle(ClassName0, ClassName),
string__append_list([ModuleName, "__", ClassName], ClassString)
),
string__int_to_string(ClassArity, A_str),
diff -u -r compiler/make_hlds.m /home/pgrad/dgj/mer/work/mercury/compiler/make_hlds.m
--- compiler/make_hlds.m Thu Dec 18 17:49:10 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/make_hlds.m Thu Dec 18 17:47:16 1997
@@ -201,7 +201,7 @@
Context, Status, Module0, Status, Module) -->
{ init_markers(Markers) },
module_add_func(Module0, VarSet, FuncName, TypesAndModes,
- RetTypeAndMode, MaybeDet, Cond, Purity, ClassContext, Markers
+ RetTypeAndMode, MaybeDet, Cond, Purity, ClassContext, Markers,
Context, Status, _, Module).
add_item_decl_pass_1(pred_mode(VarSet, PredName, Modes, MaybeDet, Cond),
@@ -508,8 +508,8 @@
--> [].
add_item_decl_pass_2(mode_defn(_, _, _), _, Status, Module, Status, Module)
--> [].
-add_item_decl_pass_2(pred(_, _, _, _, _, _), _, Status, Module, Status, Module)
- --> [].
+add_item_decl_pass_2(pred(_, _, _, _, _, _, _), _, Status, Module, Status,
+ Module) --> [].
add_item_decl_pass_2(pred_mode(_, _, _, _, _), _, Status, Module, Status,
Module) --> [].
add_item_decl_pass_2(func_mode(_, _, _, _, _, _), _, Status, Module, Status,
@@ -564,9 +564,9 @@
Module, Module, Info, Info) --> [].
add_item_clause(mode_defn(_, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
-add_item_clause(pred(_, _, _, _, _, _), Status, Status, _,
+add_item_clause(pred(_, _, _, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
-add_item_clause(func(_, _, _, _, _, _, _), Status, Status, _,
+add_item_clause(func(_, _, _, _, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
add_item_clause(pred_mode(_, _, _, _, _), Status, Status, _,
Module, Module, Info, Info) --> [].
@@ -1107,7 +1107,7 @@
DeclStatus = Status
},
{ split_types_and_modes(TypesAndModes, Types, MaybeModes) },
- add_new_pred(Module0, VarSet, PredName, Types, Cond, Purity,
+ add_new_pred(Module0, VarSet, PredName, Types, Cond, Purity,
ClassContext, Markers, Context, DeclStatus, NeedQual,
predicate, Module1),
(
@@ -1123,11 +1123,10 @@
:- pred module_add_func(module_info, varset, sym_name, list(type_and_mode),
type_and_mode, maybe(determinism), condition, purity,
- list(class_constraint), list(marker_status), term__context,
+ list(class_constraint), pred_markers, term__context,
item_status, maybe(pair(pred_id, proc_id)),
module_info, io__state, io__state).
-:- mode module_add_func(in, in, in, in, in, in, in, in, in, in, in, in,
- out, out, di, uo) is det.
+:- mode module_add_func(in, in, in, in, in, in, in, in, in, in, in, in, out, out, di, uo) is det.
module_add_func(Module0, VarSet, FuncName, TypesAndModes, RetTypeAndMode,
MaybeDet, Cond, Purity, ClassContext, Markers, Context,
@@ -1170,15 +1169,11 @@
{ list__length(Vars, ClassArity) },
{ Key = class_id(Name, ClassArity) },
(
- { map__search(Classes0, Key, _) }
+ { map__search(Classes0, Key, OldValue) }
->
- % XXX format the output properly (?)
- prog_out__write_context(Context),
- io__write_string("Error: typeclass "),
- prog_out__write_sym_name(Name),
- io__write_char('/'),
- io__write_int(ClassArity),
- io__write_string(" multiply defined.\n"),
+ { OldValue = hlds_class_defn(_, _, _, _, OldContext) },
+ multiple_def_error(Name, ClassArity, "typeclass",
+ Context, OldContext),
io__set_exit_status(1),
{ Module = Module0 }
;
@@ -1192,7 +1187,7 @@
)) },
{ list__filter_map(IsYes, PredProcIds0, PredProcIds) },
{ Value = hlds_class_defn(Constraints, Vars, PredProcIds,
- VarSet) },
+ VarSet, Context) },
{ map__det_insert(Classes0, Key, Value, Classes) },
{ module_info_set_classes(Module1, Classes, Module2) },
% When we find the class declaration, make an
@@ -1225,18 +1220,20 @@
MaybeDet, Cond, ClassContext, Context) },
{ term__var_list_to_term_list(Vars, VarTerms) },
{ NewClassContext = [constraint(Name, VarTerms)|ClassContext] },
- { Markers = [request(class_method)] },
+ { init_markers(Markers0) },
+ { add_marker(Markers0, class_method, Markers) },
module_add_pred(Module0, VarSet, PredName, TypesAndModes,
- MaybeDet, Cond, NewClassContext, Markers,
+ MaybeDet, Cond, pure, NewClassContext, Markers,
Context, Status, MaybePredIdProcId, Module)
;
{ Method = func(VarSet, FuncName, TypesAndModes, RetTypeAndMode,
MaybeDet, Cond, ClassContext, Context) },
{ term__var_list_to_term_list(Vars, VarTerms) },
{ NewClassContext = [constraint(Name, VarTerms)|ClassContext] },
- { Markers = [request(class_method)] },
+ { init_markers(Markers0) },
+ { add_marker(Markers0, class_method, Markers) },
module_add_func(Module0, VarSet, FuncName, TypesAndModes,
- RetTypeAndMode, MaybeDet, Cond, NewClassContext,
+ RetTypeAndMode, MaybeDet, Cond, pure, NewClassContext,
Markers, Context, Status, MaybePredIdProcId, Module)
;
{ Method = pred_mode(VarSet, PredName, Modes, MaybeDet,
@@ -1288,15 +1285,15 @@
purity, list(class_constraint), pred_markers, term__context,
import_status, need_qualifier, pred_or_func,
module_info, io__state, io__state).
-:- mode add_new_pred(in,in, in, in, in, in, in, in, in, in, in, in, out,
+:- mode add_new_pred(in, in, in, in, in, in, in, in, in, in, in, in, out,
di, uo) is det.
-% NB. Predicates are also added in polymorphism.m, which converts
+% 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(Module0, TVarSet, PredName, Types, Cond, Purity, ClassContext,
- Markers, Context, Status, NeedQual, PredOrFunc, Module) -->
+add_new_pred(Module0, TVarSet, PredName, Types, Cond, Purity, ClassContext,
+ Markers0, Context, Status, NeedQual, PredOrFunc, Module) -->
{ module_info_name(Module0, ModuleName) },
{ list__length(Types, Arity) },
(
@@ -1311,10 +1308,14 @@
{ module_info_get_predicate_table(Module1, PredicateTable0) },
{ clauses_info_init(Arity, ClausesInfo) },
{ map__init(Proofs) },
- { purity_to_markers(Purity, Markers) },
- % I haven't resolved this conflict properly so that
- % you can see how I'm handling markers in the updated
- % version.
+ { purity_to_markers(Purity, PurityMarkers) },
+ { markers_to_marker_list(PurityMarkers, MarkersList) },
+ { AddMarker = lambda(
+ [M::in, TheMarkers0::in, TheMarkers::out] is det,
+ (
+ add_marker(TheMarkers0, M, TheMarkers)
+ )) },
+ { list__foldl(AddMarker, MarkersList, Markers0, Markers) },
{ pred_info_init(ModuleName, PredName, Arity, TVarSet, Types,
Cond, Context, ClausesInfo, Status, Markers,
none, PredOrFunc, ClassContext, Proofs,
@@ -1498,11 +1499,11 @@
adjust_special_pred_status(Status0, SpecialPredId, Status),
map__init(Proofs),
init_markers(Markers),
- % XXX When we have "comparable" or "unifiable" typeclasses,
+ % XXX If/when we have "comparable" or "unifiable" typeclasses,
% XXX this context might not be empty
- ClassContext=[],
+ ClassContext = [],
pred_info_init(ModuleName, PredName, Arity, TVarSet, ArgTypes, Cond,
- Context, ClausesInfo0, Status, Markers, none, predicate,
+ Context, ClausesInfo0, Status, Markers, none, predicate,
ClassContext, Proofs, PredInfo0),
ArgLives = no,
add_new_proc(PredInfo0, Arity, ArgModes, yes(ArgModes),
@@ -1653,10 +1654,13 @@
Cond = true,
clauses_info_init(Arity, ClausesInfo),
map__init(Proofs),
+ % The class context is empty since this is an implicit
+ % definition. Inference will fill it in.
+ ClassContext = [],
init_markers(Markers0),
pred_info_init(ModuleName, PredName, Arity, TVarSet, Types, Cond,
- Context, ClausesInfo, local, Markers0, none, PredOrFunc, [],
- Proofs, PredInfo0),
+ Context, ClausesInfo, local, Markers0, none, PredOrFunc,
+ ClassContext, Proofs, PredInfo0),
add_marker(Markers0, infer_type, Markers),
pred_info_set_markers(PredInfo0, Markers, PredInfo),
(
diff -u -r compiler/mercury_to_c.m /home/pgrad/dgj/mer/work/mercury/compiler/mercury_to_c.m
--- compiler/mercury_to_c.m Thu Dec 18 17:49:21 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/mercury_to_c.m Tue Dec 9 19:10:50 1997
@@ -630,7 +630,7 @@
c_gen_goal_2(higher_order_call(_, _, _, _, _, _), _, _, _) -->
{ error("mercury_to_c: higher_order_call not implemented") }.
c_gen_goal_2(class_method_call(_, _, _, _, _, _), _, _, _) -->
- { error("mercury_to_c: higher_order_call not implemented") }.
+ { error("mercury_to_c: class_method_call not implemented") }.
c_gen_goal_2(call(PredId, ProcId, ArgVars, _, _, _PredName),
Indent, CGenInfo0, CGenInfo) -->
{ c_gen_info_get_module_info(CGenInfo0, ModuleInfo) },
diff -u -r compiler/mercury_to_mercury.m /home/pgrad/dgj/mer/work/mercury/compiler/mercury_to_mercury.m
--- compiler/mercury_to_mercury.m Thu Dec 18 17:58:19 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/mercury_to_mercury.m Wed Dec 17 18:22:31 1997
@@ -30,7 +30,8 @@
:- pred mercury_output_func_type(varset, sym_name, list(type), type,
maybe(determinism), purity, list(class_constraint),
term__context, io__state, io__state).
-:- mode mercury_output_func_type(in, in, in, in, in, in, in, in, di, uo) is det.
+:- mode mercury_output_func_type(in, in, in, in, in, in, in, in,
+ di, uo) is det.
:- pred mercury_output_pred_mode_decl(varset, sym_name, list(mode),
maybe(determinism), term__context, io__state, io__state).
@@ -346,7 +347,6 @@
% We put an extra set of brackets around the class name in
% case the name is an operator
- io__write_char('('),
mercury_output_sym_name(ClassName),
io__write_char('('),
io__write_list(Vars, ", ",
@@ -358,7 +358,6 @@
)
),
io__write_char(')'),
- io__write_char(')'),
(
{ Constraints = [] }
@@ -434,22 +433,22 @@
{ Method = pred(VarSet, Name, TypesAndModes, Detism,
_Condition, ClassContext, Context) },
mercury_output_pred_decl(VarSet, Name, TypesAndModes, Detism,
- ClassContext, Context, "),\n(", "\n")
+ pure, ClassContext, Context, "),\n(", "\n")
;
{ Method = func(VarSet, Name, TypesAndModes, TypeAndMode,
Detism, _Condition, ClassContext, Context) },
mercury_output_func_decl(VarSet, Name, TypesAndModes,
- TypeAndMode, Detism, ClassContext, Context,
+ TypeAndMode, Detism, pure, ClassContext, Context,
"),\n(", "\n")
;
{ Method = pred_mode(VarSet, Name, Modes, Detism,
_Condition, Context) },
- mercury_output_pred_mode_decl2(VarSet, Name, Modes, Detism,
+ mercury_output_pred_mode_decl_2(VarSet, Name, Modes, Detism,
Context, "\n")
;
{ Method = func_mode(VarSet, Name, Modes, Mode,
Detism, _Condition, Context) },
- mercury_output_func_mode_decl2(VarSet, Name, Modes,
+ mercury_output_func_mode_decl_2(VarSet, Name, Modes,
Mode, Detism, Context, "\n")
),
io__write_char(')').
@@ -1228,7 +1227,7 @@
->
mercury_output_pred_type_2(VarSet, PredName, Types, MaybeDet,
Purity, ClassContext, Context, Separator),
- mercury_output_pred_mode_decl2(VarSet, PredName, Modes,
+ mercury_output_pred_mode_decl_2(VarSet, PredName, Modes,
MaybeDet, Context, Terminator)
;
mercury_output_pred_type_2(VarSet, PredName, Types, MaybeDet,
@@ -1291,7 +1290,6 @@
io__write_string(Separator).
-
% this works under the assumptions that all purity names but `pure' are prefix
% operators, and that we never need `pure' indicators/declarations.
@@ -1314,7 +1312,7 @@
purity, list(class_constraint), term__context, string, string,
io__state, io__state).
:- mode mercury_output_func_decl(in, in, in, in, in, in, in, in, in, in,
- di, uo) is det.
+ di, uo) is det.
mercury_output_func_decl(VarSet, FuncName, TypesAndModes, RetTypeAndMode,
MaybeDet, Purity, ClassContext, Context,
@@ -1325,28 +1323,28 @@
{ MaybeModes = yes(Modes) },
{ MaybeRetMode = yes(RetMode) }
->
- mercury_output_func_type2(VarSet, FuncName, Types, RetType,
+ mercury_output_func_type_2(VarSet, FuncName, Types, RetType,
no, Purity, ClassContext, Context, Separator),
- mercury_output_func_mode_decl2(VarSet, FuncName, Modes, RetMode,
- MaybeDet, Context, Terminator)
+ mercury_output_func_mode_decl_2(VarSet, FuncName, Modes,
+ RetMode, MaybeDet, Context, Terminator)
;
- mercury_output_func_type2(VarSet, FuncName, Types, RetType,
+ mercury_output_func_type_2(VarSet, FuncName, Types, RetType,
MaybeDet, Purity, ClassContext, Context,
Terminator)
).
mercury_output_func_type(VarSet, FuncName, Types, RetType, MaybeDet,
Purity, ClassContext, Context) -->
- mercury_output_func_type2(VarSet, FuncName, Types, RetType, MaybeDet,
+ mercury_output_func_type_2(VarSet, FuncName, Types, RetType, MaybeDet,
Purity, ClassContext, Context, ".\n").
-:- pred mercury_output_func_type2(varset, sym_name, list(type), type,
+:- pred mercury_output_func_type_2(varset, sym_name, list(type), type,
maybe(determinism), purity, list(class_constraint),
term__context, string, io__state, io__state).
-:- mode mercury_output_func_type2(in, in, in, in, in, in, in, in, in,
- di, uo) is det.
+:- mode mercury_output_func_type_2(in, in, in, in, in, in, in, in, in,
+ di, uo) is det.
-mercury_output_func_type2(VarSet, FuncName, Types, RetType, MaybeDet,
+mercury_output_func_type_2(VarSet, FuncName, Types, RetType, MaybeDet,
Purity, ClassContext, _Context, Separator) -->
io__write_string(":- "),
write_purity_prefix(Purity),
@@ -1415,15 +1413,15 @@
% Output a mode declaration for a predicate.
mercury_output_pred_mode_decl(VarSet, PredName, Modes, MaybeDet, Context) -->
- mercury_output_pred_mode_decl2(VarSet, PredName, Modes, MaybeDet,
+ mercury_output_pred_mode_decl_2(VarSet, PredName, Modes, MaybeDet,
Context, ".\n").
-:- pred mercury_output_pred_mode_decl2(varset, sym_name, list(mode),
+:- pred mercury_output_pred_mode_decl_2(varset, sym_name, list(mode),
maybe(determinism), term__context, string,
io__state, io__state).
-:- mode mercury_output_pred_mode_decl2(in, in, in, in, in, in, di, uo) is det.
+:- mode mercury_output_pred_mode_decl_2(in, in, in, in, in, in, di, uo) is det.
-mercury_output_pred_mode_decl2(VarSet, PredName, Modes, MaybeDet, Context,
+mercury_output_pred_mode_decl_2(VarSet, PredName, Modes, MaybeDet, Context,
Separator) -->
io__write_string(":- mode "),
mercury_output_pred_mode_subdecl(VarSet, PredName, Modes, MaybeDet,
@@ -1448,16 +1446,16 @@
mercury_output_func_mode_decl(VarSet, FuncName, Modes, RetMode, MaybeDet,
Context) -->
- mercury_output_func_mode_decl2(VarSet, FuncName, Modes, RetMode,
+ mercury_output_func_mode_decl_2(VarSet, FuncName, Modes, RetMode,
MaybeDet, Context, ".\n").
-:- pred mercury_output_func_mode_decl2(varset, sym_name, list(mode), mode,
+:- pred mercury_output_func_mode_decl_2(varset, sym_name, list(mode), mode,
maybe(determinism), term__context, string,
io__state, io__state).
-:- mode mercury_output_func_mode_decl2(in, in, in, in, in, in, in,
+:- mode mercury_output_func_mode_decl_2(in, in, in, in, in, in, in,
di, uo) is det.
-mercury_output_func_mode_decl2(VarSet, FuncName, Modes, RetMode, MaybeDet,
+mercury_output_func_mode_decl_2(VarSet, FuncName, Modes, RetMode, MaybeDet,
Context, Separator) -->
io__write_string(":- mode "),
mercury_output_func_mode_subdecl(VarSet, FuncName, Modes, RetMode,
diff -u -r compiler/module_qual.m /home/pgrad/dgj/mer/work/mercury/compiler/module_qual.m
--- compiler/module_qual.m Thu Dec 18 17:59:50 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/module_qual.m Mon Dec 15 17:19:44 1997
@@ -132,8 +132,8 @@
add_mode_defn(ModeDefn, Info0, Info).
collect_mq_info_2(module_defn(_, ModuleDefn), Info0, Info) :-
process_module_defn(ModuleDefn, Info0, Info).
-collect_mq_info_2(pred(_,_,_,_,_,_), Info, Info).
-collect_mq_info_2(func(_,_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(pred(_,_,_,_,_,_,_), Info, Info).
+collect_mq_info_2(func(_,_,_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pred_mode(_,_,_,_,_), Info, Info).
collect_mq_info_2(func_mode(_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pragma(_), Info, Info).
@@ -274,10 +274,8 @@
{ update_import_status(ModuleDefn, Info0, Info, Continue) }.
module_qualify_item(
- pred(A, SymName, TypesAndModes0, D, E, F, Constraints0) -
- Context,
- pred(A, SymName, TypesAndModes, D, E, F, Constraints) -
- Context,
+ pred(A, SymName, TypesAndModes0, D,E,F, Constraints0) - Context,
+ pred(A, SymName, TypesAndModes, D,E,F, Constraints) - Context,
Info0, Info, yes) -->
{ list__length(TypesAndModes0, Arity) },
{ mq_info_set_error_context(Info0, pred(SymName - Arity) - Context,
@@ -286,8 +284,8 @@
qualify_class_constraints(Constraints0, Constraints, Info2, Info).
module_qualify_item(
- func(A,SymName, TypesAndModes0, TypeAndMode0, D, E, F,
- Constraints0) - Context,
+ func(A,SymName, TypesAndModes0, TypeAndMode0, D, E, F
+ ,Constraints0) - Context,
func(A, SymName, TypesAndModes, TypeAndMode, D, E, F,
Constraints) - Context,
Info0, Info, yes) -->
@@ -343,7 +341,7 @@
% We don't qualify the interface yet, since that requires
% us to resolve overloading.
qualify_class_constraints(Constraints0, Constraints, Info1, Info2),
- qualify_classname(Id, Name - _, Info2, Info3),
+ qualify_class_name(Id, Name - _, Info2, Info3),
qualify_type_list(Types0, Types, Info3, Info),
{ qualify_instance_interface(Name, Interface0, Interface) }.
@@ -692,14 +690,14 @@
qualify_class_constraint(constraint(ClassName0, Types0),
constraint(ClassName, Types), MQInfo0, MQInfo) -->
{ list__length(Types0, Arity) },
- qualify_classname(ClassName0 - Arity, ClassName - _, MQInfo0, MQInfo1),
+ qualify_class_name(ClassName0 - Arity, ClassName - _, MQInfo0, MQInfo1),
qualify_type_list(Types0, Types, MQInfo1, MQInfo).
-:- pred qualify_classname(pair(classname, arity)::in,
- pair(classname, arity)::out, mq_info::in, mq_info::out,
+:- pred qualify_class_name(pair(class_name, arity)::in,
+ pair(class_name, arity)::out, mq_info::in, mq_info::out,
io__state::di, io__state::uo) is det.
-qualify_classname(Class0, Class, MQInfo0, MQInfo) -->
+qualify_class_name(Class0, Class, MQInfo0, MQInfo) -->
{ mq_info_get_classes(MQInfo0, ClassIdSet) },
find_unique_match(Class0, Class, ClassIdSet, class_id,
MQInfo0, MQInfo).
diff -u -r compiler/notes/.#compiler_design.html.1.8 /home/pgrad/dgj/mer/work/mercury/compiler/notes/.#compiler_design.html.1.8
--- compiler/notes/.#compiler_design.html.1.8 Wed Dec 17 13:25:47 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/notes/.#compiler_design.html.1.8 Mon Nov 24 16:23:55 1997
@@ -97,9 +97,10 @@
definition is in prog_data.m, while the code to create it is in
prog_io.m and its submodules prog_io_dcg.m (which handles clauses
using Definite Clause Grammar notation), prog_io_goal.m (which handles
- goals), prog_io_pragma.m (which handles pragma declarations) and
- prog_io_util.m (which defines predicates and types needed by the other
- prog_io*.m modules. The data structure for insts is stored in
+ goals), prog_io_pragma.m (which handles pragma declarations),
+ prog_io_typeclass.m (which handles typeclass and instance declarations)
+ and prog_io_util.m (which defines predicates and types needed by the
+ other prog_io*.m modules. The data structure for insts is stored in
its own module, inst.m.
<p>
@@ -206,10 +207,12 @@
pred_info. However, typecheck.m doesn't figure out the pred_id
for function calls or calls to overloaded predicates; that can't
be done in a single pass of typechecking, and so it is done
- later on in modes.m. When it has finished, typecheck.m calls
- clause_to_proc.m to make duplicate copies of the clauses for
- each different mode of a predicate; all later stages work on
- procedures, not predicates.
+ later on in modes.m. Typeclass constraints are checked here, and
+ any redundant constraints that are eliminated are recorded (as
+ constraint_proofs) in the pred_info for future reference. When it has
+ finished, typecheck.m calls clause_to_proc.m to make duplicate copies
+ of the clauses for each different mode of a predicate; all later
+ stages work on procedures, not predicates.
<li> type_util.m contains utility predicates dealing with types
that are used in a variety of different places within the compiler
</ul>
@@ -298,6 +301,18 @@
what modes.m does, and unique_modes calls lots of predicates
defined in modes.m to do it.
+<dt> checking typeclass instances (check_typeclass.m)
+ <dd>
+ check_typeclass.m checks that, each instance declaration, that the
+ types, modes and determinism of each predicate/function that is a
+ method of the class is correct (ie. that it matches the typeclass
+ declaration). In this pass, pred_ids and proc_ids are assigned to
+ the methods for each instance. In addition, while checking that the
+ superclasses of a class are satisfied by the instance declaration, a
+ set of constraint_proofs are built up for the superclass constraints.
+ These are used by polymorphism.m when generating the
+ base_typeclass_info for the instance.
+
<dt> simplification (simplify.m)
<dd>
@@ -323,8 +338,9 @@
The first two passes of this stage are code simplifications.
<ul>
-<li> introduction of type_info arguments for polymorphic predicates and
- transformation of complicated unifications into predicate calls
+<li> introduction of type_info arguments for polymorphic predicates,
+ introduction of typeclass_info arguments for typeclass-constrained predicates
+ and transformation of complicated unifications into predicate calls
(polymorphism.m)
<li> removal of lambda expressions (lambda.m) <br>
@@ -620,6 +636,10 @@
creates base_type_functors structures that give information on
the functors of a given type. The base_type_layout and base_type_functors
structures of each declared type constructor are added to the LLDS.
+<ul>
+<li> base_typeclass_info.m generates the base_typeclass_info structures that
+ list the methods of a class for each instance declaration. These are added to
+ the LLDS.
<li> stack_layout.m generates the stack_layout structures for
accurate garbage collection. Tables are created from the data
diff -u -r compiler/notes/compiler_design.html /home/pgrad/dgj/mer/work/mercury/compiler/notes/compiler_design.html
--- compiler/notes/compiler_design.html Thu Dec 18 14:55:29 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/notes/compiler_design.html Tue Dec 9 17:38:07 1997
@@ -97,9 +97,10 @@
definition is in prog_data.m, while the code to create it is in
prog_io.m and its submodules prog_io_dcg.m (which handles clauses
using Definite Clause Grammar notation), prog_io_goal.m (which handles
- goals), prog_io_pragma.m (which handles pragma declarations) and
- prog_io_util.m (which defines predicates and types needed by the other
- prog_io*.m modules. The data structure for insts is stored in
+ goals), prog_io_pragma.m (which handles pragma declarations),
+ prog_io_typeclass.m (which handles typeclass and instance declarations)
+ and prog_io_util.m (which defines predicates and types needed by the
+ other prog_io*.m modules. The data structure for insts is stored in
its own module, inst.m.
<p>
@@ -206,10 +207,12 @@
pred_info. However, typecheck.m doesn't figure out the pred_id
for function calls or calls to overloaded predicates; that can't
be done in a single pass of typechecking, and so it is done
- later on in modes.m. When it has finished, typecheck.m calls
- clause_to_proc.m to make duplicate copies of the clauses for
- each different mode of a predicate; all later stages work on
- procedures, not predicates.
+ later on in modes.m. Typeclass constraints are checked here, and
+ any redundant constraints that are eliminated are recorded (as
+ constraint_proofs) in the pred_info for future reference. When it has
+ finished, typecheck.m calls clause_to_proc.m to make duplicate copies
+ of the clauses for each different mode of a predicate; all later
+ stages work on procedures, not predicates.
<li> type_util.m contains utility predicates dealing with types
that are used in a variety of different places within the compiler
</ul>
@@ -304,6 +307,18 @@
what modes.m does, and unique_modes calls lots of predicates
defined in modes.m to do it.
+<dt> checking typeclass instances (check_typeclass.m)
+ <dd>
+ check_typeclass.m checks that, each instance declaration, that the
+ types, modes and determinism of each predicate/function that is a
+ method of the class is correct (ie. that it matches the typeclass
+ declaration). In this pass, pred_ids and proc_ids are assigned to
+ the methods for each instance. In addition, while checking that the
+ superclasses of a class are satisfied by the instance declaration, a
+ set of constraint_proofs are built up for the superclass constraints.
+ These are used by polymorphism.m when generating the
+ base_typeclass_info for the instance.
+
<dt> simplification (simplify.m)
<dd>
@@ -329,8 +344,9 @@
The first two passes of this stage are code simplifications.
<ul>
-<li> introduction of type_info arguments for polymorphic predicates and
- transformation of complicated unifications into predicate calls
+<li> introduction of type_info arguments for polymorphic predicates,
+ introduction of typeclass_info arguments for typeclass-constrained predicates
+ and transformation of complicated unifications into predicate calls
(polymorphism.m)
<li> removal of lambda expressions (lambda.m) <br>
@@ -626,6 +642,10 @@
creates base_type_functors structures that give information on
the functors of a given type. The base_type_layout and base_type_functors
structures of each declared type constructor are added to the LLDS.
+<ul>
+<li> base_typeclass_info.m generates the base_typeclass_info structures that
+ list the methods of a class for each instance declaration. These are added to
+ the LLDS.
<li> stack_layout.m generates the stack_layout structures for
accurate garbage collection. Tables are created from the data
diff -u -r compiler/notes/glossary.html /home/pgrad/dgj/mer/work/mercury/compiler/notes/glossary.html
--- compiler/notes/glossary.html Thu Apr 3 15:17:38 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/notes/glossary.html Wed Nov 26 15:55:57 1997
@@ -15,6 +15,10 @@
<dl>
+<dt> class context
+ <dd>
+ The typeclass constraints on a predicate or function.
+
<dt> HLDS
<dd>
The "High Level Data Structure". See hlds.m.
diff -u -r compiler/polymorphism.m /home/pgrad/dgj/mer/work/mercury/compiler/polymorphism.m
--- compiler/polymorphism.m Wed Dec 17 13:25:46 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/polymorphism.m Mon Dec 15 17:15:47 1997
@@ -158,7 +158,7 @@
% Every predicate which has a typeclass constraint is given an extra
% argument for every constraint in the predicate's type declaration.
% The argument is the "dictionary", or "typeclass_info" for the typeclass.
-% The dictionary contains pointers to each of the class methods
+% The dictionary contains pointers to each of the class methods.
%
%-----------------------------------------------------------------------------%
%
@@ -168,14 +168,13 @@
% type_info being represented in two parts (the type_info and the
% base_type_info).
%
-% The base_type_info contains:
-% * arity of the instance declaration (ie. the number of
-% constraints on the decl).
+% The base_typeclass_info contains:
+% * the number of constraints on the instance decl.
% * pointer to method #1
% ...
% * pointer to method #n
%
-% The type_info contains:
+% The typeclass_info contains:
% * a pointer to the base typeclass info
% * typeclass info #1 for constraint on instance decl
% * ...
@@ -220,7 +219,7 @@
% * typeclass info for foo(T)
% * type info for list(T)
%
-% Where the "T" for the list is known, the whole typeclass_info will be static
+% If the "T" for the list is known, the whole typeclass_info will be static
% data. When we do not know until runtime, the typeclass_info is constructed
% dynamically.
%
@@ -232,17 +231,17 @@
% ignoring the requirement for super-homogeneous form for clarity:
%
% :- pred p(T1) <= foo(T1).
-% :- pred q(T2) <= foo(T2).
-% :- pred r(T3, T4) <= foo(T3).
+% :- pred q(T2, T3) <= foo(T2), bar(T3).
+% :- pred r(T4, T5) <= foo(T4).
%
-% p(X) :- q([X]), r(0, X).
+% p(X) :- q([X], 0), r(0, X).
%
% We add an extra argument for each typeclass constraint, and one argument for
% each unconstrained type variable.
%
% :- pred p(typeclass_info(foo(T1)), T1).
-% :- pred q(typeclass_info(foo(T2)), T2).
-% :- pred r(typeclass_info(foo(T3)), type_info(T4), T3, T4).
+% :- pred q(typeclass_info(foo(T2)), typeclass_info(bar(T3)), T2, T3).
+% :- pred r(typeclass_info(foo(T4)), type_info(T5), T4, T5).
%
% We transform the body of p to this:
%
@@ -250,24 +249,36 @@
% BaseTypeClassInfoT2 = base_typeclass_info(
% 1,
% ...
-% ... (The methods for the class from the list instance)
+% ... (The methods for the foo class from the list
+% ... instance)
% ...
% ),
% TypeClassInfoT2 = typeclass_info(
-% BaseTypeInfoT2,
+% BaseClassTypeInfoT2,
% TypeClassInfoT1,
-% <type_info for list(T1)>,
-% q(TypeClassInfoT2, [X]),
-% BaseTypeClassInfoT3 = baseclass_type_info(
+% <type_info for list(T1)>),
+% BaseTypeClassInfoT3 = base_typeclass_info(
% 0,
% ...
-% ... (The methods for the class from the int instance)
+% ... (The methods for the bar class from the int
+% ... instance)
% ...
% ),
% TypeClassInfoT3 = typeclass_info(
-% BaseTypeInfoT3,
+% BaseClassTypeInfoT3,
% <type_info for int>),
-% r(TypeClassInfoT1, TypeInfoT3, 0, X).
+% q(TypeClassInfoT2, TypeClassInfoT3, [X], 0),
+% BaseTypeClassInfoT4 = baseclass_type_info(
+% 0,
+% ...
+% ... (The methods for the foo class from the int
+% ... instance)
+% ...
+% ),
+% TypeClassInfoT4 = typeclass_info(
+% BaseTypeClassInfoT4,
+% <type_info for int>),
+% r(TypeClassInfoT1, <type_info for int>, 0, X).
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -287,7 +298,7 @@
:- import_module hlds_pred, hlds_goal, hlds_data, llds, (lambda), globals.
:- import_module prog_data, type_util, mode_util, quantification, instmap.
:- import_module code_util, unify_proc, special_pred, prog_util, make_hlds.
-:- import_module std_util, (inst), hlds_out, base_typeclass_info.
+:- import_module (inst), hlds_out, base_typeclass_info.
:- import_module bool, int, string, list, set, map.
:- import_module term, varset, std_util, require, assoc_list.
@@ -651,18 +662,8 @@
BuiltinState, yes(CallContext), SymName)
- GoalInfo },
- % The TypeClassInfoVar is also nonlocal
- % to this conj, since it is used to
- % extract the type_info
- %
- % XXX Do I need to do this?
- { goal_info_get_nonlocals(GoalInfo,
- NonLocals0) },
- { set__insert(NonLocals0, TypeClassInfoVar,
- NonLocals) },
- { goal_info_set_nonlocals(GoalInfo, NonLocals,
- NewGoalInfo) },
- { Goal = conj([Call|Goals]) - NewGoalInfo }
+ { list__append(Goals, [Call], TheGoals) },
+ { Goal = conj(TheGoals) - GoalInfo }
)
; { type_is_higher_order(Type, _, _) } ->
@@ -926,10 +927,10 @@
% polymorphically typed with a type that depends on that
% type-info variable.
%
- % In addition, a typeclass-info is non-local to a goal if any
- % of the non-local variables for that goal are polymorphically
- % typed and are constrained by the typeclass constraints for
- % that typeclass-info variable
+ % In addition, a typeclass-info may be non-local to a goal if
+ % any of the non-local variables for that goal are
+ % polymorphically typed and are constrained by the typeclass
+ % constraints for that typeclass-info variable
%
Goal0 = _ - GoalInfo0,
goal_info_get_nonlocals(GoalInfo0, NonLocals),
@@ -941,11 +942,7 @@
solutions_set(lambda([Var::out] is nondet, (
list__member(TheVar, NonLocalTypeVars),
map__search(TypeVarMap, TheVar, Location),
- (
- Location = type_info(Var)
- ;
- Location = typeclass_info(Var, _)
- )
+ type_info_locn_var(Location, Var)
)), NewOutsideVars),
set__union(NewOutsideVars, NonLocals, OutsideVars),
implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
@@ -966,8 +963,14 @@
PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
TCVarMap, Proofs, PredName, ModuleInfo0),
- % XXX This is wrong. What is the class context really?
- Constraints = [],
+ % Calculate the constraints which apply to this lambda
+ % expression.
+ map__keys(TCVarMap, AllConstraints),
+ map__apply_to_list(Vars, VarTypes, LambdaVarTypes),
+ list__map(type_util__vars, LambdaVarTypes, LambdaTypeVarsList),
+ list__condense(LambdaTypeVarsList, LambdaTypeVars),
+ list__filter(polymorphism__constraint_contains_vars(LambdaTypeVars),
+ AllConstraints, Constraints),
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals, LambdaGoal, Unification0, VarSet, VarTypes,
@@ -976,6 +979,19 @@
PolyInfo = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
TCVarMap, Proofs, PredName, ModuleInfo).
+:- pred polymorphism__constraint_contains_vars(list(var), class_constraint).
+:- mode polymorphism__constraint_contains_vars(in, in) is semidet.
+
+polymorphism__constraint_contains_vars(LambdaVars, ClassConstraint) :-
+ ClassConstraint = constraint(_, ConstraintTypes),
+ list__map(type_util__vars, ConstraintTypes, ConstraintVarsList),
+ list__condense(ConstraintVarsList, ConstraintVars),
+ % Probably not the most efficient way of doing it, but I
+ % wouldn't think that it matters.
+ set__list_to_set(LambdaVars, LambdaVarsSet),
+ set__list_to_set(ConstraintVars, ConstraintVarsSet),
+ set__subset(ConstraintVarsSet, LambdaVarsSet).
+
%---------------------------------------------------------------------------%
% Given a list of constraints, create a list of variables to hold the
@@ -1155,7 +1171,7 @@
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, SubClassId, SubClassDefn),
SubClassDefn = hlds_class_defn(SuperClasses0,
- SubClassVars, _, _),
+ SubClassVars, _, _, _),
% Work out which superclass typeclass_info to
% take
@@ -1365,15 +1381,11 @@
Info0 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
Proofs, PredName, ModuleInfo),
- ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet),
+ ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet, _),
map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
varset__merge_subst(VarSet0, ClassVarSet, VarSet1, Subst),
- % XXX I think the SuperClassProofs need to have the
- % substitutions applied since the code that uses them
- % assumes that this has already been done. (?)
-
Info1 = poly_info(VarSet1, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
SuperClassProofs, PredName, ModuleInfo),
@@ -1439,7 +1451,6 @@
% To allow univ_to_type to check the type_infos
% correctly, the actual arity of the pred is added to
% the type_info of higher-order types.
- % XXX fix this when contexts are added to higher order types
hlds_out__pred_or_func_to_str(PredOrFunc, PredOrFuncStr),
TypeId = unqualified(PredOrFuncStr) - 0,
polymorphism__construct_type_info(Type, TypeId, TypeArgs,
@@ -1965,9 +1976,9 @@
TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
VarSet, VarTypes, TypeInfoLocns) :-
- % We need a dummy tvarset to pass to get_pred_id_and_proc_id
+ % We need a tvarset to pass to get_pred_id_and_proc_id
varset__init(TVarSet0),
- varset__new_var(TVarSet0, Dummy, TVarSet),
+ varset__new_var(TVarSet0, TVar, TVarSet),
term__context_init(EmptyContext),
ExtractTypeInfo = qualified("mercury_builtin",
@@ -1976,12 +1987,8 @@
EmptyContext),
IntTerm = term__functor(term__atom("int"), [], EmptyContext),
TypeInfoTerm = term__functor(term__atom("type_info"),
- [term__variable(Dummy)], EmptyContext),
+ [term__variable(TVar)], EmptyContext),
- % We have to put an extra type_info at the front, and pass it a
- % bogus value because this pred has a type parameter... even
- % though we are actually _extracting_ the type_info.
- % Existential types would fix this.
get_pred_id_and_proc_id(ExtractTypeInfo, predicate, TVarSet,
[TypeClassInfoTerm, IntTerm, TypeInfoTerm],
ModuleInfo, PredId, ProcId),
@@ -1990,6 +1997,12 @@
polymorphism__new_type_info_var(Type, "type_info", VarSet1, VarTypes1,
TypeInfoVar, VarSet2, VarTypes2),
+
+ % We have to put an extra type_info at the front of the call to
+ % type_info_from_typeclass_info, and pass it a bogus value
+ % because the pred has a type parameter... even though we are
+ % actually _extracting_ the type_info. Existential typing of
+ % type_info_from_typeclass_info would fix this.
polymorphism__new_type_info_var(Type, "type_info", VarSet2, VarTypes2,
DummyTypeInfoVar, VarSet, VarTypes),
@@ -2078,7 +2091,7 @@
ClassId = class_id(ClassName0, ClassArity),
module_info_classes(ModuleInfo, ClassTable),
map__lookup(ClassTable, ClassId, ClassDefn),
- ClassDefn = hlds_class_defn(SuperClasses, _, _, _),
+ ClassDefn = hlds_class_defn(SuperClasses, _, _, _, _),
list__length(SuperClasses, NumSuperClasses),
unqualify_name(ClassName0, ClassName),
@@ -2150,18 +2163,22 @@
%---------------------------------------------------------------------------%
+ % Expand the bodies of all class methods for typeclasses which
+ % were defined in this module. The expansion involves inserting a
+ % class_method_call with the appropriate arguments, which is
+ % responsible for extracting the appropriate part of the dictionary.
:- pred polymorphism__expand_class_method_bodies(module_info, module_info).
:- mode polymorphism__expand_class_method_bodies(in, out) is det.
polymorphism__expand_class_method_bodies(ModuleInfo0, ModuleInfo) :-
module_info_classes(ModuleInfo0, Classes),
- module_info_name(ModuleInfo0, Name),
+ module_info_name(ModuleInfo0, ModuleName),
map__keys(Classes, ClassIds0),
% Don't expand classes from other modules
FromThisModule = lambda([ClassId::in] is semidet,
(
- ClassId = class_id(qualified(Name, _), _)
+ ClassId = class_id(qualified(ModuleName, _), _)
)),
list__filter(FromThisModule, ClassIds0, ClassIds),
@@ -2171,7 +2188,8 @@
:- pred expand_bodies(hlds_class_defn, module_info, module_info).
:- mode expand_bodies(in, in, out) is det.
-expand_bodies(hlds_class_defn(_, _, Interface, _), ModuleInfo0, ModuleInfo) :-
+expand_bodies(hlds_class_defn(_, _, Interface, _, _),
+ ModuleInfo0, ModuleInfo) :-
list__foldl2(expand_one_body, Interface, 1, _, ModuleInfo0, ModuleInfo).
:- pred expand_one_body(hlds_class_proc, int, int, module_info, module_info).
@@ -2184,20 +2202,19 @@
pred_info_procedures(PredInfo0, ProcTable0),
map__lookup(ProcTable0, ProcId, ProcInfo0),
+ % Find which of the constraints on the pred is the one
+ % introduced because it is a class method.
pred_info_get_class_context(PredInfo0, ClassContext),
(
ClassContext = [Head|_]
->
- InstanceDictContext = Head
+ InstanceConstraint = Head
;
error("expand_one_body: class method is not constrained")
),
proc_info_typeclass_info_varmap(ProcInfo0, VarMap),
- map__lookup(VarMap, InstanceDictContext, TypeClassInfoVar),
-
- %proc_info_variables(ProcInfo0, VarSet0),
- %proc_info_vartypes(ProcInfo0, VarTypes0),
+ map__lookup(VarMap, InstanceConstraint, TypeClassInfoVar),
proc_info_headvars(ProcInfo0, HeadVars0),
proc_info_vartypes(ProcInfo0, Types0),
@@ -2211,6 +2228,11 @@
error("missing determinism decl. How did we get this far?")
),
+ % Work out which argument corresponds to the constraint which
+ % is introduced because this is a class method, then delete it
+ % from the list of args to the class_method_call. That variable
+ % becomes the "dictionary" variable for the class_method_call.
+ % (cf. the closure for a higher order call).
(
list__nth_member_search(HeadVars0, TypeClassInfoVar, N),
delete_nth(HeadVars0, N, HeadVars1),
@@ -2226,8 +2248,7 @@
BodyGoalExpr = class_method_call(TypeClassInfoVar, ProcNum0,
HeadVars, Types, Modes, Detism),
- % Make the goal info for the call. Maybe we should re modecheck
- % the whole thing?
+ % Make the goal info for the call.
set__list_to_set(HeadVars0, NonLocals),
instmap_delta_from_mode_list(HeadVars0, Modes0, ModuleInfo0,
InstmapDelta),
diff -u -r compiler/prog_data.m /home/pgrad/dgj/mer/work/mercury/compiler/prog_data.m
--- compiler/prog_data.m Thu Dec 18 18:00:18 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/prog_data.m Mon Dec 15 17:21:23 1997
@@ -18,8 +18,8 @@
:- interface.
-:- import_module hlds_data, hlds_pred, (inst), purity.
-:- import_module term_util, list, map, varset, term, std_util.
+:- import_module hlds_data, hlds_pred, (inst), purity, term_util.
+:- import_module list, map, varset, term, std_util.
%-----------------------------------------------------------------------------%
@@ -52,13 +52,13 @@
; module_defn(varset, module_defn)
; pred(varset, sym_name, list(type_and_mode),
- maybe(determinism), condition,
- purity, list(class_constraint))
+ maybe(determinism), condition, purity,
+ list(class_constraint))
% VarNames, PredName, ArgTypes, Deterministicness, Cond
; func(varset, sym_name, list(type_and_mode), type_and_mode,
- maybe(determinism), condition,
- purity, list(class_constraint))
+ maybe(determinism), condition, purity,
+ list(class_constraint))
% VarNames, PredName, ArgTypes, ReturnType,
% Deterministicness, Cond
@@ -74,12 +74,12 @@
; pragma(pragma_type)
- ; typeclass(list(class_constraint), classname, list(var),
+ ; typeclass(list(class_constraint), class_name, list(var),
class_interface, varset)
% Constraints, ClassName, ClassParams,
% ClassMethods, VarNames
- ; instance(list(class_constraint), classname, list(type),
+ ; instance(list(class_constraint), class_name, list(type),
instance_interface, varset)
% DerivingClass, ClassName, Types,
% MethodInstances, VarNames
@@ -167,9 +167,9 @@
; check_termination(sym_name, arity).
% Predname, Arity
-:- type class_constraint ---> constraint(classname, list(type)).
+:- type class_constraint ---> constraint(class_name, list(type)).
-:- type classname == sym_name.
+:- type class_name == sym_name.
:- type class_interface == list(class_method).
diff -u -r compiler/prog_io.m /home/pgrad/dgj/mer/work/mercury/compiler/prog_io.m
--- compiler/prog_io.m Thu Dec 18 18:08:13 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/prog_io.m Mon Dec 15 17:23:32 1997
@@ -55,8 +55,8 @@
:- interface.
-:- import_module prog_data.
-:- import_module list, io, prog_io_util.
+:- import_module prog_data, prog_io_util.
+:- import_module list, io.
%-----------------------------------------------------------------------------%
@@ -97,7 +97,8 @@
%
% parse Term. If successful, MaybeItem is bound to the parsed item,
% otherwise it is bound to an appropriate error message.
- % Qualify appropriate parts to come from ModuleName
+ % Qualify appropriate parts of the item, with ModuleName as the
+ % module name.
:- pred parse_item(string, varset, term, maybe_item_and_context).
:- mode parse_item(in, in, in, out) is det.
@@ -528,6 +529,29 @@
process_decl(ModuleName, VarSet, "func", [FuncDecl], Result) :-
parse_type_decl_func(ModuleName, VarSet, FuncDecl, pure, Result).
+ % Because "<=" has a higher precedence than "pred" or "func", we
+ % we need to handle preds and funcs with class contexts specially.
+process_decl(ModuleName, VarSet, "<=", [Decl, ClassContext], Result) :-
+ (
+ Decl = term__functor(term__atom("pred"), [PredDecl], Context)
+ ->
+ NewTerm = term__functor(term__atom("<="),
+ [PredDecl, ClassContext], Context),
+ parse_type_decl_pred(ModuleName, VarSet, NewTerm, pure,
+ Result)
+ ;
+ Decl = term__functor(term__atom("func"), [FuncDecl], Context)
+ ->
+ NewTerm = term__functor(term__atom("<="),
+ [FuncDecl, ClassContext], Context),
+ parse_type_decl_func(ModuleName, VarSet, NewTerm, pure,
+ Result)
+ ;
+ Result = error(
+ "Class contexts only allowed on pred or func declarations",
+ Decl)
+ ).
+
process_decl(ModuleName, VarSet, "mode", [ModeDecl], Result) :-
parse_mode_decl(ModuleName, VarSet, ModeDecl, Result).
@@ -1150,7 +1174,7 @@
).
:- pred process_pred_2(maybe_functor, term, varset, maybe(determinism),
- condition, purity, list(class_constraint),
+ condition, purity, list(class_constraint),
maybe1(item)).
:- mode process_pred_2(in, in, in, in, in, in, in, out) is det.
@@ -1171,15 +1195,15 @@
Result = error("syntax error in `:- pred' declaration",
PredType)
).
-process_pred_2(error(M, T), _, _, _, _, _, error(M, T)).
+process_pred_2(error(M, T), _, _, _, _, _, _, error(M, T)).
%-----------------------------------------------------------------------------%
% We could probably get rid of some code duplication between here and
% prog_io_typeclass.m
% The last argument is `no' if no context was given, and yes(Result) if
% there was. Result is either bound to the correctly parsed context, or
- % an appropriate error message (if a syntactically invalid error
- % message was given.
+ % an appropriate error message (if a syntactically invalid class
+ % context was given).
:- pred maybe_get_class_context(string, term, term,
maybe1(list(class_constraint))).
@@ -1232,22 +1256,22 @@
(
MaybeContext = ok(Constraints),
process_unconstrained_func(ModuleName, VarSet, Term,
- Cond, Purity, MaybeDet, Constraints, Result)
+ Cond, MaybeDet, Purity, Constraints, Result)
;
MaybeContext = error(String, ErrorTerm),
Result = error(String, ErrorTerm)
)
;
process_unconstrained_func(ModuleName, VarSet, Term0,
- Cond, Purity, MaybeDet, [], Result)
+ Cond, MaybeDet, Purity, [], Result)
).
:- pred process_unconstrained_func(string, varset, term, condition,
- purity, maybe(determinism), list(class_constraint), maybe1(item)).
+ maybe(determinism), purity, list(class_constraint), maybe1(item)).
:- mode process_unconstrained_func(in, in, in, in, in, in, in, out) is det.
-process_unconstrained_func(ModuleName, VarSet, Term, Cond, Purity, MaybeDet,
- Constraints, Result) :-
+process_unconstrained_func(ModuleName, VarSet, Term, Cond, MaybeDet,
+ Purity, Constraints, Result) :-
(
Term = term__functor(term__atom("="),
[FuncTerm, ReturnTypeTerm], _Context)
@@ -1308,7 +1332,7 @@
"syntax error in arguments of `:- func' declaration",
FuncTerm)
).
-process_func_2(error(M, T), _, _, _, _, _, _, error(M, T)).
+process_func_2(error(M, T), _, _, _, _, _, _, _, error(M, T)).
%-----------------------------------------------------------------------------%
diff -u -r compiler/prog_out.m /home/pgrad/dgj/mer/work/mercury/compiler/prog_out.m
--- compiler/prog_out.m Wed Dec 17 13:25:46 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/prog_out.m Thu Dec 18 11:31:02 1997
@@ -26,6 +26,9 @@
:- pred prog_out__write_context(term__context, io__state, io__state).
:- mode prog_out__write_context(in, di, uo) is det.
+ % XXX This pred should be deleted, and all uses replaced with
+ % XXX error_util:write_error_pieces, once zs has committed that
+ % XXX error_util.m.
:- pred prog_out__write_strings_with_context(term__context, list(string),
io__state, io__state).
:- mode prog_out__write_strings_with_context(in, in, di, uo) is det.
diff -u -r compiler/purity.m /home/pgrad/dgj/mer/work/mercury/compiler/purity.m
--- compiler/purity.m Thu Dec 11 21:31:08 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/purity.m Thu Dec 18 18:37:45 1997
@@ -366,6 +366,11 @@
{ HOCall = higher_order_call(_,_,_,_,_,_) },
error_if_body_purity_indicated(GoalInfo, NumErrors0, NumErrors,
InClosure, "higher order goal").
+compute_expr_purity(CMCall, CMCall, GoalInfo, _, _, InClosure, pure,
+ NumErrors0, NumErrors) -->
+ { CMCall = class_method_call(_,_,_,_,_,_) },
+ error_if_body_purity_indicated(GoalInfo, NumErrors0, NumErrors,
+ InClosure, "class method goal").
compute_expr_purity(switch(Var,Canfail,Cases0,Storemap),
switch(Var,Canfail,Cases,Storemap), GoalInfo, PredInfo,
ModuleInfo, InClosure, Purity, NumErrors0, NumErrors) -->
diff -u -r compiler/simplify.m /home/pgrad/dgj/mer/work/mercury/compiler/simplify.m
--- compiler/simplify.m Thu Dec 18 14:55:21 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/simplify.m Wed Dec 10 18:20:54 1997
@@ -424,12 +424,8 @@
Info = Info0
).
- % XXX This is a little conservative, but will make no difference at
- % this stage. We could eliminate duplicate class_method_calls, but
- % since class_method_calls will only appear as the bodies of class
- % methods, there will never be duplicates. If we start inlining the
- % bodies of class methods (or other such optimisations), then adding
- % the simplification code for class_method_calls may be worth it.
+ % XXX We ought to do duplicate call elimination for class
+ % XXX method calls here.
simplify__goal_2(Goal, GoalInfo, Goal, GoalInfo, Info, Info) :-
Goal = class_method_call(_, _, _, _, _, _).
diff -u -r compiler/stratify.m /home/pgrad/dgj/mer/work/mercury/compiler/stratify.m
--- compiler/stratify.m Thu Dec 18 14:55:22 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/stratify.m Wed Dec 10 18:22:00 1997
@@ -409,13 +409,12 @@
->
{ goal_info_get_context(GoalInfo, Context) },
emit_message(ThisPredProcId, Context,
- "higher order call may introduce a non-stratified loop",
+ "higher order call may introduce a non-stratified loop",
Error, Module0, Module)
;
{ Module = Module0 }
).
- % XXX Is this right? Hmmmm. I need to talk to Tom.
higher_order_check_goal(class_method_call(_Var, _Num, _Vars, _Types, _Modes,
_Det), GoalInfo, Negated, _WholeScc, ThisPredProcId,
HighOrderLoops, Error, Module0, Module) -->
@@ -425,7 +424,7 @@
->
{ goal_info_get_context(GoalInfo, Context) },
emit_message(ThisPredProcId, Context,
- "higher order call may introduce a non-stratified loop",
+ "class method call may introduce a non-stratified loop",
Error, Module0, Module)
;
{ Module = Module0 }
diff -u -r compiler/term_pass1.m /home/pgrad/dgj/mer/work/mercury/compiler/term_pass1.m
--- compiler/term_pass1.m Wed Dec 17 13:25:46 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/term_pass1.m Mon Dec 15 17:32:47 1997
@@ -490,6 +490,8 @@
proc_inequalities_goal(class_method_call(_, _, _, _, _, _),
GoalInfo, _Module, _, _PPId, Error, Offs, Offs) :-
goal_info_get_context(GoalInfo, Context),
+ % It would be better to use a new alternative
+ % `class_method_call' rather than than `horder_call' here.
Error = error(Context - horder_call).
proc_inequalities_goal(switch(_SwitchVar, _CanFail, Cases, _StoreMap), GoalInfo,
diff -u -r compiler/type_util.m /home/pgrad/dgj/mer/work/mercury/compiler/type_util.m
--- compiler/type_util.m Wed Dec 17 13:25:46 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/type_util.m Mon Dec 15 17:42:57 1997
@@ -136,7 +136,7 @@
:- mode type_list_subsumes(in, in, out) is semidet.
% type_list_matches_exactly(TypesA, TypesB) succeeds iff TypesA and
- % TypesB are exactly the same module variable renaming.
+ % TypesB are exactly the same modulo variable renaming.
:- pred type_list_matches_exactly(list(type), list(type)).
:- mode type_list_matches_exactly(in, in) is semidet.
@@ -697,13 +697,7 @@
;
NewVar = Var
),
- (
- Locn = type_info(_),
- NewLocn = type_info(NewVar)
- ;
- Locn = typeclass_info(_, Num),
- NewLocn = typeclass_info(NewVar, Num)
- ),
+ type_info_locn_set_var(Locn, NewVar, NewLocn),
% if the tvar is still a variable, insert it into the
% map with the new var.
diff -u -r compiler/typecheck.m /home/pgrad/dgj/mer/work/mercury/compiler/typecheck.m
--- compiler/typecheck.m Thu Dec 18 18:08:57 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/typecheck.m Wed Dec 17 13:06:22 1997
@@ -427,7 +427,7 @@
pred_info_typevarset(PredInfo0, TypeVarSet0),
pred_info_clauses_info(PredInfo0, ClausesInfo0),
pred_info_import_status(PredInfo0, Status),
- pred_info_get_marker_list(PredInfo0, Markers),
+ pred_info_get_markers(PredInfo0, Markers),
ClausesInfo0 = clauses_info(VarSet, ExplicitVarTypes,
_OldInferredVarTypes, HeadVars, Clauses0),
(
@@ -436,7 +436,7 @@
% There are no clauses for class methods.
% The clauses are generated later on,
% in polymorphism__expand_class_method_bodies
- ( list__member(request(class_method), Markers) ->
+ ( check_marker(Markers, class_method) ->
IOState = IOState0,
% For the moment, we just insert the types
% of the head vars into the clauses_info
@@ -456,7 +456,6 @@
Changed = no
)
;
- pred_info_get_markers(PredInfo0, Markers),
( check_marker(Markers, infer_type) ->
% For a predicate whose type is inferred,
% the predicate is allowed to bind the type
@@ -958,11 +957,11 @@
{ Arity1 is Arity + 1 },
{ PredCallId = unqualified("call")/Arity1 },
typecheck_info_set_called_predid(PredCallId),
-% XXX DGJ
-% XXX This is wrong, and needs serious thought. It will do for now.
-% XXX We need to add constraints to higher order thingies.
+ % The class context is empty because higher-order predicates
+ % are always monomorphic.
+ { ClassContext = [] },
typecheck_var_has_polymorphic_type_list([PredVar|Args], TypeVarSet,
- [PredVarType|ArgTypes], []).
+ [PredVarType|ArgTypes], ClassContext).
:- pred higher_order_pred_type(int, tvarset, type, list(type)).
:- mode higher_order_pred_type(in, out, out, out) is det.
@@ -1047,7 +1046,7 @@
% sanity check
PredClassContext \= []
->
- error("non-polymorphic pred has context")
+ error("non-polymorphic pred has class context")
;
true
)
@@ -1057,7 +1056,11 @@
PredClassContext,
TypeCheckInfo1, TypeCheckInfo2)
),
- % Should we really do this now?
+ % Arguably, we could do context reduction at
+ % a different point. See the paper:
+ % "Type class: an exploration of the design
+ % space", S.P. Jones, M. Jones 1997.
+ % for a discussion of some of the issues.
perform_context_reduction(TypeCheckInfo2, TypeCheckInfo)
;
typecheck_info_get_pred_import_status(TypeCheckInfo1,
@@ -1194,7 +1197,7 @@
;
% if there is no matching predicate for this call,
% then this predicate must have a type error which
- % should have been caught by in typechecking.
+ % should have been caught by typechecking.
error("type error in pred call: no matching pred")
).
@@ -1346,14 +1349,6 @@
),
convert_args_type_assign_set(ArgTypeAssigns, TypeAssigns).
-:- pred conv_args_type_assign_set(args_type_assign_set, type_assign_set).
-:- mode conv_args_type_assign_set(in, out) is det.
-
-conv_args_type_assign_set([], []).
-conv_args_type_assign_set([X|Xs], [Y|Ys]) :-
- conv_args_type_assign(X, Y),
- conv_args_type_assign_set(Xs, Ys).
-
:- pred conv_args_type_assign(pair(type_assign, list(type)), type_assign).
:- mode conv_args_type_assign(in, out) is det.
@@ -1744,7 +1739,8 @@
typecheck_unification(X, var(Y), var(Y)) -->
typecheck_unify_var_var(X, Y).
typecheck_unification(X, functor(F, As), functor(F, As)) -->
- typecheck_unify_var_functor(X, F, As).
+ typecheck_unify_var_functor(X, F, As),
+ perform_context_reduction.
typecheck_unification(X, lambda_goal(PredOrFunc, Vars, Modes, Det, Goal0),
lambda_goal(PredOrFunc, Vars, Modes, Det, Goal)) -->
typecheck_lambda_var_has_type(PredOrFunc, X, Vars),
@@ -1880,10 +1876,12 @@
:- type args_type_assign_set == list(args_type_assign).
-:- type args_type_assign ---> args(type_assign, list(type),
- list(class_constraint)).
- % Type assignment, types of callee,
- % constraints from callee
+:- type args_type_assign
+ ---> args(
+ type_assign, % Type assignment,
+ list(type), % types of callee,
+ list(class_constraint) % constraints from callee
+ ).
:- pred typecheck_unify_var_functor_get_ctors(type_assign_set,
typecheck_info, list(cons_type_info),
@@ -2091,7 +2089,8 @@
get_cons_stuff(ConsDefn, TypeAssign0, _TypeCheckInfo, ConsType, ArgTypes,
TypeAssign) :-
- ConsDefn = cons_type_info(ConsTypeVarSet, ConsType0, ArgTypes0),
+ ConsDefn = cons_type_info(ConsTypeVarSet, ConsType0, ArgTypes0,
+ ClassConstraints0),
% Rename apart the type vars in the type of the constructor
% and the types of its arguments.
@@ -2104,11 +2103,18 @@
;
type_assign_rename_apart(TypeAssign0, ConsTypeVarSet,
[ConsType0 | ArgTypes0],
- TypeAssign1, [ConsType1 | ArgTypes1], _)
+ TypeAssign1, [ConsType1 | ArgTypes1], Subst)
->
+ apply_subst_to_constraints(Subst, ClassConstraints0,
+ ClassConstraints2),
+ type_assign_get_typeclass_constraints(TypeAssign1,
+ OldConstraints),
+ list__append(OldConstraints, ClassConstraints2,
+ ClassConstraints),
+ type_assign_set_typeclass_constraints(TypeAssign1,
+ ClassConstraints, TypeAssign),
ConsType = ConsType1,
- ArgTypes = ArgTypes1,
- TypeAssign = TypeAssign1
+ ArgTypes = ArgTypes1
;
error("get_cons_stuff: type_assign_rename_apart failed")
).
@@ -2270,7 +2276,13 @@
make_pred_cons_info_list(TypeCheckInfo, PredIds, PredTable, Arity,
ModuleInfo, L1, L).
-:- type cons_type_info ---> cons_type_info(tvarset, type, list(type)).
+:- type cons_type_info
+ ---> cons_type_info(
+ tvarset,
+ type,
+ list(type),
+ list(class_constraint)
+ ).
:- pred make_pred_cons_info(typecheck_info, pred_id, pred_table, int,
module_info, list(cons_type_info), list(cons_type_info)).
@@ -2281,6 +2293,7 @@
map__lookup(PredTable, PredId, PredInfo),
pred_info_arity(PredInfo, PredArity),
pred_info_get_is_pred_or_func(PredInfo, IsPredOrFunc),
+ pred_info_get_class_context(PredInfo, ClassContext),
(
IsPredOrFunc = predicate,
PredArity >= FuncArity
@@ -2295,7 +2308,7 @@
PredType = term__functor(term__atom("pred"),
PredTypeParams, Context),
ConsInfo = cons_type_info(PredTypeVarSet,
- PredType, ArgTypes),
+ PredType, ArgTypes, ClassContext),
L = [ConsInfo | L0]
;
error("make_pred_cons_info: split_list failed")
@@ -2328,7 +2341,7 @@
], Context)
),
ConsInfo = cons_type_info(PredTypeVarSet,
- FuncType, FuncArgTypes),
+ FuncType, FuncArgTypes, ClassContext),
L = [ConsInfo | L0]
;
error("make_pred_cons_info: split_list or remove_suffix failed")
@@ -2353,7 +2366,7 @@
Arity1 is Arity - 1,
higher_order_func_type(Arity1, TypeVarSet, FuncType, ArgTypes, RetType),
ConsTypeInfos = [cons_type_info(TypeVarSet, RetType,
- [FuncType | ArgTypes])].
+ [FuncType | ArgTypes], [])].
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -2886,7 +2899,7 @@
ConsType = term__functor(term__atom(BuiltInTypeName), [],
Context),
varset__init(ConsTypeVarSet),
- ConsInfo = cons_type_info(ConsTypeVarSet, ConsType, []),
+ ConsInfo = cons_type_info(ConsTypeVarSet, ConsType, [], []),
ConsInfoList1 = [ConsInfo | ConsInfoList0]
;
ConsInfoList1 = ConsInfoList0
@@ -2938,7 +2951,9 @@
:- mode typecheck_constraints(in, typecheck_info_di, typecheck_info_uo) is det.
% XXX if we're inferring, don't bother checking the constraints at this
- % XXX stage. Fix this up.
+ % XXX stage. Fix this up. Handling inference isn't actually that
+ % XXX difficult: you just collect the constraint set, perform context
+ % XXX reduction, and that is the class context of the pred.
typecheck_constraints(yes, TypeCheckInfo, TypeCheckInfo).
typecheck_constraints(no, TypeCheckInfo0, TypeCheckInfo) :-
%get the declared constraints
@@ -3072,7 +3087,6 @@
TypeAssignSet, TypeCheckInfo)
).
- % XXX do we need to do this to fixpoint?
:- pred reduce_type_assign_context(class_table, instance_table,
type_assign, type_assign).
:- mode reduce_type_assign_context(in, in, in, out) is semidet.
@@ -3098,40 +3112,55 @@
Bindings, Tvarset0, Tvarset, Proofs0, Proofs,
Constraints0, Constraints) :-
apply_instance_rules(Constraints0, InstanceTable, Bindings,
- Tvarset0, Tvarset, Proofs0, Proofs1, Constraints1),
- apply_class_rules(Constraints1, ClassTable, Bindings, Tvarset,
- Proofs1, Proofs, Constraints2),
- list__sort_and_remove_dups(Constraints2, Constraints).
+ Tvarset0, Tvarset1, Proofs0, Proofs1, Constraints1, Changed1),
+ apply_class_rules(Constraints1, ClassTable, Bindings, Tvarset1,
+ Proofs1, Proofs2, Constraints2, Changed2),
+ (
+ Changed1 = no, Changed2 = no
+ ->
+ % We have reached fixpoint
+ list__sort_and_remove_dups(Constraints2, Constraints),
+ Tvarset = Tvarset1,
+ Proofs = Proofs2
+ ;
+ typecheck__reduce_context_by_rule_application(InstanceTable,
+ ClassTable, Bindings, Tvarset1, Tvarset, Proofs2,
+ Proofs, Constraints2, Constraints)
+ ).
:- pred apply_instance_rules(list(class_constraint), instance_table,
tsubst, tvarset, tvarset, map(class_constraint, constraint_proof),
- map(class_constraint, constraint_proof), list(class_constraint)).
-:- mode apply_instance_rules(in, in, in, in, out, in, out, out) is semidet.
+ map(class_constraint, constraint_proof), list(class_constraint), bool).
+:- mode apply_instance_rules(in, in, in, in, out, in, out, out, out) is semidet.
-apply_instance_rules([], _, _, Names, Names, Proofs, Proofs, []).
+apply_instance_rules([], _, _, Names, Names, Proofs, Proofs, [], no).
apply_instance_rules([C|Cs], InstanceTable, Bindings,
- TypeNames, NewTypeNames, Proofs0, Proofs, Constraints) :-
+ TVarSet, NewTVarSet, Proofs0, Proofs,
+ Constraints, Changed) :-
C = constraint(ClassName, Types0),
list__length(Types0, Arity),
map__lookup(InstanceTable, class_id(ClassName, Arity), Instances),
term__apply_rec_substitution_to_list(Types0, Bindings, Types),
(
find_matching_instance_rule(Instances, ClassName, Types,
- TypeNames, NewTypeNames0, Proofs0, Proofs1,
+ TVarSet, NewTVarSet0, Proofs0, Proofs1,
NewConstraints0)
->
% Put the new constraints at the front of the list
NewConstraints = NewConstraints0,
- NewTypeNames1 = NewTypeNames0,
- Proofs2 = Proofs1
+ NewTVarSet1 = NewTVarSet0,
+ Proofs2 = Proofs1,
+ Changed1 = yes
;
% Put the old constraint at the front of the list
NewConstraints = [C],
- NewTypeNames1 = TypeNames,
- Proofs2 = Proofs0
- ),
- apply_instance_rules(Cs, InstanceTable, Bindings, NewTypeNames1,
- NewTypeNames, Proofs2, Proofs, TheRest),
+ NewTVarSet1 = TVarSet,
+ Proofs2 = Proofs0,
+ Changed1 = no
+ ),
+ apply_instance_rules(Cs, InstanceTable, Bindings, NewTVarSet1,
+ NewTVarSet, Proofs2, Proofs, TheRest, Changed2),
+ bool__or(Changed1, Changed2, Changed),
list__append(NewConstraints, TheRest, Constraints).
% We take the first matching instance rule that we can find; any
@@ -3149,27 +3178,27 @@
:- mode find_matching_instance_rule(in, in, in, in, out, in, out, out)
is semidet.
-find_matching_instance_rule(Instances, ClassName, Types, TypeNames,
- NewTypeNames, Proofs0, Proofs, NewConstraints) :-
+find_matching_instance_rule(Instances, ClassName, Types, TVarSet,
+ NewTVarSet, Proofs0, Proofs, NewConstraints) :-
% Start a counter so we remember which instance decl we have
% used.
- find_matching_instance_rule2(Instances, 1, ClassName, Types,
- TypeNames, NewTypeNames, Proofs0, Proofs, NewConstraints).
+ find_matching_instance_rule_2(Instances, 1, ClassName, Types,
+ TVarSet, NewTVarSet, Proofs0, Proofs, NewConstraints).
-:- pred find_matching_instance_rule2(list(hlds_instance_defn), int,
+:- pred find_matching_instance_rule_2(list(hlds_instance_defn), int,
sym_name, list(type), tvarset, tvarset,
map(class_constraint, constraint_proof),
map(class_constraint, constraint_proof), list(class_constraint)).
-:- mode find_matching_instance_rule2(in, in, in, in, in, out, in, out, out)
+:- mode find_matching_instance_rule_2(in, in, in, in, in, out, in, out, out)
is semidet.
-find_matching_instance_rule2([I|Is], N0, ClassName, Types, TypeNames,
- NewTypeNames, Proofs0, Proofs, NewConstraints) :-
+find_matching_instance_rule_2([I|Is], N0, ClassName, Types, TVarSet,
+ NewTVarSet, Proofs0, Proofs, NewConstraints) :-
I = hlds_instance_defn(ModuleName, NewConstraints0, InstanceTypes0,
Interface, PredProcIds, InstanceNames, SuperClassProofs),
(
- varset__merge_subst(TypeNames, InstanceNames, NewTypeNames0,
+ varset__merge_subst(TVarSet, InstanceNames, NewTVarSet0,
RenameSubst),
term__apply_rec_substitution_to_list(InstanceTypes0,
RenameSubst, InstanceTypes),
@@ -3179,7 +3208,7 @@
NewConstraints1),
apply_rec_subst_to_constraints(Subst, NewConstraints1,
NewConstraints),
- NewTypeNames = NewTypeNames0,
+ NewTVarSet = NewTVarSet0,
NewProof = apply_instance(hlds_instance_defn(ModuleName,
NewConstraints, InstanceTypes, Interface, PredProcIds,
InstanceNames, SuperClassProofs), N0),
@@ -3187,8 +3216,8 @@
map__set(Proofs0, Constraint, NewProof, Proofs)
;
N is N0 + 1,
- find_matching_instance_rule2(Is, N, ClassName,
- Types, TypeNames, NewTypeNames, Proofs0,
+ find_matching_instance_rule_2(Is, N, ClassName,
+ Types, TVarSet, NewTVarSet, Proofs0,
Proofs, NewConstraints)
).
@@ -3199,36 +3228,36 @@
% redundant.
:- pred apply_class_rules(list(class_constraint), class_table,
tsubst, tvarset, map(class_constraint, constraint_proof),
- map(class_constraint, constraint_proof), list(class_constraint)).
-:- mode apply_class_rules(in, in, in, in, in, out, out) is det.
+ map(class_constraint, constraint_proof), list(class_constraint), bool).
+:- mode apply_class_rules(in, in, in, in, in, out, out, out) is det.
-apply_class_rules(Constraints0, ClassTable, Bindings, TypeNames,
- Proofs0, Proofs, Constraints) :-
- apply_class_rules2(Constraints0, Constraints0, ClassTable, Bindings,
- TypeNames, Proofs0, Proofs, Constraints).
-
-:- pred apply_class_rules2(list(class_constraint), list(class_constraint),
- class_table, tsubst, tvarset, map(class_constraint, constraint_proof),
- map(class_constraint, constraint_proof), list(class_constraint)).
-:- mode apply_class_rules2(in, in, in, in, in, in, out, out) is det.
+apply_class_rules(Constraints0, ClassTable, Bindings, TVarSet,
+ Proofs0, Proofs, Constraints, Changed) :-
+ apply_rec_subst_to_constraints(Bindings, Constraints0, Constraints1),
+ apply_class_rules_2(Constraints1, Constraints1, ClassTable,
+ TVarSet, Proofs0, Proofs, Constraints, Changed).
+
+:- pred apply_class_rules_2(list(class_constraint), list(class_constraint),
+ class_table, tvarset, map(class_constraint, constraint_proof),
+ map(class_constraint, constraint_proof), list(class_constraint), bool).
+:- mode apply_class_rules_2(in, in, in, in, in, out, out, out) is det.
% The first argument is the list of constraints left to be checked.
% The second argument is the list of constraints that have not been
% rejected. If a redundant constraint is found, it is deleted from
% both (if it is still in the first list).
-apply_class_rules2([], Constraints, _, _, _, Proofs, Proofs, Constraints).
-apply_class_rules2([C|Cs], AllConstraints, ClassTable, Bindings, TypeNames,
- Proofs0, Proofs, Constraints) :-
- C = constraint(ClassName, Types0),
- list__length(Types0, Arity),
+apply_class_rules_2([], Constraints, _, _, Proofs, Proofs, Constraints, no).
+apply_class_rules_2([C|Cs], AllConstraints, ClassTable, TVarSet,
+ Proofs0, Proofs, Constraints, Changed) :-
+ C = constraint(ClassName, Types),
+ list__length(Types, Arity),
ClassId = class_id(ClassName, Arity),
map__lookup(ClassTable, ClassId, ClassDefn),
- term__apply_rec_substitution_to_list(Types0, Bindings, Types),
ClassDefn = hlds_class_defn(ParentClassConstraints0, ClassVars,
- _ClassInterface, ClassVarset),
+ _ClassInterface, ClassVarset, _TermContext),
term__var_list_to_term_list(ClassVars, ClassTypes),
- % XXX Can we really ignore _NewTypeNames?
- varset__merge_subst(TypeNames, ClassVarset, _NewTypeNames, RenameSubst),
+ % XXX Can we really ignore _NewTVarSet?
+ varset__merge_subst(TVarSet, ClassVarset, NewTVarSet, RenameSubst),
term__apply_rec_substitution_to_list(ClassTypes, RenameSubst,
NewClassTypes),
apply_rec_subst_to_constraints(RenameSubst, ParentClassConstraints0,
@@ -3237,7 +3266,7 @@
[ThisConstraint::in, RenamedConstraint::out] is semidet,
(
type_list_subsumes(NewClassTypes, Types, Subst),
- apply_rec_subst_to_constraint(Subst, ThisConstraint,
+ apply_rec_subst_to_constraint(Subst, ThisConstraint,
RenamedConstraint),
list__member(RenamedConstraint, AllConstraints)
)),
@@ -3257,9 +3286,17 @@
TheProofs)
)),
list__foldl(RecordRedundancy, RedundantConstraints, Proofs0, Proofs1),
+ (
+ RedundantConstraints = [],
+ Changed1 = no
+ ;
+ RedundantConstraints = [_|_],
+ Changed1 = yes
+ ),
- apply_class_rules2(NewCs, NewConstraints, ClassTable, Bindings,
- TypeNames, Proofs1, Proofs, Constraints).
+ apply_class_rules_2(NewCs, NewConstraints, ClassTable,
+ NewTVarSet, Proofs1, Proofs, Constraints, Changed2),
+ bool__or(Changed1, Changed2, Changed).
%-----------------------------------------------------------------------------%
@@ -3303,7 +3340,7 @@
hlds_data__get_type_defn_tvarset(TypeDefn, ConsTypeVarSet),
hlds_data__get_type_defn_tparams(TypeDefn, ConsTypeParams),
construct_type(TypeId, ConsTypeParams, Context, ConsType),
- ConsTypeInfo = cons_type_info(ConsTypeVarSet, ConsType, ArgTypes).
+ ConsTypeInfo = cons_type_info(ConsTypeVarSet, ConsType, ArgTypes, []).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -3312,18 +3349,16 @@
:- type type_assign_set == list(type_assign).
-:- type type_assign ---> type_assign(
- map(var, type), % var types
- tvarset, % type names
- tsubst, % type bindings
- list(class_constraint), % typeclass
- % constraints
- map(class_constraint, % for each
- constraint_proof) % constraint
- % found to be
- % redundant,
- % why is it so?
- ).
+:- type type_assign
+ ---> type_assign(
+ map(var, type), % var types
+ tvarset, % type names
+ tsubst, % type bindings
+ list(class_constraint), % typeclass constraints
+ map(class_constraint, % for each constraint
+ constraint_proof) % constraint found to be
+ % redundant, why is it so?
+ ).
%-----------------------------------------------------------------------------%
@@ -3696,7 +3731,7 @@
% arguments only for the arguments in which the two types differ.
(
{ ArgsTypeAssignSet = [SingleArgsTypeAssign] },
- { SingleArgsTypeAssign = TypeAssign - ConsArgTypes },
+ { SingleArgsTypeAssign = args(TypeAssign, ConsArgTypes, _) },
{ assoc_list__from_corresponding_lists(Args, ConsArgTypes,
ArgExpTypes) },
{ find_mismatched_args(ArgExpTypes, [TypeAssign], 1,
@@ -3706,7 +3741,7 @@
report_mismatched_args(Mismatches, yes, VarSet, Context)
;
- { conv_args_type_assign_set(ArgsTypeAssignSet,
+ { convert_args_type_assign_set(ArgsTypeAssignSet,
TypeAssignSet) },
%
@@ -3717,7 +3752,7 @@
(
% could the type of the functor be polymorphic?
{ list__member(ConsDefn, ConsDefnList) },
- { ConsDefn = cons_type_info(_, _, ConsArgTypes) },
+ { ConsDefn = cons_type_info(_, _, ConsArgTypes, _) },
{ ConsArgTypes \= [] }
->
% if so, print out the type of `Var'
@@ -3906,7 +3941,9 @@
io__state, io__state).
:- mode write_cons_type(in, in, in, di, uo) is det.
-write_cons_type(cons_type_info(TVarSet, ConsType0, ArgTypes0), Functor, _) -->
+ % XXX Should we mention the context here?
+write_cons_type(cons_type_info(TVarSet, ConsType0, ArgTypes0, _),
+ Functor, _) -->
{ strip_builtin_qualifier_from_cons_id(Functor, Functor1) },
{ strip_builtin_qualifiers_from_type_list(ArgTypes0, ArgTypes) },
( { ArgTypes \= [] } ->
diff -u -r compiler/unique_modes.m /home/pgrad/dgj/mer/work/mercury/compiler/unique_modes.m
--- compiler/unique_modes.m Thu Dec 18 18:13:23 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/unique_modes.m Wed Dec 17 13:10:29 1997
@@ -370,11 +370,11 @@
unique_modes__check_goal_2(class_method_call(TCVar, Num, Args, Types, Modes,
Det), _GoalInfo0, Goal) -->
mode_checkpoint(enter, "class method call"),
- % This is a little white lie. However, since there can't
- % really be a unique mode error in a class_method_call, this
- % lie will never be used. There can't be an error because the
- % class_method_call is introduced by the compiler as the body
- % of a class method.
+ % Setting the context to `higher_order_call(...)' is a little
+ % white lie. However, since there can't really be a unique
+ % mode error in a class_method_call, this lie will never be
+ % used. There can't be an error because the class_method_call
+ % is introduced by the compiler as the body of a class method.
mode_info_set_call_context(higher_order_call(predicate)),
{ determinism_components(Det, _, at_most_zero) ->
NeverSucceeds = yes
diff -u -r compiler/unused_args.m /home/pgrad/dgj/mer/work/mercury/compiler/unused_args.m
--- compiler/unused_args.m Thu Dec 18 18:11:56 1997
+++ /home/pgrad/dgj/mer/work/mercury/compiler/unused_args.m Thu Dec 18 18:37:49 1997
@@ -929,15 +929,13 @@
pred_info_clauses_info(PredInfo0, ClausesInfo),
pred_info_get_markers(PredInfo0, Markers),
pred_info_get_goal_type(PredInfo0, GoalType),
+ pred_info_get_class_context(PredInfo0, ClassContext),
map__init(EmptyProofs),
% *** This will need to be fixed when the condition
% field of the pred_info becomes used.
- % XXX
- % XXX The class context shouldn't be empty!!!
- % XXX
pred_info_init(PredModule, qualified(PredModule, Name), Arity, Tvars,
ArgTypes, true, Context, ClausesInfo, Status, Markers,
- GoalType, PredOrFunc, [], EmptyProofs, PredInfo1),
+ GoalType, PredOrFunc, ClassContext, EmptyProofs, PredInfo1),
pred_info_set_typevarset(PredInfo1, TypeVars, PredInfo).
love and cuddles,
dgj
--
David Jeffery (dgj at cs.mu.oz.au) | Marge: Did you just call everyone "chicken"?
MEngSc student, | Homer: Noooo. I swear on this Bible!
Department of Computer Science | Marge: That's not a Bible; that's a book of
University of Melbourne | carpet samples!
Australia | Homer: Ooooh... Fuzzy.
More information about the developers
mailing list