diff: typeclasses (final) [4/6]

[David Glen JEFFERY]

+modecheck_goal_expr(class_method_call(_, _, _, _, _, _),
+		_GoalInfo0, _Goal) -->
+	{ error("modecheck_goal_expr: class method exists at modecheck time") }.
+
 modecheck_goal_expr(unify(A0, B0, _, UnifyInfo0, UnifyContext), GoalInfo0, Goal)
 		-->
 	mode_checkpoint(enter, "unify"),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.25
diff -u -r1.25 module_qual.m
--- module_qual.m	1997/12/09 04:01:14	1.25
+++ module_qual.m	1997/12/15 06:19:44
@@ -97,12 +97,13 @@
 			type_id_set,	% Sets of all types, modes and
 			inst_id_set,	% insts visible in this module.
 			mode_id_set,
+			class_id_set,
 			set(module_name), % modules imported in the
 				% interface that are not definitely
 				% needed in the interface.
 			import_status, % import status of the current item.
 			int,	% number of errors found.
-			bool,	% are there any undefined types.
+			bool,	% are there any undefined types or typeclasses.
 			bool,	% are there any undefined insts or modes.
 			bool, 	% do we want to report errors.
 			error_context,	% context of the current item.
@@ -131,14 +132,18 @@
 	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).
 collect_mq_info_2(nothing, Info, Info).
+collect_mq_info_2(typeclass(_, Name, Vars, _, _), Info0, Info) :-
+	add_typeclass_defn(Name, Vars, Info0, Info).
+collect_mq_info_2(instance(_,_,_,_,_), Info, Info).
 
-% Predicates to add the type, inst and mode ids visible
+
+% Predicates to add the type, inst, mode and typeclass ids visible
 % in this module to the mq_info.
 
 :- pred add_type_defn(type_defn::in, mq_info::in, mq_info::out) is det.
@@ -176,6 +181,16 @@
 	id_set_insert(NeedQualifier, SymName - Arity, Modes0, Modes),
 	mq_info_set_modes(Info0, Modes, Info).
 
+:- pred add_typeclass_defn(sym_name::in, list(var)::in, 
+	mq_info::in, mq_info::out) is det.
+
+add_typeclass_defn(SymName, Params, Info0, Info) :-
+	list__length(Params, Arity),
+	mq_info_get_classes(Info0, Classes0),
+	mq_info_get_need_qual_flag(Info0, NeedQualifier),
+	id_set_insert(NeedQualifier, SymName - Arity, Classes0, Classes),
+	mq_info_set_classes(Info0, Classes, Info).
+
 	% Update import status.
 	% Add imported modules if in the interface.
 :- pred process_module_defn(module_defn::in, mq_info::in, mq_info::out) is det.
@@ -258,23 +273,28 @@
 		module_defn(A, ModuleDefn) - Context, Info0, Info, Continue) -->
 	{ update_import_status(ModuleDefn, Info0, Info, Continue) }.
 
-module_qualify_item(pred(A, SymName, TypesAndModes0, D, E, F) - Context,
-		pred(A, SymName, TypesAndModes, D, E, F) - Context,
+module_qualify_item(
+		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,
 								Info1) },
-	qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info).
+	qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info2),
+	qualify_class_constraints(Constraints0, Constraints, Info2, Info).
 
 module_qualify_item(
-		func(A,SymName,TypesAndModes0,TypeAndMode0,D,E,F) - Context,
-		func(A,SymName,TypesAndModes,TypeAndMode,D,E,F) - Context,
+		func(A,SymName, TypesAndModes0, TypeAndMode0, D, E, F
+			,Constraints0) - Context,
+		func(A, SymName, TypesAndModes, TypeAndMode, D, E, F,
+			Constraints) - Context,
 		Info0, Info, yes) -->
 	{ list__length(TypesAndModes0, Arity) },
 	{ mq_info_set_error_context(Info0, func(SymName - Arity) - Context,
 								Info1) },
 	qualify_types_and_modes(TypesAndModes0, TypesAndModes, Info1, Info2),
-	qualify_type_and_mode(TypeAndMode0, TypeAndMode, Info2, Info).
+	qualify_type_and_mode(TypeAndMode0, TypeAndMode, Info2, Info3),
+	qualify_class_constraints(Constraints0, Constraints, Info3, Info).
 
 module_qualify_item(pred_mode(A, SymName, Modes0, C, D) - Context,
 		 	pred_mode(A, SymName, Modes, C, D) - Context,
@@ -299,6 +319,31 @@
 	qualify_pragma(Pragma0, Pragma, Info1, Info).
 module_qualify_item(nothing - Context, nothing - Context,
 						Info, Info, yes) --> [].
+module_qualify_item(typeclass(Constraints0, Name, Vars, Interface0, VarSet) -
+			Context, 
+		typeclass(Constraints, Name, Vars, Interface, VarSet) -
+			Context, 
+		Info0, Info, yes) -->
+	{ list__length(Vars, Arity) },
+	{ Id = Name - Arity },
+	{ mq_info_set_error_context(Info0, class(Id) - Context, Info1) },
+	qualify_class_constraints(Constraints0, Constraints, Info1, Info2),
+	qualify_class_interface(Interface0, Interface, Info2, Info).
+
+module_qualify_item(instance(Constraints0, Name0, Types0, Interface0, VarSet) -
+			Context, 
+		instance(Constraints, Name, Types, Interface, VarSet) -
+			Context, 
+		Info0, Info, yes) -->
+	{ list__length(Types0, Arity) },
+	{ Id = Name0 - Arity },
+	{ mq_info_set_error_context(Info0, instance(Id) - Context, Info1) },
+		% We don't qualify the interface yet, since that requires
+		% us to resolve overloading.
+	qualify_class_constraints(Constraints0, Constraints, Info1, Info2),
+	qualify_class_name(Id, Name - _, Info2, Info3),
+	qualify_type_list(Types0, Types, Info3, Info),
+	{ qualify_instance_interface(Name, Interface0, Interface) }.
 
 :- pred update_import_status(module_defn::in, mq_info::in, mq_info::out,
 							bool::out) is det.
@@ -630,11 +675,116 @@
 	qualify_mode(Mode0, Mode, Info0, Info1),
 	qualify_pragma_vars(PragmaVars0, PragmaVars, Info1, Info).
 
+:- pred qualify_class_constraints(list(class_constraint)::in,
+	list(class_constraint)::out, mq_info::in, mq_info::out, io__state::di,
+	io__state::uo) is det. 
+
+qualify_class_constraints([], [], MQInfo, MQInfo) --> [].
+qualify_class_constraints([C0|C0s], [C|Cs], MQInfo0, MQInfo) -->
+	qualify_class_constraint(C0, C, MQInfo0, MQInfo1),
+	qualify_class_constraints(C0s, Cs, MQInfo1, MQInfo).
+
+:- pred qualify_class_constraint(class_constraint::in, class_constraint::out,
+	mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
+
+qualify_class_constraint(constraint(ClassName0, Types0), 
+	constraint(ClassName, Types), MQInfo0, MQInfo) -->
+	{ list__length(Types0, Arity) },
+	qualify_class_name(ClassName0 - Arity, ClassName - _, MQInfo0, MQInfo1),
+	qualify_type_list(Types0, Types, MQInfo1, MQInfo).
+
+:- 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_class_name(Class0, Class, MQInfo0, MQInfo) -->
+	{ mq_info_get_classes(MQInfo0, ClassIdSet) },
+	find_unique_match(Class0, Class, ClassIdSet, class_id,
+		MQInfo0, MQInfo).
+
+:- pred qualify_class_interface(class_interface::in, class_interface::out,
+	mq_info::in, mq_info::out, io__state::di, io__state::uo) is det. 
+
+qualify_class_interface([], [], MQInfo, MQInfo) --> [].
+qualify_class_interface([M0|M0s], [M|Ms], MQInfo0, MQInfo) -->
+	qualify_class_method(M0, M, MQInfo0, MQInfo1),
+	qualify_class_interface(M0s, Ms, MQInfo1, MQInfo).
+
+:- pred qualify_class_method(class_method::in, class_method::out,
+	mq_info::in, mq_info::out, io__state::di, io__state::uo) is det. 
+
+	% There is no need to qualify the method name, since that is
+	% done when the item is parsed.
+qualify_class_method(
+		pred(Varset, Name, TypesAndModes0, MaybeDet, Cond,
+			ClassContext0, Context), 
+		pred(Varset, Name, TypesAndModes, MaybeDet, Cond, 
+			ClassContext, Context), 
+		MQInfo0, MQInfo
+		) -->
+	qualify_types_and_modes(TypesAndModes0, TypesAndModes, 
+		MQInfo0, MQInfo1),
+	qualify_class_constraints(ClassContext0, ClassContext, 
+		MQInfo1, MQInfo).
+qualify_class_method(
+		func(Varset, Name, TypesAndModes0, ReturnMode0, MaybeDet, Cond,
+			ClassContext0, Context), 
+		func(Varset, Name, TypesAndModes, ReturnMode, MaybeDet, Cond,
+			ClassContext, Context), 
+		MQInfo0, MQInfo
+		) -->
+	qualify_types_and_modes(TypesAndModes0, TypesAndModes, 
+		MQInfo0, MQInfo1),
+	qualify_type_and_mode(ReturnMode0, ReturnMode, MQInfo1, MQInfo2),
+	qualify_class_constraints(ClassContext0, ClassContext, 
+		MQInfo2, MQInfo).
+qualify_class_method(
+		pred_mode(Varset, Name, Modes0, MaybeDet, Cond, Context), 
+		pred_mode(Varset, Name, Modes, MaybeDet, Cond, Context), 
+		MQInfo0, MQInfo
+		) -->
+	qualify_mode_list(Modes0, Modes, MQInfo0, MQInfo).
+qualify_class_method(
+		func_mode(Varset, Name, Modes0, ReturnMode0, MaybeDet, Cond,
+			Context), 
+		func_mode(Varset, Name, Modes, ReturnMode, MaybeDet, Cond,
+			Context), 
+		MQInfo0, MQInfo
+		) -->
+	qualify_mode_list(Modes0, Modes, MQInfo0, MQInfo1),
+	qualify_mode(ReturnMode0, ReturnMode, MQInfo1, MQInfo).
+
+:- pred qualify_instance_interface(sym_name::in, instance_interface::in, 
+	instance_interface::out) is det. 
+
+qualify_instance_interface(ClassName, M0s, Ms) :-
+	(
+		ClassName = qualified(Module, _)
+	;
+		ClassName = unqualified( _),
+		Module = ""
+	),
+	Qualify = lambda([M0::in, M::out] is det,
+		(
+			M0 = pred_instance(unqualified(Method), A, B),
+			M = pred_instance(qualified(Module, Method), A, B)
+		;
+			M0 = pred_instance(qualified(_, _), _A, _B),
+			M = M0
+		;
+			M0 = func_instance(unqualified(Method), A, B),
+			M = func_instance(qualified(Module, Method), A, B)
+		;
+			M0 = func_instance(qualified(_, _), _A, _B),
+			M = M0
+		)),
+	list__map(Qualify, M0s, Ms).
+
 	% Find the unique match in the current name space for a given id
 	% from a list of ids. If none exists, either because no match was
 	% found or mulitiple matches were found, report an error.
-	% This predicate assumes that type_ids, inst_ids and mode_ids
-	% have the same representation.
+	% This predicate assumes that type_ids, inst_ids, mode_ids and
+	% class_ids have the same representation.
 :- pred find_unique_match(id::in, id::out, id_set::in, id_type::in,
 		mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
 
@@ -703,7 +853,8 @@
 :- type id_type --->
 		type_id
 	;	mode_id
-	;	inst_id.
+	;	inst_id
+	;	class_id.
 
 :- type error_context == pair(error_context2, term__context).
 
@@ -719,7 +870,9 @@
 	;	func_mode(id)
 	;	(pragma)
 	;	lambda_expr
-	;	type_qual.
+	;	type_qual
+	;	class(id)
+	;	instance(id).
 
 	% Report an undefined type, inst or mode.
 :- pred report_undefined(error_context, pair(sym_name, int),
@@ -803,12 +956,19 @@
 	io__write_string("pragma").
 write_error_context2(type_qual) -->
 	io__write_string("explicit type qualification").
+write_error_context2(class(Id)) -->
+	io__write_string("declaration of typeclass "),
+	write_id(Id).
+write_error_context2(instance(Id)) -->
+	io__write_string("declaration of instance of typeclass "),
+	write_id(Id).
 
 :- pred id_type_to_string(id_type::in, string::out) is det.
 
 id_type_to_string(type_id, "type").
 id_type_to_string(mode_id, "mode").
 id_type_to_string(inst_id, "inst").
+id_type_to_string(class_id, "typeclass").
 
 	% Write sym_name/arity.
 :- pred write_id(id::in, io__state::di, io__state::uo) is det.
@@ -920,12 +1080,13 @@
 	ErrorContext = type(unqualified("") - 0) - Context,
 	set__init(InterfaceModules0),
 	id_set_init(Empty),
-	Info0 = mq_info(Empty, Empty, Empty, InterfaceModules0, local, 0,
+	Info0 = mq_info(Empty, Empty, Empty, Empty, InterfaceModules0, local, 0,
 		no, no, ReportErrors, ErrorContext, may_be_unqualified).
 
 :- pred mq_info_get_types(mq_info::in, type_id_set::out) is det.
 :- pred mq_info_get_insts(mq_info::in, inst_id_set::out) is det.
 :- pred mq_info_get_modes(mq_info::in, mode_id_set::out) is det.
+:- pred mq_info_get_classes(mq_info::in, class_id_set::out) is det.
 :- pred mq_info_get_interface_modules(mq_info::in,
 					set(module_name)::out) is det.
 :- pred mq_info_get_import_status(mq_info::in, import_status::out) is det.
@@ -935,22 +1096,24 @@
 :- pred mq_info_get_report_error_flag(mq_info::in, bool::out) is det.
 :- pred mq_info_get_error_context(mq_info::in, error_context::out) is det.
 
-mq_info_get_types(mq_info(Types, _,_,_,_,_,_,_,_,_,_), Types).
-mq_info_get_insts(mq_info(_, Insts, _,_,_,_,_,_,_,_,_), Insts).
-mq_info_get_modes(mq_info(_,_, Modes, _,_,_,_,_,_,_,_), Modes).
-mq_info_get_interface_modules(mq_info(_,_,_, Modules, _,_,_,_,_,_,_), Modules).
-mq_info_get_import_status(mq_info(_,_,_,_, Status, _,_,_,_,_,_), Status).
-mq_info_get_num_errors(mq_info(_,_,_,_,_, NumErrors, _,_,_,_,_), NumErrors).
-mq_info_get_type_error_flag(mq_info(_,_,_,_,_,_, TypeErrs, _,_,_,_), TypeErrs).
-mq_info_get_mode_error_flag(mq_info(_,_,_,_,_,_,_, ModeError, _,_,_),
+mq_info_get_types(mq_info(Types, _, _,_,_,_,_,_,_,_,_,_), Types).
+mq_info_get_insts(mq_info(_, Insts, _,_,_,_,_,_,_,_,_,_), Insts).
+mq_info_get_modes(mq_info(_,_, Modes, _,_,_,_,_,_,_,_,_), Modes).
+mq_info_get_classes(mq_info(_,_,_, Classes, _,_,_,_,_,_,_,_), Classes).
+mq_info_get_interface_modules(mq_info(_,_,_,_, Modules,_,_,_,_,_,_,_), Modules).
+mq_info_get_import_status(mq_info(_,_,_,_,_, Status, _,_,_,_,_,_), Status).
+mq_info_get_num_errors(mq_info(_,_,_,_,_,_, NumErrors, _,_,_,_,_), NumErrors).
+mq_info_get_type_error_flag(mq_info(_,_,_,_,_,_,_, TypeErrs,_,_,_,_), TypeErrs).
+mq_info_get_mode_error_flag(mq_info(_,_,_,_,_,_,_,_, ModeError, _,_,_),
 						ModeError).
-mq_info_get_report_error_flag(mq_info(_,_,_,_,_,_,_,_, Report,_,_), Report).
-mq_info_get_error_context(mq_info(_,_,_,_,_,_,_,_,_, Context,_), Context).
-mq_info_get_need_qual_flag(mq_info(_,_,_,_,_,_,_,_,_,_,UseModule), UseModule).
+mq_info_get_report_error_flag(mq_info(_,_,_,_,_,_,_,_,_, Report,_,_), Report).
+mq_info_get_error_context(mq_info(_,_,_,_,_,_,_,_,_,_, Context,_), Context).
+mq_info_get_need_qual_flag(mq_info(_,_,_,_,_,_,_,_,_,_,_,UseModule), UseModule).
 
 :- pred mq_info_set_types(mq_info::in, type_id_set::in, mq_info::out) is det.
 :- pred mq_info_set_insts(mq_info::in, inst_id_set::in, mq_info::out) is det.
 :- pred mq_info_set_modes(mq_info::in, mode_id_set::in, mq_info::out) is det.
+:- pred mq_info_set_classes(mq_info::in, class_id_set::in, mq_info::out) is det.
 :- pred mq_info_set_interface_modules(mq_info::in, set(module_name)::in,
 						mq_info::out) is det.
 :- pred mq_info_set_import_status(mq_info::in, import_status::in,
@@ -960,29 +1123,31 @@
 :- pred mq_info_set_error_context(mq_info::in, error_context::in,
 						mq_info::out) is det.
 
-mq_info_set_types(mq_info(_, B,C,D,E,F,G,H,I,J,K), Types,
-		mq_info(Types, B,C,D,E,F,G,H,I,J,K)).
-mq_info_set_insts(mq_info(A,_,C,D,E,F,G,H,I,J,K), Insts,
-		mq_info(A, Insts, C,D,E,F,G,H,I,J,K)).
-mq_info_set_modes(mq_info(A,B,_,D,E,F,G,H,I,J,K), Modes,
-		mq_info(A,B, Modes, D,E,F,G,H,I,J,K)).
-mq_info_set_interface_modules(mq_info(A,B,C,_,E,F,G,H,I,J,K), Modules,
-		mq_info(A,B,C, Modules, E,F,G,H,I,J,K)).
-mq_info_set_import_status(mq_info(A,B,C,D,_,F,G,H,I,J,K), Status,
-		mq_info(A,B,C,D, Status, F,G,H,I,J,K)).
-mq_info_set_type_error_flag(mq_info(A,B,C,D,E,F, _, H,I,J,K),
-		mq_info(A,B,C,D,E,F, yes, H,I,J,K)).
-mq_info_set_mode_error_flag(mq_info(A,B,C,D,E,F,G,_,I,J,K),
-		mq_info(A,B,C,D,E,F,G, yes, I,J,K)).
-mq_info_set_error_context(mq_info(A,B,C,D,E,F,G,H,I,_,K), Context,
-		mq_info(A,B,C,D,E,F,G,H,I, Context,K)).
-mq_info_set_need_qual_flag(mq_info(A,B,C,D,E,F,G,H,I,J,_), Flag,
-		mq_info(A,B,C,D,E,F,G,H,I,J, Flag)).
+mq_info_set_types(mq_info(_, B,C,D,E,F,G,H,I,J,K,L), Types,
+		mq_info(Types, B,C,D,E,F,G,H,I,J,K,L)).
+mq_info_set_insts(mq_info(A,_,C,D,E,F,G,H,I,J,K,L), Insts,
+		mq_info(A, Insts, C,D,E,F,G,H,I,J,K,L)).
+mq_info_set_modes(mq_info(A,B,_,D,E,F,G,H,I,J,K,L), Modes,
+		mq_info(A,B, Modes, D,E,F,G,H,I,J,K,L)).
+mq_info_set_classes(mq_info(A,B,C,_,E,F,G,H,I,J,K,L), Classes,
+		mq_info(A,B, C, Classes,E,F,G,H,I,J,K,L)).
+mq_info_set_interface_modules(mq_info(A,B,C,D,_,F,G,H,I,J,K,L), Modules,
+		mq_info(A,B,C,D, Modules, F,G,H,I,J,K,L)).
+mq_info_set_import_status(mq_info(A,B,C,D,E,_,G,H,I,J,K,L), Status,
+		mq_info(A,B,C,D,E, Status, G,H,I,J,K,L)).
+mq_info_set_type_error_flag(mq_info(A,B,C,D,E,F,G, _, I,J,K,L),
+		mq_info(A,B,C,D,E,F,G, yes, I,J,K,L)).
+mq_info_set_mode_error_flag(mq_info(A,B,C,D,E,F,G,H,_,J,K,L),
+		mq_info(A,B,C,D,E,F,G,H, yes, J,K,L)).
+mq_info_set_error_context(mq_info(A,B,C,D,E,F,G,H,I,J,_,L), Context,
+		mq_info(A,B,C,D,E,F,G,H,I,J, Context,L)).
+mq_info_set_need_qual_flag(mq_info(A,B,C,D,E,F,G,H,I,J,K,_), Flag,
+		mq_info(A,B,C,D,E,F,G,H,I,J,K, Flag)).
 
 :- pred mq_info_incr_errors(mq_info::in, mq_info::out) is det.
 
-mq_info_incr_errors(mq_info(A,B,C,D,E, NumErrors0, G,H,I,J,K), 
-		mq_info(A,B,C,D,E, NumErrors, G,H,I,J,K)) :-
+mq_info_incr_errors(mq_info(A,B,C,D,E,F, NumErrors0, H,I,J,K,L), 
+		mq_info(A,B,C,D,E,F, NumErrors,H,I,J,K,L)) :-
 	NumErrors is NumErrors0 + 1.
 
 :- pred mq_info_set_error_flag(mq_info::in, id_type::in, mq_info::out) is det.
@@ -993,6 +1158,8 @@
 	mq_info_set_mode_error_flag(Info0, Info).
 mq_info_set_error_flag(Info0, inst_id, Info) :-
 	mq_info_set_mode_error_flag(Info0, Info).
+mq_info_set_error_flag(Info0, class_id, Info) :-
+	mq_info_set_type_error_flag(Info0, Info).
 
 	% If the current item is in the interface, remove its module 
 	% name from the list of modules not used in the interface.
@@ -1035,6 +1202,7 @@
 :- type type_id_set == id_set.
 :- type mode_id_set == id_set.
 :- type inst_id_set == id_set.
+:- type class_id_set == id_set.
 
 :- pred id_set_init(id_set::out) is det.
 
Index: compiler/modules.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modules.m,v
retrieving revision 1.43
diff -u -r1.43 modules.m
--- modules.m	1997/11/21 08:08:23	1.43
+++ modules.m	1997/12/02 05:29:44
@@ -8,13 +8,13 @@
 % main author: fjh
 
 % This module contains all the code for handling module imports and exports,
-% for computing module dependencies, and for generate makefile fragments to
+% for computing module dependencies, and for generating makefile fragments to
 % record those dependencies.
 %
 %
 % The interface system works as follows:
 %
-% 1. a .int3 file is written, which contains all the types, insts
+% 1. a .int3 file is written, which contains all the types, typeclasses, insts
 % and modes defined in the interface. Equivalence types, insts and
 % modes are written in full, others are written in abstract form.
 % These are module qualified as far as possible given the information
@@ -1562,7 +1562,7 @@
 
 	% Given a module interface (well, a list of items), extract the
 	% short interface part of that module, i.e. the exported
-	% type/inst/mode declarations, but not the exported pred or
+	% type/typeclass/inst/mode declarations, but not the exported pred or
 	% constructor declarations.  If the module interface imports
 	% other modules, then the short interface only needs to include
 	% those import_module declarations only if the short interface
@@ -1626,6 +1626,7 @@
 include_in_short_interface(inst_defn(_, _, _)).
 include_in_short_interface(mode_defn(_, _, _)).
 include_in_short_interface(module_defn(_, _)).
+include_in_short_interface(typeclass(_, _, _, _, _)).
 
 :- pred make_abstract_type_defn(item, item).
 :- mode make_abstract_type_defn(in, out) is semidet.
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/opt_debug.m,v
retrieving revision 1.75
diff -u -r1.75 opt_debug.m
--- opt_debug.m	1997/12/05 15:47:40	1.75
+++ opt_debug.m	1997/12/09 06:37:19
@@ -687,6 +687,8 @@
 	string__append("common", N_str, Str).
 opt_debug__dump_data_name(base_type(BaseData, TypeName, TypeArity), Str) :-
 	llds_out__make_base_type_name(BaseData, TypeName, TypeArity, Str).
+opt_debug__dump_data_name(base_typeclass_info(ClassId, InstanceNum), Str) :-
+	llds_out__make_base_typeclass_info_name(ClassId, InstanceNum, Str).
 opt_debug__dump_data_name(stack_layout(Label), Str) :-
 	opt_debug__dump_label(Label, LabelStr),
 	string__append_list(["stack_layout(", LabelStr, ")"], Str).
@@ -738,6 +740,9 @@
 opt_debug__dump_code_addr(do_det_closure, "do_det_closure").
 opt_debug__dump_code_addr(do_semidet_closure, "do_semidet_closure").
 opt_debug__dump_code_addr(do_nondet_closure, "do_nondet_closure").
+opt_debug__dump_code_addr(do_det_class_method, "do_det_class_method").
+opt_debug__dump_code_addr(do_semidet_class_method, "do_semidet_class_method").
+opt_debug__dump_code_addr(do_nondet_class_method, "do_nondet_class_method").
 opt_debug__dump_code_addr(do_not_reached, "do_not_reached").
 
 opt_debug__dump_code_addrs([], "").
Index: compiler/opt_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/opt_util.m,v
retrieving revision 1.85
diff -u -r1.85 opt_util.m
--- opt_util.m	1997/12/05 15:47:42	1.85
+++ opt_util.m	1997/12/09 06:37:20
@@ -1199,6 +1199,9 @@
 opt_util__livevals_addr(do_det_closure, yes).
 opt_util__livevals_addr(do_semidet_closure, yes).
 opt_util__livevals_addr(do_nondet_closure, yes).
+opt_util__livevals_addr(do_det_class_method, yes).
+opt_util__livevals_addr(do_semidet_class_method, yes).
+opt_util__livevals_addr(do_nondet_class_method, yes).
 opt_util__livevals_addr(do_not_reached, no).
 
 opt_util__count_temps_instr_list([], R, R, F, F).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.118
diff -u -r1.118 polymorphism.m
--- polymorphism.m	1997/10/14 09:27:53	1.118
+++ polymorphism.m	1997/12/15 06:15:47
@@ -8,9 +8,10 @@
 % main author: fjh
 
 % This module is a pass over the HLDS.
-% It does a syntactic transformation to implement polymorphism
-% using higher-order predicates, and also invokes `lambda__transform_lambda'
-% to handle lambda expressions by creating new predicates for them.
+% It does a syntactic transformation to implement polymorphism, including
+% typeclasses, using higher-order predicates, and also invokes
+% `lambda__transform_lambda' to handle lambda expressions by creating new
+% predicates for them.
 %
 %-----------------------------------------------------------------------------%
 %
@@ -40,7 +41,7 @@
 %	word 3		<compare/3 predicate for type>
 %	word 4		<base_type_layout for type>
 %	word 5		<base_type_functors for type>
-%	word 6		<string name of type>
+%	word 6		<string name of type constructor>
 %			e.g. "int" for `int', "list" for `list(T)',
 %			"map" for `map(K,V)'
 %	word 7		<string name of module>
@@ -150,6 +151,137 @@
 % single shared base_type_info.
 %
 %-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+%
+% Tranformation of code using typeclasses:
+%
+% 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.
+%
+%-----------------------------------------------------------------------------%
+%
+% Representation of a typeclass_info:
+%	The typeclass_info is represented in two parts (the typeclass_info
+%	itself, and a base_typeclass_info), in a similar fashion to the
+%	type_info being represented in two parts (the type_info and the
+%	base_type_info).
+%
+%		The base_typeclass_info contains:
+%		  * the number of constraints on the instance decl.
+%		  * pointer to method #1
+%		    ...
+%		  * pointer to method #n
+%
+%		The typeclass_info contains:
+%		  * a pointer to the base typeclass info
+%		  * typeclass info #1 for constraint on instance decl
+%		  * ...
+%		  * typeclass info #n for constraint on instance decl
+%		  * typeclass info for superclass #1
+%		    ...
+%		  * typeclass info for superclass #n
+%		  * type info #1 
+%		  * ...
+%		  * type info #n
+%
+% The base_type_info is produced statically, and there is one for each instance
+% declaration. For each constraint on the instance declaration, the
+% corresponding typeclass info is stored in the second part.
+%
+% eg. for the following program:
+%
+%	:- typeclass foo(T) where [...].
+%	:- instance  foo(int) where [...].
+%	:- instance  foo(list(T)) <= foo(T) where [...].
+%
+%	The typeclass_info for foo(int) is:
+%		The base_type_info:
+%		  * 0 (arity of the instance declaration) 
+%		  * pointer to method #1
+%		    ...
+%		  * pointer to method #n
+%
+%		The type_info:
+%		  * a pointer to the base typeclass info
+%		  * type info for int
+%
+%	The typeclass_info for foo(list(T)) is:
+%		The base_type_info:
+%		  * 1 (arity of the instance declaration)
+%		  * pointer to method #1
+%		    ...
+%		  * pointer to method #n
+%
+%		The type_info contains:
+%		  * a pointer to the base typeclass info
+%		  * typeclass info for foo(T)
+%		  * type info for list(T)
+%
+% 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.
+%
+%-----------------------------------------------------------------------------%
+%
+% Example of transformation:
+%
+% Take the following code as an example (assuming the declarations above),
+% ignoring the requirement for super-homogeneous form for clarity:
+%
+%	:- pred p(T1) <= foo(T1).
+%	:- pred q(T2, T3) <= foo(T2), bar(T3).
+%	:- pred r(T4, T5) <= foo(T4).
+%
+%	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)), 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:
+%
+%	p(TypeClassInfoT1, X) :-
+%		BaseTypeClassInfoT2 = base_typeclass_info(
+%			1,
+%			...
+%			... (The methods for the foo class from the list
+%			...  instance)
+%			...
+%			),
+%		TypeClassInfoT2 = typeclass_info(
+%			BaseClassTypeInfoT2,
+%			TypeClassInfoT1,
+%			<type_info for list(T1)>),
+%		BaseTypeClassInfoT3 = base_typeclass_info(
+%			0,
+%			...
+%			... (The methods for the bar class from the int
+%			...  instance)
+%			...
+%			),
+%		TypeClassInfoT3 = typeclass_info(
+%			BaseClassTypeInfoT3,
+%			<type_info for int>),
+%		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).
+%
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
 
 :- module polymorphism.
 :- interface.
@@ -166,10 +298,10 @@
 :- 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 (inst), hlds_out.
+:- import_module (inst), hlds_out, base_typeclass_info.
 
 :- import_module bool, int, string, list, set, map.
-:- import_module term, varset, std_util, require.
+:- import_module term, varset, std_util, require, assoc_list.
 
 %-----------------------------------------------------------------------------%
 
@@ -187,7 +319,8 @@
 	polymorphism__process_preds(PredIds0, ModuleInfo0, ModuleInfo1),
 	module_info_preds(ModuleInfo1, Preds1),
 	map__keys(Preds1, PredIds1),
-	polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo).
+	polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo2),
+	polymorphism__expand_class_method_bodies(ModuleInfo2, ModuleInfo).
 
 :- pred polymorphism__process_preds(list(pred_id), module_info, module_info).
 :- mode polymorphism__process_preds(in, in, out) is det.
@@ -284,9 +417,32 @@
 			varset,			% from the proc_info
 			map(var, type),		% from the proc_info
 			tvarset,		% from the proc_info
-			map(tvar, var),		% specifies the type_info var
+			map(tvar, type_info_locn),		
+						% specifies the location of
+						% the type_info var
 						% for each of the pred's type
 						% parameters
+
+			map(class_constraint, var),		
+						% specifies the location of
+						% the typeclass_info var
+						% for each of the pred's class
+						% constraints
+			map(class_constraint, constraint_proof),
+						% specifies why each constraint
+						% that was eliminated from the
+						% pred was able to be eliminated
+						% (this allows us to efficiently
+						% construct the dictionary)
+
+						% Note that the two maps above
+						% are separate since the second
+						% is the information calculated
+						% by typecheck.m, while the
+						% first is the information
+						% calculated here in
+						% polymorphism.m
+
 			string,			% pred name
 			module_info
 		).
@@ -300,34 +456,76 @@
 	% grab the appropriate fields from the pred_info and proc_info
 	pred_info_arg_types(PredInfo0, ArgTypeVarSet, ArgTypes),
 	pred_info_typevarset(PredInfo0, TypeVarSet0),
+	pred_info_get_class_context(PredInfo0, ClassContext),
+	pred_info_get_constraint_proofs(PredInfo0, Proofs),
 	pred_info_name(PredInfo0, PredName),
 	proc_info_headvars(ProcInfo0, HeadVars0),
 	proc_info_variables(ProcInfo0, VarSet0),
 	proc_info_vartypes(ProcInfo0, VarTypes0),
 	proc_info_goal(ProcInfo0, Goal0),
 	proc_info_argmodes(ProcInfo0, ArgModes0),
-	% insert extra head variables to hold the address of the
-	% equality predicate for each polymorphic type in the predicate's
-	% type declaration
+
+
+		% Insert extra head variables to hold the address of the
+		% type_infos and typeclass_infos.
+		% We insert one variable for each unconstrained type variable
+		% (for the type_info) and one variable for each constraint (for
+		% the typeclass_info).
 	term__vars_list(ArgTypes, HeadTypeVars0),
-	list__remove_dups(HeadTypeVars0, HeadTypeVars), % remove duplicates
-	polymorphism__make_head_vars(HeadTypeVars, ArgTypeVarSet,
-		VarSet0, VarTypes0, ExtraHeadVars, VarSet1, VarTypes1),
-	list__append(ExtraHeadVars, HeadVars0, HeadVars),
-	list__length(ExtraHeadVars, NumExtraVars),
+		% Make a fresh variable for each class constraint, returning
+		% a list of variables that appear in the constraints, along
+		% with the location of the type infos for them.
+	polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo0,
+		VarSet0, VarTypes0, ExtraHeadTypeclassInfoVars,
+		TypeClassInfoMap, ConstrainedTVars, 
+		VarSet1, VarTypes1),
+
+	list__delete_elems(HeadTypeVars0, ConstrainedTVars, 
+		UnconstrainedTVars0),
+	list__remove_dups(UnconstrainedTVars0, UnconstrainedTVars), 
+
+	polymorphism__make_head_vars(UnconstrainedTVars, ArgTypeVarSet,
+		VarSet1, VarTypes1, ExtraHeadTypeInfoVars, VarSet2, VarTypes2),
+
+		% First the type_infos, then the typeclass_infos, 
+		% but we have to do it in reverse because we're appending...
+	list__append(ExtraHeadTypeclassInfoVars, HeadVars0, HeadVars1),
+	list__append(ExtraHeadTypeInfoVars, HeadVars1, HeadVars),
+
+		% Work out the total number of new vars
+	list__length(ExtraHeadTypeInfoVars, NumExtraVars0),
+	list__length(ExtraHeadTypeclassInfoVars, NumExtraVars1),
+	NumExtraVars is NumExtraVars1 + NumExtraVars0,
+
 	list__duplicate(NumExtraVars, user_defined_mode(
 		qualified("mercury_builtin", "in"), []), ExtraModes),
 	list__append(ExtraModes, ArgModes0, ArgModes),
 
+		% Make a map of the locations of the unconstrained typeinfos
+	AddLocn = lambda([TVarAndVar::in, TIM0::in, TIM::out] is det,
+		(
+			TVarAndVar = TVar - TheVar,
+			map__det_insert(TIM0, TVar, type_info(TheVar), TIM)
+		)),
+	assoc_list__from_corresponding_lists(UnconstrainedTVars,
+		ExtraHeadTypeInfoVars, TVarsAndVars),
+	list__foldl(AddLocn, TVarsAndVars, TypeClassInfoMap, TypeInfoMap1),
+
+
+		% Make a map of the locations of the typeclass_infos
+	map__from_corresponding_lists(ClassContext, ExtraHeadTypeclassInfoVars,
+				TypeclassInfoLocations0),
+
+	Info0 = poly_info(VarSet2, VarTypes2, TypeVarSet0,
+				TypeInfoMap1, TypeclassInfoLocations0,
+				Proofs, PredName, ModuleInfo0),
+
 	% process any polymorphic calls inside the goal
-	map__from_corresponding_lists(HeadTypeVars, ExtraHeadVars,
-				TypeInfoMap0),
-	Info0 = poly_info(VarSet1, VarTypes1, TypeVarSet0,
-				TypeInfoMap0, PredName, ModuleInfo0),
 	polymorphism__process_goal(Goal0, Goal1, Info0, Info1),
 	polymorphism__fixup_quantification(Goal1, Goal, Info1, Info),
-	Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap, _PredName,
-		ModuleInfo),
+	Info = poly_info(VarSet, VarTypes, TypeVarSet,
+				TypeInfoMap, TypeclassInfoLocations,
+				_Proofs, _PredName, ModuleInfo),
 
 	% set the new values of the fields in proc_info and pred_info
 	proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
@@ -335,7 +533,9 @@
 	proc_info_set_varset(ProcInfo2, VarSet, ProcInfo3),
 	proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo4),
 	proc_info_set_argmodes(ProcInfo4, ArgModes, ProcInfo5),
-	proc_info_set_typeinfo_varmap(ProcInfo5, TypeInfoMap, ProcInfo),
+	proc_info_set_typeinfo_varmap(ProcInfo5, TypeInfoMap, ProcInfo6),
+	proc_info_set_typeclass_info_varmap(ProcInfo6, TypeclassInfoLocations,
+		ProcInfo),
 	pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
 
 :- pred polymorphism__process_goal(hlds_goal, hlds_goal,
@@ -357,6 +557,11 @@
 		GoalInfo, higher_order_call(A, B, C, D, E, F) - GoalInfo)
 		--> [].
 
+	% The same goes for class method calls
+polymorphism__process_goal_expr(class_method_call(A, B, C, D, E, F),
+		GoalInfo, class_method_call(A, B, C, D, E, F) - GoalInfo)
+		--> [].
+
 polymorphism__process_goal_expr(call(PredId0, ProcId0, ArgVars0,
 		Builtin, Context, Name0), GoalInfo, Goal) -->
 	% Check for a call to a special predicate like compare/3
@@ -368,7 +573,7 @@
 		{ list__length(ArgVars0, Arity) },
 		{ special_pred_name_arity(SpecialPredId, PredName0,
 						MangledPredName, Arity) },
-		=(poly_info(_, VarTypes, _, _TypeInfoMap, _PN, ModuleInfo)),
+		=(poly_info(_, VarTypes, _, _, _, _, _, ModuleInfo)),
 		{ special_pred_get_type(MangledPredName, ArgVars0, MainVar) },
 		{ map__lookup(VarTypes, MainVar, Type) },
 		{ Type \= term__variable(_) },
@@ -404,7 +609,7 @@
 		{ Unification = complicated_unify(UniMode, CanFail) },
 		{ Y = var(YVar) }
 	->
-		=(poly_info(_, VarTypes, _, TypeInfoMap, _PName, ModuleInfo)),
+		=(poly_info(_, VarTypes, _, TypeInfoMap, _, _, _, ModuleInfo)),
 		{ map__lookup(VarTypes, XVar, Type) },
 		( { Type = term__variable(TypeVar) } ->
 			% Convert polymorphic unifications into calls to
@@ -428,14 +633,38 @@
 			%     polymorphically typed variables in partially
 			%     instantiated mode") if it isn't
 			{ hlds_pred__in_in_unification_proc_id(ProcId) },
-			{ map__lookup(TypeInfoMap, TypeVar, TypeInfoVar) },
+			{ map__lookup(TypeInfoMap, TypeVar, TypeInfoLocn) },
 			{ SymName = unqualified("unify") },
-			{ ArgVars = [TypeInfoVar, XVar, YVar] },
 			{ code_util__builtin_state(ModuleInfo, PredId, ProcId,
 				BuiltinState) },
 			{ CallContext = call_unify_context(XVar, Y, Context) },
-			{ Goal = call(PredId, ProcId, ArgVars, BuiltinState,
-				yes(CallContext), SymName) - GoalInfo }
+			(
+					% If the typeinfo is available in a
+					% variable, just use it
+				{ TypeInfoLocn = type_info(TypeInfoVar) },
+				{ ArgVars = [TypeInfoVar, XVar, YVar] },
+				{ Goal = call(PredId, ProcId, ArgVars,
+					BuiltinState, yes(CallContext), SymName)
+					- GoalInfo }
+			;
+					% If the typeinfo is in a
+					% typeclass_info, first extract it, 
+					% then use it
+				{ TypeInfoLocn =
+					typeclass_info(TypeClassInfoVar,
+					Index) },
+				extract_type_info(Type, TypeVar,
+					TypeClassInfoVar, Index,
+					Goals, TypeInfoVar),
+
+				{ ArgVars = [TypeInfoVar, XVar, YVar] },
+				{ Call = call(PredId, ProcId, ArgVars,
+					BuiltinState, yes(CallContext), SymName)
+					- GoalInfo },
+
+				{ list__append(Goals, [Call], TheGoals) },
+				{ Goal = conj(TheGoals) - GoalInfo }
+			)
 
 		; { type_is_higher_order(Type, _, _) } ->
 			{ SymName = unqualified("builtin_unify_pred") },
@@ -537,7 +766,7 @@
 	% so that the c_code can refer to the type_info variable
 	% for type T as `TypeInfo_for_T'.
 	%
-	=(poly_info(_, _, _, _, _, ModuleInfo)),
+	=(poly_info(_, _, _, _, _, _, _, ModuleInfo)),
 	{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
 	{ pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes) },
 	{ term__vars_list(PredArgTypes, PredTypeVars0) },
@@ -612,14 +841,17 @@
 
 polymorphism__process_call(PredId, _ProcId, ArgVars0, ArgVars,
 				ExtraVars, ExtraGoals, Info0, Info) :-
-	Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0,
-				TypeInfoMap0, PredName, ModuleInfo),
+
+	Info0 = poly_info(A, VarTypes, TypeVarSet0, D, E, F, G, ModuleInfo),
+
 	module_info_pred_info(ModuleInfo, PredId, PredInfo),
 	pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes0),
+	pred_info_get_class_context(PredInfo, PredClassContext0),
 		% rename apart
 		% (this merge might be a performance bottleneck?)
-	varset__merge(TypeVarSet0, PredTypeVarSet, PredArgTypes0,
-			TypeVarSet, PredArgTypes),
+	varset__merge_subst(TypeVarSet0, PredTypeVarSet, TypeVarSet, Subst),
+	term__apply_substitution_to_list(PredArgTypes0, Subst,
+		PredArgTypes),
 	term__vars_list(PredArgTypes, PredTypeVars0),
 	( PredTypeVars0 = [] ->
 		% optimize for common case of non-polymorphic call
@@ -628,24 +860,47 @@
 		ExtraVars = [],
 		Info = Info0
 	;
-		list__remove_dups(PredTypeVars0, PredTypeVars),
-		map__apply_to_list(ArgVars0, VarTypes0, ActualArgTypes),
+		list__remove_dups(PredTypeVars0, PredTypeVars1),
+		map__apply_to_list(ArgVars0, VarTypes, ActualArgTypes),
 		( type_list_subsumes(PredArgTypes, ActualArgTypes,
 				TypeSubst1) ->
 			TypeSubst = TypeSubst1
 		;
 		error("polymorphism__process_goal_expr: type unification failed")
 		),
+
+
+		apply_subst_to_constraints(Subst, PredClassContext0,
+			PredClassContext),
+
+		Info1 = poly_info(A, VarTypes, TypeVarSet, D, E, F, G,
+			ModuleInfo),
+
+			% Make the typeclass_infos for the call, and return
+			% a list of which variables were constrained by the
+			% context
+		polymorphism__make_typeclass_info_vars(PredClassContext,
+			Subst, TypeSubst, ExtraTypeClassVars, 
+			ExtraTypeClassGoals, ConstrainedVars, Info1, Info2),
+
+			% No need to make typeinfos for the constrained vars
+		list__delete_elems(PredTypeVars1, ConstrainedVars,
+			PredTypeVars),
+
 		term__var_list_to_term_list(PredTypeVars, PredTypes0),
 		term__apply_rec_substitution_to_list(PredTypes0, TypeSubst,
 			PredTypes),
-		polymorphism__make_vars(PredTypes, ModuleInfo, TypeInfoMap0,
-				VarSet0, VarTypes0,
-				ExtraVars, TypeInfoMap, ExtraGoals, VarSet, 
-				VarTypes),
-		list__append(ExtraVars, ArgVars0, ArgVars),
-		Info = poly_info(VarSet, VarTypes, TypeVarSet,
-				TypeInfoMap, PredName, ModuleInfo)
+
+		polymorphism__make_type_info_vars(PredTypes,
+			ExtraTypeInfoVars, ExtraTypeInfoGoals,
+			Info2, Info),
+		list__append(ExtraTypeClassVars, ArgVars0, ArgVars1),
+		list__append(ExtraTypeInfoVars, ArgVars1, ArgVars),
+		list__append(ExtraTypeClassGoals, ExtraTypeInfoGoals,
+			ExtraGoals),
+		list__append(ExtraTypeClassVars, ExtraTypeInfoVars,
+			ExtraVars)
+
 	).
 
 :- pred polymorphism__fixup_quantification(hlds_goal, hlds_goal,
@@ -661,31 +916,39 @@
 
 polymorphism__fixup_quantification(Goal0, Goal, Info0, Info) :-
 	Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeVarMap,
-			PredName, ModuleInfo),
+			TypeClassVarMap, Proofs, PredName, ModuleInfo),
 	( map__is_empty(TypeVarMap) ->
 		Info = Info0,
 		Goal = Goal0
 	;
 		%
-		% A type-info variable may be non-local to a goal if any of
+		% A type-info variable may be non-local to a goal if any of 
 		% the ordinary non-local variables for that goal are
 		% polymorphically typed with a type that depends on that
 		% type-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),
 		set__to_sorted_list(NonLocals, NonLocalsList),
 		map__apply_to_list(NonLocalsList, VarTypes0, NonLocalsTypes),
 		term__vars_list(NonLocalsTypes, NonLocalTypeVars),
-		solutions_set(lambda([TypeInfoVar::out] is nondet, (
-				list__member(Var, NonLocalTypeVars),
-				map__search(TypeVarMap, Var, TypeInfoVar)
+			% Find all the type-infos and typeclass-infos that are
+			% non-local
+		solutions_set(lambda([Var::out] is nondet, (
+				list__member(TheVar, NonLocalTypeVars),
+				map__search(TypeVarMap, TheVar, Location),
+				type_info_locn_var(Location, Var)
 			)), NewOutsideVars),
 		set__union(NewOutsideVars, NonLocals, OutsideVars),
 		implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
 			OutsideVars, Goal, VarSet, VarTypes, _Warnings),
 		Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarMap,
-				PredName, ModuleInfo)
+				TypeClassVarMap, Proofs, PredName, ModuleInfo)
 	).
 
 :- pred polymorphism__process_lambda(pred_or_func, list(var),
@@ -697,50 +960,484 @@
 polymorphism__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals,
 		LambdaGoal, Unification0, Functor, Unification,
 		PolyInfo0, PolyInfo) :-
-	PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap, PredName,
-			ModuleInfo0),
+	PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap, 
+			TCVarMap, Proofs, PredName, ModuleInfo0),
+
+		% 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,
-		TVarSet, TVarMap, ModuleInfo0, Functor,
+		Constraints, TVarSet, TVarMap, TCVarMap, ModuleInfo0, Functor,
 		Unification, ModuleInfo),
-	PolyInfo = poly_info(VarSet, VarTypes, TVarSet, TVarMap, PredName,
-			ModuleInfo).
+	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
+% typeclass_info for those constraints, and create a list of goals to 
+% initialize those typeclass_info variables to the appropriate 
+% typeclass_info structures for the constraints.
+
+:- pred polymorphism__make_typeclass_info_vars(list(class_constraint),
+	substitution, tsubst, list(var), list(hlds_goal), list(var),
+	poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_vars(in, in, in, out, out, out, 
+	in, out) is det.
+
+polymorphism__make_typeclass_info_vars(PredClassContext, Subst, TypeSubst, 
+		ExtraVars, ExtraGoals, ConstrainedVars, Info0, Info) :-
+
+		% initialise the accumulators
+	ExtraVars0 = [],
+	ExtraGoals0 = [],
+	ConstrainedVars0 = [],
+
+		% do the work
+	polymorphism__make_typeclass_info_vars_2(PredClassContext, 
+		Subst, TypeSubst, 
+		ExtraVars0, ExtraVars1, 
+		ExtraGoals0, ExtraGoals1,
+		ConstrainedVars0, ConstrainedVars, 
+		Info0, Info),
+	
+		% We build up the vars and goals in reverse order
+	list__reverse(ExtraVars1, ExtraVars),
+	list__reverse(ExtraGoals1, ExtraGoals).
+
+% Accumulator version of the above.
+:- pred polymorphism__make_typeclass_info_vars_2(list(class_constraint),
+	substitution, tsubst, 
+	list(var), list(var), 
+	list(hlds_goal), list(hlds_goal), 
+	list(var), list(var),
+	poly_info, poly_info).
+:- mode polymorphism__make_typeclass_info_vars_2(in, in, in, in, out, in, out,
+	in, out, in, out) is det.
+
+polymorphism__make_typeclass_info_vars_2([], _Subst, _TypeSubst,
+		ExtraVars, ExtraVars, 
+		ExtraGoals, ExtraGoals, 
+		ConstrainedVars, ConstrainedVars,
+		Info, Info).
+polymorphism__make_typeclass_info_vars_2([C|Cs], Subst, TypeSubst,
+		ExtraVars0, ExtraVars, 
+		ExtraGoals0, ExtraGoals, 
+		ConstrainedVars0, ConstrainedVars,
+		Info0, Info) :-
+	polymorphism__make_typeclass_info_var(C, Subst, TypeSubst,
+			ExtraGoals0, ExtraGoals1, 
+			ConstrainedVars0, ConstrainedVars1, Info0, Info1,
+			ExtraVar),
+	polymorphism__make_typeclass_info_vars_2(Cs, Subst, TypeSubst,
+			[ExtraVar|ExtraVars0], ExtraVars, 
+			ExtraGoals1, ExtraGoals, 
+			ConstrainedVars1, ConstrainedVars,
+			Info1, Info).
+
+:- pred polymorphism__make_typeclass_info_var(class_constraint,
+	substitution, tsubst,
+	list(hlds_goal), list(hlds_goal), 
+	list(var), list(var),
+	poly_info, poly_info,
+	var). 
+:- mode polymorphism__make_typeclass_info_var(in, in, in, in, out, in, out, 
+	in, out, out) is det.
+
+polymorphism__make_typeclass_info_var(Constraint, Subst, TypeSubst,
+		ExtraGoals0, ExtraGoals, 
+		ConstrainedVars0, ConstrainedVars, 
+		Info0, Info, Var) :-
+	Constraint = constraint(ClassName, NewConstrainedTypes),
+	list__length(NewConstrainedTypes, ClassArity),
+	ClassId = class_id(ClassName, ClassArity),
+	term__vars_list(NewConstrainedTypes, NewConstrainedVars),
+	list__append(NewConstrainedVars, ConstrainedVars0, ConstrainedVars),
+	term__apply_rec_substitution_to_list(NewConstrainedTypes, TypeSubst, 
+		ConstrainedTypes),
+	NewC = constraint(ClassName, ConstrainedTypes),
+
+	Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0, TypeInfoMap0, 
+		TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
+
+	(
+		map__search(TypeClassInfoMap0, NewC, Location)
+	->
+			% We already have a typeclass_info for this constraint
+		ExtraGoals = ExtraGoals0,
+		Var = Location,
+		Info = Info0
+	;
+			% We don't have the typeclass_info as a parameter to
+			% the pred, so we must be able to create it from
+			% somewhere else
+
+			% Work out how to make it
+		map__lookup(Proofs, NewC, Proof),
+		(
+				% We have to construct the typeclass_info
+				% using an instance declaration
+			Proof = apply_instance(InstanceDefn, InstanceNum),
+
+				% The subst has already been applied to these
+				% constraints in typecheck.m
+			InstanceDefn = hlds_instance_defn(_,
+				InstanceConstraints, _, _, _, _, _),
+
+				% Make the type_infos for the types that are
+				% constrained by this. These are packaged in
+				% the typeclass_info
+			polymorphism__make_type_info_vars(ConstrainedTypes,
+				InstanceExtraTypeInfoVars, TypeInfoGoals, 
+				Info0, Info1),
+
+				% Make the typeclass_infos for the constraints
+				% from the context of the instance decl.
+			polymorphism__make_typeclass_info_vars_2(
+				InstanceConstraints,
+				Subst, TypeSubst, 
+				[], InstanceExtraTypeClassInfoVars, 
+				ExtraGoals0, ExtraGoals1, 
+				[], _, Info1, Info2),
+
+			polymorphism__construct_typeclass_info(
+				InstanceExtraTypeInfoVars, 
+				InstanceExtraTypeClassInfoVars, 
+				ClassId, InstanceNum, Var, NewGoals, 
+				Info2, Info),
+
+				% Oh, yuck. The type_info goals have already
+				% been reversed, so lets reverse them back.
+			list__reverse(TypeInfoGoals, RevTypeInfoGoals),
+
+			list__append(ExtraGoals1, RevTypeInfoGoals,
+				ExtraGoals2),
+			list__append(NewGoals, ExtraGoals2, ExtraGoals)
+		;
+				% We have to extract the typeclass_info from
+				% another one
+			Proof = superclass(SubClassConstraint0),
+
+				% First create a variable to hold the new
+				% typeclass_info 
+			unqualify_name(ClassName, ClassNameString),
+			polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
+				ClassNameString, Var, VarSet1, VarTypes1),
+
+				% Then work out where to extract it from
+			SubClassConstraint0 = 
+				constraint(SubClassName, SubClassTypes0),
+			term__apply_substitution_to_list(SubClassTypes0, Subst,
+				SubClassTypes),
+			SubClassConstraint = 
+				constraint(SubClassName, SubClassTypes),
+			list__length(SubClassTypes, SubClassArity),
+			SubClassId = class_id(SubClassName, SubClassArity),
+
+			Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet0, 
+				TypeInfoMap0, TypeClassInfoMap0, Proofs, 
+				PredName, ModuleInfo),
+
+				% Make the typeclass_info for the subclass
+			polymorphism__make_typeclass_info_var(
+				SubClassConstraint,
+				Subst, TypeSubst, 
+				ExtraGoals0, ExtraGoals1, 
+				[], _,
+				Info1, Info2,
+				SubClassVar), 
+
+				% Look up the definition of the subclass
+			module_info_classes(ModuleInfo, ClassTable),
+			map__lookup(ClassTable, SubClassId, SubClassDefn), 
+			SubClassDefn = hlds_class_defn(SuperClasses0,
+				SubClassVars, _, _, _),
+
+				% Work out which superclass typeclass_info to
+				% take
+			ToTerm = lambda([TheVar::in, TheTerm::out] is det,
+				(
+					TheTerm = term__variable(TheVar)
+				)),
+			list__map(ToTerm, SubClassVars, SubClassVarTerms),
+			(
+				type_list_subsumes(SubClassVarTerms,
+					SubClassTypes, SubTypeSubst0)
+			->
+				SubTypeSubst0 = SubTypeSubst
+			;
+				error("polymorphism__make_typeclass_info_var")
+			),
+			apply_rec_subst_to_constraints(SubTypeSubst,
+				SuperClasses0, SuperClasses),
+			(
+				list__nth_member_search(SuperClasses,
+					Constraint, SuperClassIndex0)
+			->
+				SuperClassIndex0 = SuperClassIndex
+			;
+					% We shouldn't have got this far if
+					% the constraints were not satifsied
+				error("polymorphism.m: constraint not in constraint list")
+			),
+
+			Info2 = poly_info(VarSet2, VarTypes2, TypeVarSet2, 
+				TypeInfoMap2, TypeClassInfoMap2, Proofs2, 
+				PredName2, ModuleInfo2),
+
+			polymorphism__make_count_var(SuperClassIndex, VarSet2,
+				VarTypes2, IndexVar, IndexGoal, VarSet,
+				VarTypes),
+
+			Info = poly_info(VarSet, VarTypes, TypeVarSet2, 
+				TypeInfoMap2, TypeClassInfoMap2, Proofs2, 
+				PredName2, ModuleInfo2),
+
+				% We extract the superclass typeclass_info by
+				% inserting a call to
+				% superclass_from_typeclass_info in
+				% mercury_builtin.
+
+				% Make the goal for the call
+			varset__init(Empty),
+			term__context_init(EmptyContext),
+			ExtractSuperClass = 
+				qualified("mercury_builtin", 
+					  "superclass_from_typeclass_info"),
+			TypeClassInfoTerm = term__functor(
+					term__atom("typeclass_info"), [],
+					EmptyContext),
+			IntTerm = term__functor(
+					term__atom("int"), [],
+					EmptyContext),
+			get_pred_id_and_proc_id(ExtractSuperClass, predicate, 
+				Empty, 
+				[TypeClassInfoTerm, IntTerm, TypeClassInfoTerm],
+				ModuleInfo, PredId, ProcId),
+			Call = call(PredId, ProcId, 
+				[SubClassVar, IndexVar, Var],
+				not_builtin, no, 
+				ExtractSuperClass
+				),
+
+				% Make the goal info for the call
+			set__list_to_set([SubClassVar, IndexVar, Var],
+				NonLocals),
+			instmap_delta_from_assoc_list(
+				[Var - ground(shared, no)],
+				InstmapDelta),
+			goal_info_init(NonLocals, InstmapDelta, det, GoalInfo),
+
+				% Put them together
+			SuperClassGoal = Call - GoalInfo,
+
+				% Add it to the accumulator
+			ExtraGoals = [SuperClassGoal,IndexGoal|ExtraGoals1]
+		)
+	).
+
+:- pred polymorphism__construct_typeclass_info(list(var), list(var), class_id, 
+	int, var, list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__construct_typeclass_info(in, in, in, in, out, out, 
+	in, out) is det.
+
+polymorphism__construct_typeclass_info(ArgTypeInfoVars, ArgTypeClassInfoVars,
+		ClassId, InstanceNum, NewVar, NewGoals, Info0, Info) :-
+
+	Info0 = poly_info(_, _, _, _, _, _, _, ModuleInfo),
+
+	module_info_instances(ModuleInfo, InstanceTable),
+	map__lookup(InstanceTable, ClassId, InstanceList),
+	list__index1_det(InstanceList, InstanceNum, InstanceDefn),
+	InstanceDefn = hlds_instance_defn(_, _, InstanceTypes, _, _, _, 
+		SuperClassProofs),
+
+	module_info_classes(ModuleInfo, ClassTable),
+	map__lookup(ClassTable, ClassId, ClassDefn),
+
+	polymorphism__get_arg_superclass_vars(ClassDefn, InstanceTypes,
+		SuperClassProofs, ArgSuperClassVars, SuperClassGoals, 
+		Info0, Info1),
+
+	Info1 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap, TCVarMap, 
+			Proofs, PredName, _),
+
+		% lay out the argument variables as expected in the
+		% typeclass_info
+	list__append(ArgTypeClassInfoVars, ArgSuperClassVars, ArgVars0),
+	list__append(ArgVars0, ArgTypeInfoVars, ArgVars),
+
+	ClassId = class_id(ClassName, _Arity),
+
+	unqualify_name(ClassName, ClassNameString),
+	polymorphism__new_typeclass_info_var(VarSet0, VarTypes0,
+		ClassNameString, BaseVar, VarSet1, VarTypes1),
+
+	base_typeclass_info__make_instance_string(InstanceTypes,
+		InstanceString),
+
+		% XXX I don't think we actually need to carry this string
+		% around.
+	ModuleName = "some bogus string",
+	ConsId = base_typeclass_info_const(ModuleName, ClassId, InstanceString),
+	BaseTypeClassInfoTerm = functor(ConsId, []),
+
+		% create the construction unification to initialize the variable
+	BaseUnification = construct(BaseVar, ConsId, [], []),
+	BaseUnifyMode = (free -> ground(shared, no)) -
+			(ground(shared, no) -> ground(shared, no)),
+	BaseUnifyContext = unify_context(explicit, []),
+		% XXX the UnifyContext is wrong
+	BaseUnify = unify(BaseVar, BaseTypeClassInfoTerm, BaseUnifyMode,
+			BaseUnification, BaseUnifyContext),
+
+		% create a goal_info for the unification
+	set__list_to_set([BaseVar], NonLocals),
+	instmap_delta_from_assoc_list([BaseVar - ground(shared, no)],
+		InstmapDelta),
+	goal_info_init(NonLocals, InstmapDelta, det, BaseGoalInfo),
+
+	BaseGoal = BaseUnify - BaseGoalInfo,
+
+		% build a unification to add the argvars to the
+		% base_typeclass_info
+	NewConsId = cons(qualified("mercury_builtin", "typeclass_info"), 1),
+	NewArgVars = [BaseVar|ArgVars],
+	TypeClassInfoTerm = functor(NewConsId, NewArgVars),
+
+		% introduce a new variable
+	polymorphism__new_typeclass_info_var(VarSet1, VarTypes1,
+		ClassNameString, NewVar, VarSet, VarTypes),
+
+		% create the construction unification to initialize the
+		% variable
+	UniMode = (free - ground(shared, no) ->
+		   ground(shared, no) - ground(shared, no)),
+	list__length(NewArgVars, NumArgVars),
+	list__duplicate(NumArgVars, UniMode, UniModes),
+	Unification = construct(NewVar, NewConsId, NewArgVars,
+		UniModes),
+	UnifyMode = (free -> ground(shared, no)) -
+			(ground(shared, no) -> ground(shared, no)),
+	UnifyContext = unify_context(explicit, []),
+		% XXX the UnifyContext is wrong
+	Unify = unify(NewVar, TypeClassInfoTerm, UnifyMode,
+			Unification, UnifyContext),
+
+	% create a goal_info for the unification
+	goal_info_init(GoalInfo0),
+	set__list_to_set([NewVar | NewArgVars], TheNonLocals),
+	goal_info_set_nonlocals(GoalInfo0, TheNonLocals, GoalInfo1),
+	list__duplicate(NumArgVars, ground(shared, no), ArgInsts),
+		% note that we could perhaps be more accurate than
+		% `ground(shared)', but it shouldn't make any
+		% difference.
+	InstConsId = cons( qualified("mercury_builtin", "typeclass_info"), 
+		NumArgVars),
+	instmap_delta_from_assoc_list(
+		[NewVar - 
+			bound(unique, [functor(InstConsId, ArgInsts)])],
+		InstMapDelta),
+	goal_info_set_instmap_delta(GoalInfo1, InstMapDelta, GoalInfo2),
+	goal_info_set_determinism(GoalInfo2, det, GoalInfo),
+
+	TypeClassInfoGoal = Unify - GoalInfo,
+	NewGoals0 = [TypeClassInfoGoal, BaseGoal],
+	list__append(SuperClassGoals, NewGoals0, NewGoals),
+	Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap, 
+			TCVarMap, Proofs, PredName, ModuleInfo).
+
+%---------------------------------------------------------------------------%
+
+:- pred polymorphism__get_arg_superclass_vars(hlds_class_defn, list(type),
+	map(class_constraint, constraint_proof), list(var), list(hlds_goal),
+	poly_info, poly_info).
+:- mode polymorphism__get_arg_superclass_vars(in, in, in, out, out, 
+	in, out) is det.
+
+polymorphism__get_arg_superclass_vars(ClassDefn, InstanceTypes, 
+		SuperClassProofs, NewVars, NewGoals, Info0, Info) :-
+
+	Info0 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap0, TCVarMap0, 
+			Proofs, PredName, ModuleInfo),
+
+	ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet, _),
+
+	map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
+	varset__merge_subst(VarSet0, ClassVarSet, VarSet1, Subst),
+
+	Info1 = poly_info(VarSet1, VarTypes0, TVarSet, TVarMap0, TCVarMap0, 
+			SuperClassProofs, PredName, ModuleInfo),
+
+	polymorphism__make_superclasses_from_proofs(SuperClasses, Subst,
+		TypeSubst, [], NewGoals, Info1, Info2, [], NewVars),
+
+	Info2 = poly_info(VarSet, VarTypes, _, TVarMap, TCVarMap, _, _, _),
+
+	Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap, TCVarMap, 
+			Proofs, PredName, ModuleInfo) .  
+
+
+:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint), 
+	substitution, tsubst, list(hlds_goal), list(hlds_goal), 
+	poly_info, poly_info, list(var), list(var)).
+:- mode polymorphism__make_superclasses_from_proofs(in, in, in, in, out, 
+	in, out, in, out) is det.
+
+polymorphism__make_superclasses_from_proofs([], _, _, 
+		Goals, Goals, Info, Info, Vars, Vars).
+polymorphism__make_superclasses_from_proofs([C|Cs], Subst, TypeSubst, 
+		Goals0, Goals, Info0, Info, Vars0, [Var|Vars]) :-
+	polymorphism__make_superclasses_from_proofs(Cs, Subst, TypeSubst,
+		Goals0, Goals1, Info0, Info1, Vars0, Vars),
+	polymorphism__make_typeclass_info_var(C, Subst, TypeSubst,
+		Goals1, Goals, [], _, Info1, Info, Var).
 
 %---------------------------------------------------------------------------%
 
 % Given a list of types, create a list of variables to hold the type_info
 % for those types, and create a list of goals to initialize those type_info
 % variables to the appropriate type_info structures for the types.
-% Update the varset and vartypes accordingly.
-
-:- pred polymorphism__make_vars(list(type), module_info, map(tvar, var),
-	varset, map(var, type), list(var), map(tvar, var), list(hlds_goal),
-	varset, map(var, type)).
-:- mode polymorphism__make_vars(in, in, in, in, in, out, out, out, out, 
-	out) is det.
 
-polymorphism__make_vars([], _, TypeInfoMap, VarSet, VarTypes, [], TypeInfoMap,
-		[], VarSet, VarTypes).
-polymorphism__make_vars([Type | Types], ModuleInfo, TypeInfoMap0,
-		VarSet0, VarTypes0, ExtraVars, TypeInfoMap, ExtraGoals, 
-		VarSet, VarTypes) :-
-	polymorphism__make_var(Type, ModuleInfo, TypeInfoMap0,
-		VarSet0, VarTypes0, Var, TypeInfoMap1, ExtraGoals1, VarSet1,
-		VarTypes1),
-	polymorphism__make_vars(Types, ModuleInfo, TypeInfoMap1,
-		VarSet1, VarTypes1, ExtraVars2, TypeInfoMap, ExtraGoals2, 
-		VarSet, VarTypes),
+:- pred polymorphism__make_type_info_vars(list(type),
+	list(var), list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__make_type_info_vars(in, out, out, in, out) is det.
+
+polymorphism__make_type_info_vars([], [], [], Info, Info).
+polymorphism__make_type_info_vars([Type | Types], 
+		ExtraVars, ExtraGoals, Info0, Info) :-
+	polymorphism__make_type_info_var(Type, 
+		Var, ExtraGoals1, Info0, Info1),
+	polymorphism__make_type_info_vars(Types, 
+		ExtraVars2, ExtraGoals2, Info1, Info),
 	ExtraVars = [Var | ExtraVars2],
 	list__append(ExtraGoals1, ExtraGoals2, ExtraGoals).
 
-:- pred polymorphism__make_var(type, module_info, map(tvar, var), 
-	varset, map(var, type), var, map(tvar, var), list(hlds_goal),
-	varset, map(var, type)).
-:- mode polymorphism__make_var(in, in, in, in, in, out, out, out, out, out) 
-	is det.
+:- pred polymorphism__make_type_info_var(type, var, list(hlds_goal), 
+	poly_info, poly_info).
+:- mode polymorphism__make_type_info_var(in, out, out, in, out) is det.
 
-polymorphism__make_var(Type, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0, 
-		Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes) :-
+polymorphism__make_type_info_var(Type, Var, ExtraGoals, Info0, Info) :-
 	(
 		type_is_higher_order(Type, PredOrFunc, TypeArgs)
 	->
@@ -757,8 +1454,7 @@
 		hlds_out__pred_or_func_to_str(PredOrFunc, PredOrFuncStr),
 		TypeId = unqualified(PredOrFuncStr) - 0,
 		polymorphism__construct_type_info(Type, TypeId, TypeArgs,
-			yes, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
-			Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes)
+			yes, Var, ExtraGoals, Info0, Info)
 	;
 		type_to_type_id(Type, TypeId, TypeArgs)
 	->
@@ -768,11 +1464,11 @@
 		% at the top of the module.
 
 		polymorphism__construct_type_info(Type, TypeId, TypeArgs,
-			no, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
-			Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes)
+			no, Var, ExtraGoals, Info0, Info)
 	;
 		Type = term__variable(TypeVar1),
-		map__search(TypeInfoMap0, TypeVar1, TypeInfoVar)
+		Info0 = poly_info(_, _, _, TypeInfoMap0, _, _, _, _),
+		map__search(TypeInfoMap0, TypeVar1, TypeInfoLocn)
 	->
 		% This occurs for code where a predicate calls a polymorphic
 		% predicate with a bound but unknown value of the type variable.
@@ -790,11 +1486,20 @@
 		%
 		%	p(TypeInfo, X) :- q(TypeInfo, X).
 
-		Var = TypeInfoVar,
-		ExtraGoals = [],
-		VarSet = VarSet0,
-		VarTypes = VarTypes0,
-		TypeInfoMap = TypeInfoMap0
+		(
+				% If the typeinfo is available in a variable,
+				% just use it
+			TypeInfoLocn = type_info(TypeInfoVar),
+			Var = TypeInfoVar,
+			ExtraGoals = [],
+			Info = Info0
+		;
+				% If the typeinfo is in a typeclass_info, first
+				% extract it, then use it
+			TypeInfoLocn = typeclass_info(TypeClassInfoVar, Index),
+			extract_type_info(Type, TypeVar1, TypeClassInfoVar,
+				Index, ExtraGoals, Var, Info0, Info)
+		)
 	;
 		Type = term__variable(TypeVar1)
 	->
@@ -829,27 +1534,28 @@
 		% variable to zero
 		TypeId = unqualified("void") - 0,
 		polymorphism__construct_type_info(Type, TypeId, [],
-			no, ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
-			Var, TypeInfoMap1, ExtraGoals, VarSet, VarTypes),
-		map__det_insert(TypeInfoMap1, TypeVar1, Var, TypeInfoMap)
+			no, Var, ExtraGoals, Info0, Info1),
+		Info1 = poly_info(A, B, C, TypeInfoMap1, E, F, G, H),
+		map__det_insert(TypeInfoMap1, TypeVar1, type_info(Var),
+			TypeInfoMap),
+		Info = poly_info(A, B, C, TypeInfoMap, E, F, G, H)
 	;
 		error("polymorphism__make_var: unknown type")
 	).
 
 :- pred polymorphism__construct_type_info(type, type_id, list(type),
-	bool, module_info, map(tvar, var), varset, map(var, type),
-	var, map(tvar, var), list(hlds_goal), varset, map(var, type)).
-:- mode polymorphism__construct_type_info(in, in, in, in, in, in, in, in,
-	out, out, out, out, out) is det.
+	bool, var, list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__construct_type_info(in, in, in, in, out, out, 
+	in, out) is det.
 
 polymorphism__construct_type_info(Type, TypeId, TypeArgs, IsHigherOrder, 
-		ModuleInfo, TypeInfoMap0, VarSet0, VarTypes0,
-		Var, TypeInfoMap, ExtraGoals, VarSet, VarTypes) :-
+		Var, ExtraGoals, Info0, Info) :-
 
 	% Create the typeinfo vars for the arguments
-	polymorphism__make_vars(TypeArgs, ModuleInfo, TypeInfoMap0,
-		VarSet0, VarTypes0, ArgTypeInfoVars, TypeInfoMap, 
-		ArgTypeInfoGoals, VarSet1, VarTypes1),
+	polymorphism__make_type_info_vars(TypeArgs, ArgTypeInfoVars, 
+		ArgTypeInfoGoals, Info0, Info1),
+
+	Info1 = poly_info(VarSet1, VarTypes1, C, D, E, F, G, ModuleInfo),
 
 	module_info_globals(ModuleInfo, Globals),
 	globals__get_type_info_method(Globals, TypeInfoMethod),
@@ -863,7 +1569,9 @@
 			ArgTypeInfoGoals, Type, IsHigherOrder,
 			BaseVar, VarSet2, VarTypes2, [BaseGoal],
 			Var, VarSet, VarTypes, ExtraGoals)
-	).
+	),
+
+	Info = poly_info(VarSet, VarTypes, C, D, E, F, G, ModuleInfo).
 
 		% Create a unification for the two-cell type_info
 		% variable for this type if the type arity is not zero:
@@ -1201,6 +1909,8 @@
 
 	BaseTypeInfoGoal = Unify - GoalInfo.
 
+%---------------------------------------------------------------------------%
+
 :- pred polymorphism__make_head_vars(list(tvar), tvarset,
 				varset, map(var, type),
 				list(var), varset, map(var, type)).
@@ -1240,18 +1950,346 @@
 					[Type], UnifyPredType),
 	map__set(VarTypes0, Var, UnifyPredType, VarTypes).
 
+%---------------------------------------------------------------------------%
+
+:- pred extract_type_info(type, tvar, var, int, list(hlds_goal),
+	var, poly_info, poly_info).
+:- mode extract_type_info(in, in, in, in, out, out, in, out) is det.
+
+extract_type_info(Type, TypeVar, TypeClassInfoVar, Index, Goals,
+		TypeInfoVar, PolyInfo0, PolyInfo) :-
+	PolyInfo0 = poly_info(VarSet0, VarTypes0, C, TypeInfoLocns0, 
+		E, F, G, ModuleInfo),
+	extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo,
+		Goals, TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
+		VarSet, VarTypes, TypeInfoLocns),
+	PolyInfo = poly_info(VarSet, VarTypes, C, TypeInfoLocns, E, F, G, 
+			ModuleInfo).
+
+:- pred extract_type_info_2(type, tvar, var, int, module_info, list(hlds_goal),
+	var, varset, map(var, type), map(tvar, type_info_locn),
+	varset, map(var, type), map(tvar, type_info_locn)).
+:- mode extract_type_info_2(in, in, in, in, in, out, out, in, in, in, out, out,
+	out) is det.
+
+extract_type_info_2(Type, _TypeVar, TypeClassInfoVar, Index, ModuleInfo, Goals,
+		TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
+		VarSet, VarTypes, TypeInfoLocns) :-
+
+		% We need a tvarset to pass to get_pred_id_and_proc_id
+	varset__init(TVarSet0),
+	varset__new_var(TVarSet0, TVar, TVarSet),
+
+	term__context_init(EmptyContext),
+	ExtractTypeInfo = qualified("mercury_builtin",
+				"type_info_from_typeclass_info"),
+	TypeClassInfoTerm = term__functor(term__atom("typeclass_info"), [],
+		EmptyContext),
+	IntTerm = term__functor(term__atom("int"), [], EmptyContext),
+	TypeInfoTerm = term__functor(term__atom("type_info"), 
+		[term__variable(TVar)], EmptyContext),
+
+	get_pred_id_and_proc_id(ExtractTypeInfo, predicate, TVarSet, 
+		[TypeClassInfoTerm, IntTerm, TypeInfoTerm],
+		ModuleInfo, PredId, ProcId),
+	polymorphism__make_count_var(Index, VarSet0, VarTypes0, IndexVar,
+		IndexGoal, VarSet1, VarTypes1),
+
+	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),
+
+		% Now we put a dummy value in the dummy type-info variable.
+	polymorphism__init_with_int_constant(DummyTypeInfoVar, 0,
+		DummyTypeInfoGoal),
+
+		% Make the goal info for the call
+	set__list_to_set([DummyTypeInfoVar, TypeClassInfoVar, IndexVar,
+		TypeInfoVar], NonLocals),
+	instmap_delta_from_assoc_list([TypeInfoVar - ground(shared, no)],
+		InstmapDelta),
+	goal_info_init(NonLocals, InstmapDelta, det, GoalInfo),
+
+	Call = call(PredId, ProcId, 
+		[DummyTypeInfoVar, TypeClassInfoVar, IndexVar, TypeInfoVar],
+		not_builtin, no, ExtractTypeInfo) - GoalInfo,
+
+	Goals = [IndexGoal, DummyTypeInfoGoal, Call],
+
+	/* We should do this, except that makes us incorrectly compute the
+	 * non-locals for the goal, since it appears to fixup_quantification
+	 * that the type-info is non-local, but the typeclass-info is not.
+		% Update the location of the type_info so that we don't go to
+		% the bother of re-extracting it.
+	map__det_update(TypeInfoLocns0, TypeVar, type_info(TypeInfoVar),
+		TypeInfoLocns).
+	*/
+	TypeInfoLocns = TypeInfoLocns0.
+
+%---------------------------------------------------------------------------%
+
+	% Add a head var for each class constraint, and make an entry in the
+	% typeinfo locations map for each constrained type var.
+:- pred polymorphism__make_typeclass_info_head_vars(list(class_constraint),
+	module_info, varset, map(var, type), list(var), 
+	map(var, type_info_locn), list(var), varset, map(var, type)).
+:- mode polymorphism__make_typeclass_info_head_vars(in, in, in, in, 
+	out, out, out, out, out) is det.
+
+polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo, VarSet0, 
+		VarTypes0, ExtraHeadVars, TypeClassInfoMap, ConstrainedTVars,
+		VarSet, VarTypes) :-
+
+		% initialise the new accumulators
+	ExtraHeadVars0 = [],
+	map__init(TypeClassInfoMap0),
+
+		% do the work
+	polymorphism__make_typeclass_info_head_vars_2(ClassContext, ModuleInfo,
+		VarSet0, VarSet, 
+		VarTypes0, VarTypes, 
+		ExtraHeadVars0, ExtraHeadVars1,
+		TypeClassInfoMap0, TypeClassInfoMap),
+
+		% A type var has a location in a typeclass info iff it is
+		% constrained
+	map__keys(TypeClassInfoMap, ConstrainedTVars),
+
+		% The ExtraHeadVars are built up in reverse
+	list__reverse(ExtraHeadVars1, ExtraHeadVars).
+
+:- pred polymorphism__make_typeclass_info_head_vars_2(list(class_constraint),
+		module_info, varset, varset, 
+		map(var, type), map(var, type),
+		list(var), list(var),
+		map(var, type_info_locn), map(var, type_info_locn)).
+:- mode polymorphism__make_typeclass_info_head_vars_2(in, in, in, out, in, out, 
+		in, out, in, out) is det.
+
+polymorphism__make_typeclass_info_head_vars_2([], _,
+		VarSet, VarSet, 
+		VarTypes, VarTypes, 
+		ExtraHeadVars, ExtraHeadVars,
+		TypeInfoLocations, TypeInfoLocations).
+polymorphism__make_typeclass_info_head_vars_2([C|Cs], ModuleInfo,
+		VarSet0, VarSet, 
+		VarTypes0, VarTypes, 
+		ExtraHeadVars0, ExtraHeadVars,
+		TypeClassInfoMap0, TypeClassInfoMap) :-
+
+	C = constraint(ClassName0, ClassTypes),
+
+		% Work out how many superclass the class has
+	list__length(ClassTypes, ClassArity),
+	ClassId = class_id(ClassName0, ClassArity),
+	module_info_classes(ModuleInfo, ClassTable),
+	map__lookup(ClassTable, ClassId, ClassDefn),
+	ClassDefn = hlds_class_defn(SuperClasses, _, _, _, _),
+	list__length(SuperClasses, NumSuperClasses),
+
+	unqualify_name(ClassName0, ClassName),
+
+		% Make a new variable to contain the dictionary for this
+		% typeclass constraint
+	polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName,
+		Var, VarSet1, VarTypes1),
+	ExtraHeadVars1 = [Var | ExtraHeadVars0],
+
+		% Find all the type variables in the constraint, and remember
+		% what index they appear in in the typeclass info.
+
+		% The first type_info will be just after the superclass infos
+	First is NumSuperClasses + 1,
+	term__vars_list(ClassTypes, ClassTypeVars0),
+	MakeIndex = lambda([Elem0::in, Elem::out, 
+				Index0::in, Index::out] is det,
+		(
+			Elem = Elem0 - Index0,
+			Index is Index0 + 1
+		)),
+	list__map_foldl(MakeIndex, ClassTypeVars0, ClassTypeVars, First, _),
+		
+
+		% Work out which ones haven't been seen before
+	IsNew = lambda([TypeVar0::in] is semidet,
+		(
+			TypeVar0 = TypeVar - _Index,
+			\+ map__search(TypeClassInfoMap0, TypeVar, _)
+		)),
+	list__filter(IsNew, ClassTypeVars, NewClassTypeVars),
+
+		% Make an entry in the TypeInfo locations map for each new
+		% type variable. The type variable can be found at the
+		% previously calculated offset with the new typeclass_info
+	MakeEntry = lambda([IndexedTypeVar::in, 
+				LocnMap0::in, LocnMap::out] is det,
+		(
+			IndexedTypeVar = TheTypeVar - Location,
+			map__det_insert(LocnMap0, TheTypeVar,
+				typeclass_info(Var, Location), LocnMap)
+		)),
+	list__foldl(MakeEntry, NewClassTypeVars, 
+		TypeClassInfoMap0, TypeClassInfoMap1),
+
+		% Handle the rest of the constraints
+	polymorphism__make_typeclass_info_head_vars_2(Cs, ModuleInfo,
+		VarSet1, VarSet,
+		VarTypes1, VarTypes,
+		ExtraHeadVars1, ExtraHeadVars,
+		TypeClassInfoMap1, TypeClassInfoMap).
+
+:- pred polymorphism__new_typeclass_info_var(varset, map(var, type), 
+		string, var, 
+		varset, map(var, type)).
+:- mode polymorphism__new_typeclass_info_var(in, in, in, out, out, out) is det.
+
+polymorphism__new_typeclass_info_var(VarSet0, VarTypes0, ClassName, 
+		Var, VarSet, VarTypes) :-
+	% introduce new variable
+	varset__new_var(VarSet0, Var, VarSet1),
+	string__append("TypeClassInfo_for_", ClassName, Name),
+	varset__name_var(VarSet1, Var, Name, VarSet),
+
+	construct_type(qualified("mercury_builtin", "typeclass_info") - 0,
+					[], DictionaryType),
+	map__set(VarTypes0, Var, DictionaryType, VarTypes).
+
+%---------------------------------------------------------------------------%
+
+	% 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, ModuleName),
+	map__keys(Classes, ClassIds0),
+
+		% Don't expand classes from other modules
+	FromThisModule = lambda([ClassId::in] is semidet,
+		(
+			ClassId = class_id(qualified(ModuleName, _), _)
+		)),
+	list__filter(FromThisModule, ClassIds0, ClassIds),
+
+	map__apply_to_list(ClassIds, Classes, ClassDefns),
+	list__foldl(expand_bodies, ClassDefns, ModuleInfo0, ModuleInfo).
+
+:- 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) :-
+	list__foldl2(expand_one_body, Interface, 1, _, ModuleInfo0, ModuleInfo).
+
+:- pred expand_one_body(hlds_class_proc, int, int, module_info, module_info).
+:- mode expand_one_body(in, in, out, in, out) is det.
+
+expand_one_body(hlds_class_proc(PredId, ProcId), ProcNum0, ProcNum, 
+		ModuleInfo0, ModuleInfo) :-
+	module_info_preds(ModuleInfo0, PredTable0),
+	map__lookup(PredTable0, PredId, PredInfo0),
+	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|_]
+	->
+		InstanceConstraint = Head
+	;
+		error("expand_one_body: class method is not constrained")
+	),
+
+	proc_info_typeclass_info_varmap(ProcInfo0, VarMap),
+	map__lookup(VarMap, InstanceConstraint, TypeClassInfoVar),
+
+	proc_info_headvars(ProcInfo0, HeadVars0),
+	proc_info_vartypes(ProcInfo0, Types0),
+	proc_info_argmodes(ProcInfo0, Modes0),
+	proc_info_declared_determinism(ProcInfo0, Detism0),
+	(
+		Detism0 = yes(Detism1)
+	->
+		Detism = Detism1
+	;
+		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),
+		delete_nth(Modes0, N, Modes1)
+	->
+		HeadVars = HeadVars1,
+		map__apply_to_list(HeadVars1, Types0, Types),
+		Modes = Modes1
+	;
+		error("expand_one_body: typeclass_info var not found")
+	),
+
+	BodyGoalExpr = class_method_call(TypeClassInfoVar, ProcNum0,
+		HeadVars, Types, Modes, Detism),
+
+		% Make the goal info for the call. 
+	set__list_to_set(HeadVars0, NonLocals),
+	instmap_delta_from_mode_list(HeadVars0, Modes0, ModuleInfo0,
+			InstmapDelta),
+	goal_info_init(NonLocals, InstmapDelta, Detism, GoalInfo),
+	BodyGoal = BodyGoalExpr - GoalInfo,
+
+	proc_info_set_goal(ProcInfo0, BodyGoal, ProcInfo),
+	map__det_update(ProcTable0, ProcId, ProcInfo, ProcTable),
+	pred_info_set_procedures(PredInfo0, ProcTable, PredInfo),
+	map__det_update(PredTable0, PredId, PredInfo, PredTable),
+	module_info_set_preds(ModuleInfo0, PredTable, ModuleInfo),
+
+	ProcNum is ProcNum0 + 1.
+	
+:- pred delete_nth(list(T)::in, int::in, list(T)::out) is semidet.
+
+delete_nth([X|Xs], N0, Result) :-
+	(
+		N0 > 1
+	->
+		N is N0 - 1,
+		delete_nth(Xs, N, TheRest),
+		Result = [X|TheRest]
+	;
+		Result = Xs
+	).
+
+%---------------------------------------------------------------------------%
+
 :- pred polymorphism__get_module_info(module_info, poly_info, poly_info).
 :- mode polymorphism__get_module_info(out, in, out) is det.
 
 polymorphism__get_module_info(ModuleInfo, PolyInfo, PolyInfo) :-
-	PolyInfo = poly_info(_, _, _, _, _, ModuleInfo).
+	PolyInfo = poly_info(_, _, _, _, _, _, _, ModuleInfo).
 
 :- pred polymorphism__set_module_info(module_info, poly_info, poly_info).
 :- mode polymorphism__set_module_info(in, in, out) is det.


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.