[m-rev.] [dotnet-foreign] diff: foreign_class implementation

Peter Ross peter.ross at miscrit.be
Sat Jun 9 01:38:38 AEST 2001


Hi,

This diff is very rough and contains a lot of XXX's, but it does work.
I just wanted to check it all in so as to have it ready for demo at the
DevLab.

===================================================================


Estimated hours taken: 100
Branches: dotnet-foreign

Add the first cut of the pragma foreign_class declaration.

compiler/ml_foreign_class.m:
    Generate a mlds__class_defn which represents the foreign_class.

compiler/hlds_data.m:
    Add the foreign_class_table for storing information about
    foreign_class pragmas.
    Add an extra field to the hlds_class_proc which records which maybe
    records which instance method this pred_proc_id pair refers to.
    This is needed so that ml_foreign_class can generate calls to this
    instance method.

compiler/make_hlds.m:
    Process the foreign_class pragmas and insert into the
    foreign_class_table.

compiler/ml_code_gen.m:
    Call the ml_foreign_class module.

compiler/ml_call_gen.m:
    Add a version of ml_gen_proc_addr_rval which doesn't require the
    ml_gen_info.

compiler/mlds.m:
    Add to mlds__class_defn a list of mlds__defn which are the
    constructors for this class.
    Add a new rval self which is the equivalent of the this pointer in
    C++.

compiler/mlds_to_il.m:
    Handle exported names throughout the generation of IL code.
    Implement defn_to_class_decl for instance methods.
    Changes to handle the addition of the list of constructors to
    mlds__class_defn.
    Changes to handle the addition of self to mlds__rval.

compiler/unify_proc.m:
    Create empty bodies for index, unify and compare procs for foreign types.
    At some later date this will need to be fixed.

compiler/mlds_to_c.m:
compiler/mlds_to_csharp.m:
compiler/mlds_to_java.m:
compiler/mlds_to_mcpp.m:
    Changes to handle the addition of the list of constructors to
    mlds__class_defn.
    Changes to handle the addition of self to mlds__rval.

compiler/base_typeclass_info.m:
compiler/check_typeclass.m:
compiler/dead_proc_elim.m:
compiler/higher_order.m:
compiler/hlds_out.m:
compiler/intermod.m:
compiler/polymorphism.m:
    Changes to handle the new hlds_class_proc datastructure.

compiler/hlds_module.m:
    Utility predicates for the foreign_class_table.

compiler/mercury_to_mercury.m:
    Output pragma_foreign_class pragmas.

compiler/ml_elim_nested.m:
compiler/ml_optimize.m:
compiler/ml_tailcall.m:
compiler/ml_type_gen.m:
    Changes to handle the addition of the list of constructors to
    mlds__class_defn.

compiler/module_qual.m:
compiler/modules.m:
compiler/prog_data.m:
    Changes to handle the addition of foreign_class pragma.

compiler/prog_io_pragma.m:
    Parse the foreign_class pragma.

Index: compiler/base_typeclass_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/base_typeclass_info.m,v
retrieving revision 1.20
diff -u -r1.20 base_typeclass_info.m
--- compiler/base_typeclass_info.m	2000/11/01 05:11:49	1.20
+++ compiler/base_typeclass_info.m	2001/06/08 15:07:59
@@ -116,7 +116,7 @@
 	NumExtra = NumConstraints + NumUnconstrained,
 	ExtractPredProcId = lambda([HldsPredProc::in, PredProc::out] is det,
 		(
-			HldsPredProc = hlds_class_proc(PredId, ProcId),
+			HldsPredProc = hlds_class_proc(PredId, ProcId, _),
 			PredProc = proc(PredId, ProcId)
 		)),
 	list__map(ExtractPredProcId, PredProcIds0, PredProcIds),
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.39.10.2
diff -u -r1.39.10.2 check_typeclass.m
--- compiler/check_typeclass.m	2001/05/08 11:46:09	1.39.10.2
+++ compiler/check_typeclass.m	2001/06/08 15:07:59
@@ -162,7 +162,7 @@
 		solutions(
 			(pred(PredId::out) is nondet :-
 				list__member(ClassProc, ClassInterface),
-				ClassProc = hlds_class_proc(PredId, _)
+				ClassProc = hlds_class_proc(PredId, _, _)
 			),
 			PredIds),
 		list_map_foldl2(
@@ -404,7 +404,7 @@
 		lambda([ProcId::out] is nondet, 
 			(
 				list__member(ClassProc, ClassInterface),
-				ClassProc = hlds_class_proc(PredId, ProcId)
+				ClassProc = hlds_class_proc(PredId, ProcId, _)
 			)),
 		ProcIds),
 	module_info_pred_info(ModuleInfo0, PredId, PredInfo),
@@ -515,7 +515,7 @@
 			lambda([TheProcId::in, PredProcId::out] is det,
 			(
 				PredProcId = hlds_class_proc(InstancePredId,
-					TheProcId)
+						TheProcId, yes(InstanceMethod))
 			)),
 		list__map(MakeClassProc, InstanceProcIds, InstancePredProcs1),
 		(
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.65
diff -u -r1.65 dead_proc_elim.m
--- compiler/dead_proc_elim.m	2001/04/07 14:04:33	1.65
+++ compiler/dead_proc_elim.m	2001/06/08 15:07:59
@@ -262,7 +262,7 @@
 	AddHldsClassProc = lambda(
 		[PredProc::in, Q0::in, Q::out, N0::in, N::out] is det,
 		(
-			PredProc = hlds_class_proc(PredId, ProcId),
+			PredProc = hlds_class_proc(PredId, ProcId, _),
 			queue__put(Q0, proc(PredId, ProcId), Q),
 			map__set(N0, proc(PredId, ProcId), no, N)
 		)),
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.85.2.1
diff -u -r1.85.2.1 higher_order.m
--- compiler/higher_order.m	2001/06/03 09:00:50	1.85.2.1
+++ compiler/higher_order.m	2001/06/08 15:08:00
@@ -772,7 +772,7 @@
 				InstanceConstraintArgs)
 		->
 			list__index1_det(ClassInterface, Method,
-				hlds_class_proc(PredId, ProcId)),
+				hlds_class_proc(PredId, ProcId, _)),
 			list__append(InstanceConstraintArgs, Args, AllArgs)
 		;
 			fail
@@ -865,7 +865,7 @@
 		Instance = hlds_instance_defn(_, _, _, _,
 			_, _, yes(ClassInterface), _, _),
 		list__index1_det(ClassInterface, MethodNum,
-			hlds_class_proc(PredId, ProcId))
+			hlds_class_proc(PredId, ProcId, _))
 	;
 		find_matching_instance_method(Instances, MethodNum,
 			ClassTypes, PredId, ProcId, Constraints,
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.53.4.4
diff -u -r1.53.4.4 hlds_data.m
--- compiler/hlds_data.m	2001/06/03 09:00:52	1.53.4.4
+++ compiler/hlds_data.m	2001/06/08 15:08:01
@@ -833,7 +833,8 @@
 :- type hlds_class_proc
 	---> 	hlds_class_proc(
 			pred_id,
-			proc_id
+			proc_id,
+			maybe(instance_method)
 		).
 
 	% For each class, we keep track of a list of its instances, since there
@@ -899,6 +900,24 @@
 	% I'm sure there's a very clever way of 
 	% doing this with graphs or relations...
 :- type superclass_table == multi_map(class_id, subclass_details).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- interface.
+
+:- type foreign_class_table == map(string, foreign_class_defn).
+
+:- type foreign_class_defn
+	--->	foreign_class(
+			(instance)	:: sym_name,
+			(type)		:: (type),
+			constructors	:: list(pred_id),
+			foreign_name	:: string,
+			context		:: prog_context
+		).
+
+:- implementation.
 
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_module.m,v
retrieving revision 1.65.4.1
diff -u -r1.65.4.1 hlds_module.m
--- compiler/hlds_module.m	2001/05/03 13:04:24	1.65.4.1
+++ compiler/hlds_module.m	2001/06/08 15:08:01
@@ -190,6 +190,13 @@
 	module_info).
 :- mode module_info_set_superclasses(in, in, out) is det.
 
+:- pred module_info_foreign_classes(module_info, foreign_class_table).
+:- mode module_info_foreign_classes(in, out) is det.
+
+:- pred module_info_set_foreign_classes(module_info,
+		foreign_class_table, module_info).
+:- mode module_info_set_foreign_classes(in, in, out) is det.
+
 :- pred module_info_assertion_table(module_info, assertion_table).
 :- mode module_info_assertion_table(in, out) is det.
 
@@ -476,6 +483,7 @@
 		class_table ::			class_table,
 		instance_table ::		instance_table,
 		superclass_table ::		superclass_table,
+		foreign_class_table ::		foreign_class_table,
 		assertion_table ::		assertion_table,
 		ctor_field_table ::		ctor_field_table,
 		cell_counter ::			counter
@@ -564,6 +572,8 @@
 	set__list_to_set(ImportDeps `list__append` UseDeps, ImportedModules),
 	set__init(IndirectlyImportedModules),
 
+	map__init(ForeignClassTable),
+
 	assertion_table_init(AssertionTable),
 	map__init(FieldNameTable),
 
@@ -574,8 +584,8 @@
 		TypeSpecInfo, NoTagTypes),
 	ModuleInfo = module(ModuleSubInfo, PredicateTable, Requests,
 		UnifyPredMap, QualifierInfo, Types, Insts, Modes, Ctors,
-		ClassTable, SuperClassTable, InstanceTable, AssertionTable,
-		FieldNameTable, counter__init(1)).
+		ClassTable, SuperClassTable, InstanceTable, ForeignClassTable,
+		AssertionTable, FieldNameTable, counter__init(1)).
 
 %-----------------------------------------------------------------------------%
 
@@ -592,6 +602,7 @@
 module_info_classes(MI, MI ^ class_table).
 module_info_instances(MI, MI ^ instance_table).
 module_info_superclasses(MI, MI ^ superclass_table).
+module_info_foreign_classes(MI, MI ^ foreign_class_table).
 module_info_assertion_table(MI, MI ^ assertion_table).
 module_info_ctor_field_table(MI, MI ^ ctor_field_table).
 module_info_get_cell_counter(MI, MI ^ cell_counter).
@@ -612,6 +623,7 @@
 module_info_set_classes(MI, C, MI ^ class_table := C).
 module_info_set_instances(MI, I, MI ^ instance_table := I).
 module_info_set_superclasses(MI, S, MI ^ superclass_table := S).
+module_info_set_foreign_classes(MI, A, MI ^ foreign_class_table := A).
 module_info_set_assertion_table(MI, A, MI ^ assertion_table := A).
 module_info_set_ctor_field_table(MI, CF, MI ^ ctor_field_table := CF).
 module_info_set_cell_counter(MI, CC, MI ^ cell_counter := CC).
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.258.2.4
diff -u -r1.258.2.4 hlds_out.m
--- compiler/hlds_out.m	2001/06/07 12:08:51	1.258.2.4
+++ compiler/hlds_out.m	2001/06/08 15:08:02
@@ -2710,7 +2710,7 @@
 :- pred hlds_out__write_class_proc(hlds_class_proc, io__state, io__state).
 :- mode hlds_out__write_class_proc(in, di, uo) is det.
 
-hlds_out__write_class_proc(hlds_class_proc(PredId, ProcId)) -->
+hlds_out__write_class_proc(hlds_class_proc(PredId, ProcId, _)) -->
 	io__write_string("hlds_class_proc(pred_id:"),
 	{ pred_id_to_int(PredId, PredInt) },
 	io__write_int(PredInt),
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.97.2.4
diff -u -r1.97.2.4 intermod.m
--- compiler/intermod.m	2001/05/08 11:46:13	1.97.2.4
+++ compiler/intermod.m	2001/06/08 15:08:04
@@ -865,7 +865,7 @@
 			{ MaybePredProcIds = yes(ClassProcs) ->
 				GetPredId =
 				    (pred(Proc::in, PredId::out) is det :-
-					Proc = hlds_class_proc(PredId, _)
+					Proc = hlds_class_proc(PredId, _, _)
 				    ),
 				list__map(GetPredId, ClassProcs, ClassPreds0),
 
@@ -2008,7 +2008,7 @@
 class_procs_to_pred_ids(ClassProcs, PredIds) :-
 	list__map(
 		(pred(ClassProc::in, PredId::out) is det :-
-			ClassProc = hlds_class_proc(PredId, _)
+			ClassProc = hlds_class_proc(PredId, _, _)
 		),
 		ClassProcs, PredIds0),
 	list__sort_and_remove_dups(PredIds0, PredIds).
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.368.2.7
diff -u -r1.368.2.7 make_hlds.m
--- compiler/make_hlds.m	2001/06/07 12:08:54	1.368.2.7
+++ compiler/make_hlds.m	2001/06/08 15:08:06
@@ -417,6 +417,17 @@
 		{ Module = Module0 }
 	;	
 		% XXXX
+		{ Pragma = foreign_class(Instance, Type, Constructors, Name) },
+		constructor_predids(Module0, Constructors, Context,
+				Module1, PredIds),
+		{ module_info_foreign_classes(Module1, ForeignClasses0) },
+		{ map__det_insert(ForeignClasses0, Name,
+				foreign_class(Instance, Type,
+				PredIds, Name, Context), ForeignClasses) },
+		{ module_info_set_foreign_classes(Module1,
+				ForeignClasses, Module) }
+	;	
+		% XXXX
 		{ Pragma = foreign_type(MercuryType, _, ForeignType,
 				ForeignTypeLocation) },
 		{ module_info_types(Module0, Types0) },
@@ -1571,6 +1582,43 @@
 		[]
 	).
 
+:- pred constructor_predids(module_info::in, list(pair(sym_name, arity))::in,
+		prog_context::in, module_info::out, list(pred_id)::out,
+		io__state::di, io__state::uo) is det.
+
+constructor_predids(Module, [], _, Module, []) --> [].
+constructor_predids(Module0, [SymName - Arity | Pairs],
+		Context, Module, [PredId | PredIds]) -->
+	constructor_predid(Module0, SymName, Arity, Context, Module1, PredId),
+	constructor_predids(Module1, Pairs, Context, Module, PredIds).
+
+:- pred constructor_predid(module_info::in, sym_name::in, arity::in,
+		prog_context::in, module_info::out, pred_id::out,
+		io__state::di, io__state::uo) is det.
+
+constructor_predid(Module0, Name, Arity, Context, Module, PredId) -->
+	( { get_matching_pred_ids(Module0, Name, Arity, PredIds) } ->
+		( { PredIds = [PredId0] } ->
+			{ PredId = PredId0 },
+			{ Module = Module0 }
+		;
+			{ invalid_pred_id(PredId) },
+			io__set_exit_status(1),
+			prog_out__write_context(Context),
+			io__write_string("Error: More then one matching func"),
+			io__write_string(" for "),
+			prog_out__write_sym_name_and_arity(Name/Arity),
+			io__write_string("\n"),
+			{ module_info_incr_errors(Module0, Module) }
+		)
+		
+	;
+		{ invalid_pred_id(PredId) },
+		undefined_pred_or_func_error(Name, Arity, Context,
+			"`:- pragma foreign_class declaration"),
+		{ module_info_incr_errors(Module0, Module) }
+	).
+
 :- type add_marker_pred_info == pred(pred_info, pred_info).
 :- inst add_marker_pred_info = (pred(in, out) is det).
 
@@ -2400,7 +2448,8 @@
 			    (pred(Maybe::in, PredProcId::out) is semidet :-
 				(
 					Maybe = yes(Pred - Proc),
-					PredProcId = hlds_class_proc(Pred, Proc)
+					PredProcId = hlds_class_proc(
+							Pred, Proc, no)
 			    )) },
 			{ list__filter_map(IsYes, PredProcIds0, PredProcIds1) },
 
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.184.2.7
diff -u -r1.184.2.7 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m	2001/06/03 09:01:11	1.184.2.7
+++ compiler/mercury_to_mercury.m	2001/06/08 15:08:07
@@ -358,6 +358,22 @@
 		mercury_output_pragma_foreign_code(Attributes, Pred,
 			PredOrFunc, Vars, VarSet, PragmaCode)
 	;
+		{ Pragma = foreign_class(InstanceName, InstanceType,
+				ConstructorList, ForeignClassName) },
+		io__write_string(":- pragma foreign_class("),
+		mercury_output_sym_name(InstanceName),
+		io__write_string("("),
+		output_type(varset__init, no, InstanceType),
+		io__write_string("), "),
+		( { ConstructorList = [] } ->
+			io__write_string("[], ")
+		;
+			{ error("mercury_output_item: non empty cons list") }
+		),
+		io__write_string("\""),
+		io__write_string(ForeignClassName),
+		io__write_string("\").\n")
+	;
 		{ Pragma = foreign_type(_MercuryType,
 				MercuryTypeSymName, ForeignType,
 				ForeignTypeLoc) },
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.20.4.3
diff -u -r1.20.4.3 ml_call_gen.m
--- compiler/ml_call_gen.m	2001/06/08 09:46:34	1.20.4.3
+++ compiler/ml_call_gen.m	2001/06/08 15:08:07
@@ -17,7 +17,7 @@
 :- interface.
 
 :- import_module prog_data.
-:- import_module hlds_pred, hlds_goal.
+:- import_module hlds_module, hlds_pred, hlds_goal.
 :- import_module code_model.
 :- import_module mlds, ml_code_util.
 
@@ -54,6 +54,9 @@
 		ml_gen_info, ml_gen_info).
 :- mode ml_gen_proc_addr_rval(in, in, out, in, out) is det.
 
+:- func ml_gen_proc_addr_rval(module_info, pred_id, proc_id) = mlds__rval.
+
+
 	% Given a source type and a destination type,
 	% and given an source rval holding a value of the source type,
 	% produce an rval that converts the source rval to the destination type.
@@ -97,7 +100,6 @@
 
 :- implementation.
 
-:- import_module hlds_module.
 :- import_module builtin_ops.
 :- import_module type_util, mode_util, error_util.
 :- import_module options, globals.
@@ -552,14 +554,15 @@
 ml_gen_proc_addr_rval(PredId, ProcId, CodeAddrRval) -->
 	=(MLDSGenInfo),
 	{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
-	{ ml_gen_pred_label(ModuleInfo, PredId, ProcId,
-		PredLabel, PredModule) },
-	{ Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId) },
-	{ Signature = mlds__get_func_signature(Params) },
-	{ QualifiedProcLabel = qual(PredModule,
-			PredModule, PredLabel - ProcId) },
-	{ CodeAddrRval = const(code_addr_const(proc(QualifiedProcLabel,
-		Signature))) }.
+	{ CodeAddrRval = ml_gen_proc_addr_rval(ModuleInfo, PredId, ProcId) }.
+
+ml_gen_proc_addr_rval(ModuleInfo, PredId, ProcId) = CodeAddrRval :-
+	ml_gen_pred_label(ModuleInfo, PredId, ProcId, PredLabel, PredModule),
+	Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+	Signature = mlds__get_func_signature(Params),
+	QualifiedProcLabel = qual(PredModule, PredModule, PredLabel - ProcId),
+	CodeAddrRval = const(code_addr_const(proc(QualifiedProcLabel,
+			Signature))).
 
 %
 % Generate rvals and lvals for the arguments of a procedure call
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.80.2.10
diff -u -r1.80.2.10 ml_code_gen.m
--- compiler/ml_code_gen.m	2001/06/08 09:46:34	1.80.2.10
+++ compiler/ml_code_gen.m	2001/06/08 15:08:08
@@ -767,6 +767,7 @@
 :- implementation.
 
 :- import_module ml_type_gen, ml_call_gen, ml_unify_gen, ml_switch_gen.
+:- import_module ml_foreign_class.
 :- import_module ml_code_util.
 :- import_module arg_info, llds, llds_out. % XXX needed for pragma foreign code
 :- import_module export, foreign. % XXX needed for pragma foreign code
@@ -832,7 +833,9 @@
 ml_gen_defns(ModuleInfo, MLDS_Defns) -->
 	ml_gen_types(ModuleInfo, MLDS_TypeDefns),
 	ml_gen_preds(ModuleInfo, MLDS_PredDefns),
-	{ MLDS_Defns = list__append(MLDS_TypeDefns, MLDS_PredDefns) }.
+	ml_foreign_class(ModuleInfo, MLDS_ForeignClassDefns),
+	{ MLDS_Defns = MLDS_TypeDefns ++ 
+			(MLDS_PredDefns ++ MLDS_ForeignClassDefns) }.
 
 %-----------------------------------------------------------------------------%
 %
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.23.4.4
diff -u -r1.23.4.4 ml_elim_nested.m
--- compiler/ml_elim_nested.m	2001/06/08 09:46:37	1.23.4.4
+++ compiler/ml_elim_nested.m	2001/06/08 15:08:10
@@ -382,7 +382,7 @@
 	EnvTypeFlags = env_type_decl_flags,
 	Fields = list__map(convert_local_to_field, LocalVars),
 	EnvTypeDefnBody = mlds__class(mlds__class_defn(EnvTypeKind, [], 
-		[mlds__generic_env_ptr_type], [], Fields)),
+		[mlds__generic_env_ptr_type], [], [], Fields)),
 	EnvTypeDefn = mlds__defn(EnvTypeEntityName, Context, EnvTypeFlags,
 		EnvTypeDefnBody),
 
@@ -1015,6 +1015,7 @@
 	fixup_rval(Y0, Y).
 fixup_rval(mem_addr(Lval0), mem_addr(Lval)) -->
 	fixup_lval(Lval0, Lval).
+fixup_rval(self, self) --> [].
 
 :- pred fixup_lvals(list(mlds__lval), list(mlds__lval), elim_info, elim_info).
 :- mode fixup_lvals(in, out, in, out) is det.
@@ -1202,7 +1203,7 @@
 	maybe_statement_contains_defn(MaybeBody, Name).
 defn_body_contains_defn(mlds__class(ClassDefn), Name) :-
 	ClassDefn = mlds__class_defn(_Kind, _Imports, _Inherits, _Implements,
-		FieldDefns),
+		_Ctors, FieldDefns),
 	defns_contains_defn(FieldDefns, Name).
 
 :- pred statements_contains_defn(mlds__statements, mlds__defn).
@@ -1330,7 +1331,7 @@
 	maybe_statement_contains_var(MaybeBody, Name).
 defn_body_contains_var(mlds__class(ClassDefn), Name) :-
 	ClassDefn = mlds__class_defn(_Kind, _Imports, _Inherits, _Implements,
-		FieldDefns),
+		_Ctors, FieldDefns),
 	defns_contains_var(FieldDefns, Name).
 
 :- pred maybe_statement_contains_var(maybe(mlds__statement), mlds__var).
Index: compiler/ml_foreign_class.m
===================================================================
RCS file: ml_foreign_class.m
diff -N ml_foreign_class.m
--- /dev/null	Sat Aug  7 21:45:41 1999
+++ ml_foreign_class.m	Sat Jun  9 01:08:10 2001
@@ -0,0 +1,351 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2001 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: ml_foreign_class.m
+% Main author: petdr
+%
+% Transform the foreign class table in the HLDS into an MLDS
+% representation which exports these foreign classes.
+%
+%-----------------------------------------------------------------------------%
+
+:- module ml_foreign_class.
+
+:- interface.
+
+:- import_module hlds_module, mlds.
+:- import_module io.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- pred ml_foreign_class(module_info, mlds__defns, io__state, io__state).
+:- mode ml_foreign_class(in, out, di, uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module code_model, hlds_data, hlds_pred.
+:- import_module ml_call_gen, ml_code_util, prog_data, type_util.
+:- import_module int, list, map, require, std_util, term.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+ml_foreign_class(ModuleInfo, Defns) -->
+	{ module_info_foreign_classes(ModuleInfo, ForeignClasses) },
+	{ Defns = list__map(
+			ml_foreign_class_defn(ModuleInfo),
+			map__values(ForeignClasses)) }.
+
+:- func ml_foreign_class_defn(module_info, foreign_class_defn) = mlds__defn.
+
+ml_foreign_class_defn(ModuleInfo, ForeignClassDefn)
+	= mlds__defn(Name, Context, DeclFlags, Defn) :-
+	Name = export(ForeignClassDefn ^ foreign_name),
+	Context = mlds__make_context(ForeignClassDefn ^ context),
+	DeclFlags = init_decl_flags(public, per_instance, non_virtual,
+			overridable, modifiable, concrete),
+	Defn = mlds__class(gen_class_defn(ModuleInfo, ForeignClassDefn)).
+
+:- func gen_class_defn(module_info, foreign_class_defn) = mlds__class_defn.
+
+gen_class_defn(ModuleInfo, ForeignClass)
+	= mlds__class_defn(Kind, Imports,
+			Inherits, Implements, Ctors, Members) :-
+	Kind = mlds__class,
+	Imports = [],
+
+	Inherits = [foreign_type_to_inherit_from(ModuleInfo, ForeignClass)],
+
+	Implements = [],
+	Ctors = list__map(construct_ctor(ModuleInfo, ForeignClass),
+			ForeignClass ^ constructors),
+	Members = [internal_state_of_class(ModuleInfo, ForeignClass) |
+			construct_methods(ModuleInfo, ForeignClass)].
+
+%-----------------------------------------------------------------------------%
+
+:- func foreign_type_to_inherit_from(module_info,
+		foreign_class_defn) = mlds__type.
+
+foreign_type_to_inherit_from(ModuleInfo, ForeignClass) = ForeignType :-
+	module_info_classes(ModuleInfo, Classes),
+	map__lookup(Classes, class_id(ForeignClass ^ (instance), 1), ClassDefn),
+	ClassDefn = hlds_class_defn(_, SuperClasses, _, _, _, _, _),
+		% XXX Enforce the constraint for now that we can only
+		% have one super class, as currently we have no
+		% mechanism to determine between inheriting a class and
+		% an interface.
+	( SuperClasses = [SuperClass] ->
+			% We need to find the type of the instance of
+			% the parent which is defined as a foreign type
+			% or foreign class.
+		SuperClass = constraint(Name, Args),
+		SuperClassId = class_id(Name, list__length(Args)),
+		module_info_instances(ModuleInfo, InstanceTable),
+		map__lookup(InstanceTable, SuperClassId, Instances),
+		list__filter_map((pred(ID::in, MLDS_Type::out) is semidet :-
+				ID = hlds_instance_defn(_, _, _, _,
+						[Type], _, _, _, _),
+				type_is_foreign_type(ModuleInfo, Type),
+				MLDS_Type = mercury_type_to_mlds_type(
+						ModuleInfo, Type)
+			), Instances, PossibleForeignTypes),
+		( PossibleForeignTypes = [ForeignType0] ->
+			ForeignType = ForeignType0
+		;
+			error("more then one superclass instance is a foreign_type for pragma foreign_class.")
+			
+		)
+	;
+		error("more then one superclass for pragma foreign_class.")
+	).
+
+:- pred type_is_foreign_type(module_info::in, prog_data__type::in) is semidet.
+
+type_is_foreign_type(ModuleInfo, Type) :-
+	module_info_types(ModuleInfo, Types),
+	type_to_type_id(Type, TypeId, _),
+	map__search(Types, TypeId, TypeDefn),
+	hlds_data__get_type_defn_body(TypeDefn, Body),
+	Body = foreign_type(_, _).
+
+%-----------------------------------------------------------------------------%
+
+:- func internal_state_of_class(module_info, foreign_class_defn) = mlds__defn.
+
+internal_state_of_class(ModuleInfo, ForeignClass)
+	= mlds__defn(data(var(mlds__var_name("state", no))),
+			mlds__make_context(ForeignClass ^ context),
+			DeclFlags, Entity) :-
+	DeclFlags = init_decl_flags(private, per_instance, non_virtual,
+			overridable, modifiable, concrete),
+	Entity = mlds__data(
+			mercury_type_to_mlds_type(ModuleInfo,
+					ForeignClass ^ (type)),
+			no_initializer
+		).
+	
+%-----------------------------------------------------------------------------%
+
+:- func construct_ctor(module_info, foreign_class_defn, pred_id) = mlds__defn.
+
+construct_ctor(ModuleInfo, ForeignClass, PredId)
+	= mlds__defn(EntityName, Context, DeclFlags, EntityDefn) :-
+
+	module_info_pred_info(ModuleInfo, PredId, PredInfo),
+	pred_info_procids(PredInfo, ProcIds),
+
+	(
+		ProcIds = [ProcId0],
+		pred_info_get_is_pred_or_func(PredInfo, function)
+	->
+		ProcId = ProcId0
+	;
+			% XXX
+		error("construct_ctor: more then one proc_id or not func.")
+	),
+
+	EntityName = export("This a constructor it has no Name!"),
+	Context = mlds__make_context(ForeignClass ^ context),
+
+	DeclFlags = init_decl_flags(public, per_instance, non_virtual,
+			overridable, modifiable, concrete),
+
+		% Discard the return types.
+	Params0 = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+	Params0 = mlds__func_params(Args, _RetTypes),
+	Params = mlds__func_params(Args, []),
+
+	Stmt = construct_ctor_body(ModuleInfo, ForeignClass, PredId, ProcId),
+
+	EntityDefn = mlds__function(no, Params, yes(Stmt), []).
+
+:- func construct_ctor_body(module_info, foreign_class_defn, pred_id,
+		proc_id) = mlds__statement.
+
+construct_ctor_body(ModuleInfo, ForeignClass, PredId, ProcId) = Stmt :-
+
+		% Compute the function signature
+	Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+	Signature = mlds__get_func_signature(Params),
+
+		% Compute the function address
+	FunctionToCall = ml_gen_proc_addr_rval(ModuleInfo, PredId, ProcId),
+
+		% Compute the lval which refers to the internal state of
+		% the object.
+	Lval = state_lval(ModuleInfo, ForeignClass),
+
+		% Set the arguments up
+	Params = mlds__func_params(Args, _),
+	module_info_name(ModuleInfo, Name),
+	MLDS_Name = mercury_module_name_to_mlds(Name),
+	Rvals = list__map((func(A) = R :-
+			A = EntityName - Type,
+			( EntityName = data(var(V)) ->
+				Var = qual(MLDS_Name, MLDS_Name, V),
+				R = lval(var(Var, Type))
+			;
+				error("rvals")
+			)
+		), Args),
+
+	RetVals = [Lval],
+
+		% XXX shouldn't this be tail_call
+	IsTailCall = call,
+
+	Call = call(Signature, FunctionToCall, no,
+			Rvals, RetVals, IsTailCall),
+	Context = mlds__make_context(ForeignClass ^ context),
+	Stmt = mlds__statement(Call, Context).
+	
+%-----------------------------------------------------------------------------%
+
+:- func construct_methods(module_info, foreign_class_defn) = mlds__defns.
+
+construct_methods(ModuleInfo, ForeignClass) = Defns :-
+	module_info_instances(ModuleInfo, Instances),
+	map__lookup(Instances,
+			class_id(ForeignClass ^ (instance), 1), InstanceDefns),
+	list__filter((pred(ID::in) is semidet :-
+			ID = hlds_instance_defn(_, local, _, _,
+					[ForeignClass ^ (type)], _, _, _, _)
+		), InstanceDefns, PossibleInstances),
+	( PossibleInstances = [Instance] ->
+		Instance = hlds_instance_defn(_, _, _, _, _, _,
+				MaybeClassInterface, _, _),
+		(
+			MaybeClassInterface = yes(ClassInterfaces0)
+		->
+			ClassInterfaces = ClassInterfaces0
+		;
+			error("ml_foreign_class: MaybeClassInterface")
+		),
+		Defns = list__map(construct_method(ModuleInfo, ForeignClass),
+				ClassInterfaces)
+	;
+		error("ml_foreign_class: more then one possible instance")
+	).
+
+:- func construct_method(module_info, foreign_class_defn,
+		hlds_class_proc) = mlds__defn.
+
+construct_method(ModuleInfo, ForeignClass, ClassProc)
+	= mlds__defn(EntityName, Context, DeclFlags, EntityDefn) :-
+
+	ClassProc = hlds_class_proc(PredId, ProcId, MaybeInstanceMethod),
+	( MaybeInstanceMethod = yes(InstanceMethod) ->
+		InstanceMethod = instance_method(_PredOrFunc, Name0,
+				_InstanceProcDef, _Arity, _Context),
+		( 
+			Name0 = unqualified(Name) 
+		;
+			Name0 = qualified(_, Name)
+		)
+	;
+		error("ml_foreign_class: unknown instance method.")
+	),
+	EntityName = export(Name),
+
+	Context = mlds__make_context(ForeignClass ^ context),
+
+	DeclFlags = init_decl_flags(public, per_instance, non_virtual,
+			overridable, modifiable, concrete),
+
+	Params = construct_proc_params(ModuleInfo, PredId, ProcId),
+	EntityDefn = mlds__function(no, Params, yes(Stmt), []),
+
+	Stmt = construct_method_body(ModuleInfo, ForeignClass, ClassProc).
+
+:- func construct_proc_params(module_info, pred_id, proc_id)
+		= mlds__func_params.
+
+construct_proc_params(ModuleInfo, PredId, ProcId)
+	= mlds__func_params(Args, RetTypes) :-
+	Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+	Params = mlds__func_params(Args0, RetTypes),
+	Args = list__take_upto(list__length(Args0) - 2, Args0).
+
+:- func rvals(module_info, pred_id, proc_id) = list(mlds__rval).
+
+rvals(ModuleInfo, PredId, ProcId) = Rvals :-
+	module_info_name(ModuleInfo, Name),
+	MLDS_Name = mercury_module_name_to_mlds(Name),
+
+	Params = construct_proc_params(ModuleInfo, PredId, ProcId),
+	Params = mlds__func_params(Args, _RetTypes),
+	Rvals = list__map((func(A) = R :-
+			A = EntityName - Type,
+			( EntityName = data(var(V)) ->
+				Var = qual(MLDS_Name, MLDS_Name, V),
+				R = lval(var(Var, Type))
+			;
+				error("rvals")
+			)
+		), Args).
+	
+:- func construct_method_body(module_info,
+		foreign_class_defn, hlds_class_proc) = mlds__statement.
+
+construct_method_body(ModuleInfo, ForeignClass, ClassProc) = Stmt :-
+	ClassProc = hlds_class_proc(PredId, ProcId, _MaybeInstanceMethod),
+
+		% Compute the function signature
+	Params = ml_gen_proc_params(ModuleInfo, PredId, ProcId),
+	Signature = mlds__get_func_signature(Params),
+
+		% Compute the function address
+	FunctionToCall = ml_gen_proc_addr_rval(ModuleInfo, PredId, ProcId),
+
+	ThisPtr = self,
+
+		% Compute the lval which refers to the internal state of
+		% the object.
+	Lval = state_lval(ModuleInfo, ForeignClass),
+
+		% Set the arguments up
+	Args = rvals(ModuleInfo, PredId, ProcId) ++
+			[lval(Lval), mem_addr(Lval)],
+
+		% XXX Compute the return values.
+	% Params = mlds__func_params(_, RetVals),
+	RetVals = [],
+
+
+		% XXX shouldn't this be tail_call
+	IsTailCall = call,
+
+	Call = call(Signature, FunctionToCall, yes(ThisPtr),
+			Args, RetVals, IsTailCall),
+	Context = mlds__make_context(ForeignClass ^ context),
+	Stmt = mlds__statement(Call, Context).
+
+
+	% Compute the lval which refers to the internal state of
+	% the object.
+:- func state_lval(module_info, foreign_class_defn) = mlds__lval.
+
+state_lval(ModuleInfo, ForeignClass) = Lval :-
+	ThisPtr = self,
+	FieldType = mercury_type_to_mlds_type(ModuleInfo,
+			ForeignClass ^ (type)),
+	CtorType = mlds__native_int_type,	% XXX
+	PtrType = mlds__native_int_type,	% XXX
+	module_info_name(ModuleInfo, Name),
+	FieldName = qual(mercury_module_name_to_mlds(Name),
+			mercury_module_name_to_mlds(qualified(Name,
+				ForeignClass ^ foreign_name)),
+			"state"),
+	Lval = field(no, ThisPtr, named_field(FieldName, CtorType),
+			FieldType, PtrType).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: compiler/ml_optimize.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_optimize.m,v
retrieving revision 1.7.4.3
diff -u -r1.7.4.3 ml_optimize.m
--- compiler/ml_optimize.m	2001/06/08 09:46:38	1.7.4.3
+++ compiler/ml_optimize.m	2001/06/08 15:08:10
@@ -90,11 +90,11 @@
 	;
 		DefnBody0 = mlds__class(ClassDefn0),
 		ClassDefn0 = class_defn(Kind, Imports, BaseClasses, Implements,
-		                MemberDefns0),
+		                Ctors, MemberDefns0),
 		MemberDefns = optimize_in_defns(MemberDefns0, Globals,
 			ModuleName),
 		ClassDefn = class_defn(Kind, Imports, BaseClasses, Implements,
-		                MemberDefns),
+		                Ctors, MemberDefns),
 		DefnBody = mlds__class(ClassDefn),
 		Defn = mlds__defn(Name, Context, Flags, DefnBody)
 	).
Index: compiler/ml_tailcall.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_tailcall.m,v
retrieving revision 1.6.4.2
diff -u -r1.6.4.2 ml_tailcall.m
--- compiler/ml_tailcall.m	2001/06/08 09:46:38	1.6.4.2
+++ compiler/ml_tailcall.m	2001/06/08 15:08:10
@@ -137,10 +137,10 @@
 	;
 		DefnBody0 = mlds__class(ClassDefn0),
 		ClassDefn0 = class_defn(Kind, Imports, BaseClasses, Implements,
-		                MemberDefns0),
+		                Ctors, MemberDefns0),
 		MemberDefns = mark_tailcalls_in_defns(MemberDefns0),
 		ClassDefn = class_defn(Kind, Imports, BaseClasses, Implements,
-		                MemberDefns),
+		                Ctors, MemberDefns),
 		DefnBody = mlds__class(ClassDefn),
 		Defn = mlds__defn(Name, Context, Flags, DefnBody)
 	).
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.5.4.5
diff -u -r1.5.4.5 ml_type_gen.m
--- compiler/ml_type_gen.m	2001/06/08 09:46:38	1.5.4.5
+++ compiler/ml_type_gen.m	2001/06/08 15:08:10
@@ -153,12 +153,13 @@
 	Imports = [],
 	Inherits = [],
 	Implements = [],
+	ClassCtors = [],
 
 	% put it all together
 	MLDS_TypeName = type(MLDS_ClassName, MLDS_ClassArity),
 	MLDS_TypeFlags = ml_gen_type_decl_flags,
 	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__enum,
-		Imports, Inherits, Implements, Members)),
+		Imports, Inherits, Implements, ClassCtors, Members)),
 	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
 		MLDS_TypeDefnBody),
 	
@@ -334,6 +335,7 @@
 	Imports = [],
 	Inherits = [],
 	Implements = [],
+	ClassCtors = [],
 
 	% put it all together
 	Members = list__condense([MaybeEqualityMembers, TagMembers,
@@ -341,7 +343,7 @@
 	MLDS_TypeName = type(BaseClassName, BaseClassArity),
 	MLDS_TypeFlags = ml_gen_type_decl_flags,
 	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
-		Imports, Inherits, Implements, Members)),
+		Imports, Inherits, Implements, ClassCtors, Members)),
 	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
 		MLDS_TypeDefnBody),
 	
@@ -425,12 +427,13 @@
 	Imports = [],
 	Inherits = [BaseClassId],
 	Implements = [],
+	ClassCtors = [],
 
 	% put it all together
 	MLDS_TypeName = type(UnqualClassName, ClassArity),
 	MLDS_TypeFlags = ml_gen_type_decl_flags,
 	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
-		Imports, Inherits, Implements, Members)),
+		Imports, Inherits, Implements, ClassCtors, Members)),
 	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
 		MLDS_TypeDefnBody).
 	
@@ -499,12 +502,13 @@
 	Imports = [],
 	Inherits = [ParentClassId],
 	Implements = [],
+	ClassCtors = [],
 
 	% put it all together
 	MLDS_TypeName = type(CtorClassName, CtorArity),
 	MLDS_TypeFlags = ml_gen_type_decl_flags,
 	MLDS_TypeDefnBody = mlds__class(mlds__class_defn(mlds__class,
-		Imports, Inherits, Implements, Members)),
+		Imports, Inherits, Implements, ClassCtors, Members)),
 	MLDS_TypeDefn = mlds__defn(MLDS_TypeName, MLDS_Context, MLDS_TypeFlags,
 		MLDS_TypeDefnBody),
 	
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.49.4.8
diff -u -r1.49.4.8 mlds.m
--- compiler/mlds.m	2001/06/08 09:46:39	1.49.4.8
+++ compiler/mlds.m	2001/06/08 15:08:12
@@ -503,6 +503,7 @@
 						% inherits these base classes
 		implements ::	list(mlds__interface_id),
 						% implements these interfaces
+		ctors ::	mlds__defns,	% contains these constructors
 		members ::	mlds__defns	% contains these members
 	).
 
@@ -1275,8 +1276,13 @@
 
 	;	binop(binary_op, mlds__rval, mlds__rval)
 
-	;	mem_addr(mlds__lval).
+	;	mem_addr(mlds__lval)
 		% The address of a variable, etc.
+
+	;	self.
+		% The equivalent of the this pointer in C++.  Note that
+		% this rval is valid iff we are targetting an object
+		% oriented backend.
 
 :- type mlds__unary_op
 	--->	box(mlds__type)
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.83.4.8
diff -u -r1.83.4.8 mlds_to_c.m
--- compiler/mlds_to_c.m	2001/06/08 09:46:40	1.83.4.8
+++ compiler/mlds_to_c.m	2001/06/08 15:08:13
@@ -962,7 +962,7 @@
 	% not when compiling to C++
 	%
 	{ ClassDefn = class_defn(Kind, _Imports, BaseClasses, _Implements,
-		AllMembers) },
+		_Ctors, AllMembers) },
 	( { Kind = mlds__enum } ->
 		{ StaticMembers = [] },
 		{ StructMembers = AllMembers }
@@ -2712,6 +2712,9 @@
 	% XXX are parentheses needed?
 	io__write_string("&"),
 	mlds_output_lval(Lval).
+
+mlds_output_rval(self) -->
+	{ error("mlds_to_c: self rval encountered.\n") }.
 
 :- pred mlds_output_unop(mlds__unary_op, mlds__rval, io__state, io__state).
 :- mode mlds_output_unop(in, in, di, uo) is det.
Index: compiler/mlds_to_csharp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_csharp.m,v
retrieving revision 1.1.2.6
diff -u -r1.1.2.6 mlds_to_csharp.m
--- compiler/mlds_to_csharp.m	2001/06/08 09:46:42	1.1.2.6
+++ compiler/mlds_to_csharp.m	2001/06/08 15:08:13
@@ -331,6 +331,9 @@
 write_csharp_rval(mem_addr(_)) -->
 	{ sorry(this_file, "mem_addr rval") }.
 	
+write_csharp_rval(self) -->
+	{ sorry(this_file, "self rval") }.
+	
 :- pred write_csharp_rval_const(mlds__rval_const, io__state, io__state).
 :- mode write_csharp_rval_const(in, di, uo) is det.
 write_csharp_rval_const(true) --> io__write_string("1").
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.15.4.20
diff -u -r1.15.4.20 mlds_to_il.m
--- compiler/mlds_to_il.m	2001/06/08 09:46:42	1.15.4.20
+++ compiler/mlds_to_il.m	2001/06/08 15:08:14
@@ -284,11 +284,43 @@
 :- mode generate_method_defn(in, in, out) is det.
 
 generate_method_defn(defn(type(_, _), _, _, _)) --> [].
-	% XXX we don't handle export
-generate_method_defn(defn(export(_), _, _, _)) --> [].
+generate_method_defn(ExportDefn) -->
+	{ ExportDefn = defn(export(Name), _, _, Entity) },
+	( { Entity = mlds__function(_, _, _, _) } ->
+		{ Id = Name },
+		{ EntryPoint = [] },
+		generate_method_function(ExportDefn, Id, EntryPoint)
+	;
+		[]
+	).
 generate_method_defn(FunctionDefn) -->
-	{ FunctionDefn = defn(function(PredLabel, ProcId, MaybeSeqNum, PredId), 
-		Context, DeclsFlags, Entity) },
+	{ FunctionDefn = defn(function(PredLabel, ProcId, MaybeSeqNum, _PredId),
+			_Context, _DeclsFlags, _Entity) },
+
+	{ predlabel_to_id(PredLabel, ProcId, MaybeSeqNum, Id) },
+
+		% If this is main, add the entrypoint, set a
+		% flag, and call the initialization instructions
+		% in the cctor of this module.
+	(
+		{ PredLabel = pred(predicate, no, "main", 2, model_det,
+				no) },
+		{ MaybeSeqNum = no }
+	->
+		{ EntryPoint = [entrypoint] },
+		il_info_add_init_instructions(
+			runtime_initialization_instrs),
+		^ has_main := yes
+	;
+		{ EntryPoint = [] }
+	),
+	generate_method_function(FunctionDefn, Id, EntryPoint).
+
+:- pred generate_method_function(mlds__defn::in, ilds__id::in,
+		list(method_body_decl)::in, il_info::in, il_info::out) is det.
+
+generate_method_function(Defn, Id, EntryPoint) -->
+	{ Defn = defn(_EntityName, Context, _DeclFlags, Entity) },
 	( { Entity = mlds__function(_PredProcId, Params, MaybeStatement,
 		Attributes) } ->
 
@@ -296,9 +328,7 @@
 			% Generate a term (we use it to emit the complete
 			% method definition as a comment, which is nice
 			% for debugging).
-		{ term__type_to_term(defn(function(PredLabel, ProcId, 
-			MaybeSeqNum, PredId), Context, DeclsFlags, Entity),
-			MLDSDefnTerm) },
+		{ term__type_to_term(Defn, MLDSDefnTerm) },
 
 			% Generate the signature
 		{ Params = mlds__func_params(Args, Returns) },
@@ -307,10 +337,6 @@
 		{ ILSignature = params_to_il_signature(DataRep, 
 			ModuleName, Params) },
 			
-			% Generate the name of the method.
-		{ predlabel_to_id(PredLabel, ProcId, MaybeSeqNum,
-			Id) },
-
 			% Initialize the IL info with this method info.
 		il_info_new_method(ILArgs, ILSignature, id(Id)),
 
@@ -332,21 +358,6 @@
 				mlds__native_bool_type])
 		),
 
-			% If this is main, add the entrypoint, set a
-			% flag, and call the initialization instructions
-			% in the cctor of this module.
-		( { PredLabel = pred(predicate, no, "main", 2, model_det,
-			no) },
-		  { MaybeSeqNum = no }
-		->
-			{ EntryPoint = [entrypoint] },
-			il_info_add_init_instructions(
-				runtime_initialization_instrs),
-			^ has_main := yes
-		;
-			{ EntryPoint = [] }
-		),
-
 			% Generate the custom attributes
 		{ CustomAttrs = attributes_to_custom_attributes(DataRep,
 			Attributes) },
@@ -529,11 +540,11 @@
 			{ Entity = mlds__class(ClassDefn) }
 		->
 			{ ClassDefn = mlds__class_defn(_ClassType, _Imports, 
-				Inherits, _Implements, Defns) },
+				Inherits, _Implements, _Ctors, Defns) },
 			DataRep =^ il_data_rep,
 			{ Extends = mlds_inherits_to_ilds_inherits(DataRep,
 				Inherits) },
-			list__map_foldl(defn_to_class_decl, Defns, ILDefns),
+			list__map_foldl(defn_to_class_decl(no), Defns, ILDefns),
 			{ make_constructor(DataRep, FullClassName, ClassDefn, 
 				ConstructorILDefn) },
 			{ Decls = [comment_term(MLDSDefnTerm),
@@ -545,10 +556,42 @@
 				comment("This type unimplemented.")] }
 		)
 	; { EntityName = function(_PredLabel, _ProcId, _MaybeFn, _PredId) },
-		{ Decls = [] }
-	; { EntityName = export(_) },
-			% XXX we don't handle export
 		{ Decls = [] }
+	; { EntityName = export(Name) },
+		( { Entity = mlds__class(ClassDefn) } ->
+			{ ClassDefn = mlds__class_defn(_ClassType, _Imports, 
+					Inherits, _Implements, Ctors, Defns) },
+			list__map_foldl(defn_to_class_decl(no),
+					Defns, ILDefnsA),
+			list__map_foldl(defn_to_class_decl(yes),
+					Ctors, ILDefnsB),
+			{ ILDefns = ILDefnsA ++ ILDefnsB },
+			{
+				Inherits = [mlds__foreign_type(ForeignType,
+						Assembly)]
+			->
+				sym_name_to_class_name(ForeignType,
+						no, ForeignClassName),
+				Extends = extends(structured_name(
+						Assembly, ForeignClassName))
+			;
+				error("multiple inheritance or not foreign_type")
+			}
+		;
+			{ error("not exporting a foreign_class") }
+		),
+			% XXX we are using export for foreign_class
+			% decls on this backend.
+		{ Decls = [class(
+					% XXX use the DeclFlags
+					[public],
+					Name,
+					% XXX use Entity
+					Extends,
+					implements([]),
+					ILDefns
+
+				)] }
 	; { EntityName = data(_) },
 		{ Decls = [] }
 	).
@@ -679,13 +722,13 @@
 % Code to turn MLDS definitions into IL class declarations.
 %
 
-:- pred defn_to_class_decl(mlds__defn, class_member, il_info, il_info).
-:- mode defn_to_class_decl(in, out, in, out) is det.
+:- pred defn_to_class_decl(bool, mlds__defn, class_member, il_info, il_info).
+:- mode defn_to_class_decl(in, in, out, in, out) is det.
 
 	% XXX shouldn't we re-use the code for creating fieldrefs here?
 	% IL doesn't allow byrefs in classes, so we don't use them.
 	% XXX really this should be a transformation done in advance
-defn_to_class_decl(mlds__defn(Name, _Context, _DeclFlags, 
+defn_to_class_decl(_, mlds__defn(Name, _Context, _DeclFlags, 
 		mlds__data(Type, _Initializer)), ILClassMember) -->
 	DataRep =^ il_data_rep,
 	{ ILType = remove_byrefs_from_type(
@@ -698,21 +741,91 @@
 	}.
 
 	% XXX this needs to be implemented
-defn_to_class_decl(mlds__defn(_Name, _Context, _DeclFlags,
-	mlds__function(_PredProcId, _Params, _MaybeStatements, _Attributes)),
+defn_to_class_decl(IsCtor, mlds__defn(Name, Context, _DeclFlags,
+	mlds__function(_PredProcId, Params, MaybeStatement, _Attributes)),
 		ILClassMember) -->
-	{ ILClassMember = comment("unimplemented: functions in classes") }.
 
-defn_to_class_decl(mlds__defn(EntityName, _Context, _DeclFlags,
+		% XXX should use declflags to generate this
+	{ MethodAttrs = [public] },
+
+	{ IsCtor = yes,
+		Id = ctor
+	; IsCtor = no,
+		( Name = export(ExportName) ->
+			Id = id(ExportName)
+		;
+				% XXX
+			Id = id("SomeName")
+		)
+	},
+
+	il_info_get_module_name(ModuleName),
+	DataRep =^ il_data_rep,
+	{ ILSignature = params_to_il_signature(DataRep, ModuleName, Params) },
+
+		% XXX
+	{ ImplAttrs = [] },
+
+		% Initialize the IL info with this method info.
+	{ Params = mlds__func_params(Args, Returns) },
+	{ ILArgs = list__map(mlds_arg_to_il_arg, Args) },
+	il_info_new_method(ILArgs, ILSignature, Id),
+
+		% XXX
+		% Start a new block, which we will use to wrap
+		% up the entire method.
+	il_info_get_next_block_id(BlockId),
+
+	( { MaybeStatement = yes(Statement) } -> 
+		statement_to_il(Statement, InstrsTree0)
+	;
+			% If there is no function body,
+			% generate forwarding code instead.
+			% This can happen with :- external
+		atomic_statement_to_il(inline_target_code(lang_C, []),
+			InstrsTree0),
+			% The code might reference locals...
+		il_info_add_locals(["succeeded" - 
+			mlds__native_bool_type])
+	),
+
+		% Need to insert a ret for functions returning
+		% void (MLDS doesn't).
+	{ Returns = [] ->
+		MaybeRet = instr_node(ret)
+	;
+		MaybeRet = empty
+	},
+
+
+		% Retrieve the locals, put them in the enclosing
+		% scope.
+	il_info_get_locals_list(Locals),
+	{ InstrsTree = tree__list([
+		context_node(Context),
+		instr_node(start_block(scope(Locals), BlockId)),
+		InstrsTree0, 
+		MaybeRet,
+		instr_node(end_block(scope(Locals), BlockId))
+		])
+	},
+
+		% Generate the entire method contents.
+	{ MethodDefn = make_method_defn(InstrsTree) },
+
+	{ MethodHead = methodhead(MethodAttrs, Id, ILSignature, ImplAttrs) },
+	{ ILClassMember = method(MethodHead, MethodDefn) }.
+
+defn_to_class_decl(_, mlds__defn(EntityName, _Context, _DeclFlags,
 		mlds__class(ClassDefn)), ILClassMember) -->
 	DataRep =^ il_data_rep,
 	( { EntityName = type(TypeName0, Arity) } ->
 		{ TypeName = string__format("%s_%d",
 			[s(TypeName0), i(Arity)]) },
 		{ ClassDefn = mlds__class_defn(_ClassType, _Imports, 
-			Inherits, _Implements, Defns) },
+			Inherits, _Implements, _Ctors, Defns) },
 		{ FullClassName = structured_name("", [TypeName]) },
-		list__map_foldl(defn_to_class_decl, Defns, ILDefns),
+		list__map_foldl(defn_to_class_decl(no), Defns, ILDefns),
 		{ make_constructor(DataRep, FullClassName, ClassDefn,
 			ConstructorILDefn) },
 		{ Extends = mlds_inherits_to_ilds_inherits(DataRep, Inherits) },
@@ -1054,7 +1167,7 @@
 		^ method_foreign_lang := yes(managed_cplusplus),
 		{ mangle_dataname_module(no, ModuleName, NewModuleName) },
 		{ ClassName = mlds_module_name_to_class_name(NewModuleName,
-				NewModuleName, no) },
+				NewModuleName, yes) },
 		signature(_, RetType, Params) =^ signature, 
 			% If there is a return value, put it in succeeded.
 			% XXX this is incorrect for functions, which might
@@ -1392,6 +1505,8 @@
 		{ Instrs = throw_unimplemented("load mem_addr lval mem_ref") }
 	).
 
+load(self, tree__list([instr_node(ldarg(index(0)))])) --> [].
+
 :- pred store(mlds__lval, instr_tree, il_info, il_info) is det.
 :- mode store(in, out, in, out) is det.
 
@@ -1725,6 +1840,8 @@
 		unexpected(this_file, "binop_function_name")
 	; Rval = mem_addr(_),
 		unexpected(this_file, "mem_addr_function_name")
+	; Rval = self,
+		unexpected(this_file, "self_function_name")
 	).
 
 %-----------------------------------------------------------------------------
@@ -2378,7 +2495,7 @@
 		Info = Info0
 	).
 
-	% The following four conversions should never occur or be boxed
+	% The following five conversions should never occur or be boxed
 	% anyway, but just in case they are we make them reference
 	% mercury.invalid which is a non-exisitant class.   If we try to
 	% run this code, we'll get a runtime error.
@@ -2399,6 +2516,11 @@
 	ModuleName = mercury_module_name_to_mlds(unqualified("mercury")),
 	Type = mlds__class_type(qual(ModuleName, ModuleName, "invalid"),
 		0, mlds__class).
+rval_to_type(self, Type, I, I) :-
+	% XXX trd what is the right thing here?
+	ModuleName = mercury_module_name_to_mlds(unqualified("mercury")),
+	Type = mlds__class_type(qual(ModuleName, ModuleName, "invalid"),
+		0, mlds__class).
 rval_to_type(const(Const), Type, I, I) :- 
 	Type = rval_const_to_type(Const).
 
@@ -2772,7 +2894,8 @@
 	ilasm__class_member).
 :- mode make_constructor(in, in, in, out) is det.
 make_constructor(DataRep, ClassName, 
-		mlds__class_defn(_,  _Imports, Inherits, _Implements, Defns),
+		mlds__class_defn(_,  _Imports,
+			Inherits, _Implements, _Ctors, Defns),
 		ILDecl) :-
 	Extends = mlds_inherits_to_ilds_inherits(DataRep, Inherits),
 	( Extends = extends_nothing,
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.2.4.7
diff -u -r1.2.4.7 mlds_to_java.m
--- compiler/mlds_to_java.m	2001/06/08 09:46:43	1.2.4.7
+++ compiler/mlds_to_java.m	2001/06/08 15:08:15
@@ -390,6 +390,7 @@
 		ClassExtends = [],
 		InterfaceDefn = mlds__class_type(Interface, 0, mlds__interface),
 		ClassImplements = [InterfaceDefn],
+		ClassCtors = [],
 		%
 		% Create a method that calls the original predicate.
 		%
@@ -403,7 +404,8 @@
 		ClassContext  = Context,
 		ClassFlags    = ml_gen_type_decl_flags,
 		ClassBodyDefn = mlds__class_defn(mlds__class, ClassImports, 
-			ClassExtends, ClassImplements, ClassMembers),
+			ClassExtends, ClassImplements,
+			ClassCtors, ClassMembers),
 		ClassBody     = mlds__class(ClassBodyDefn)
 	;
 
@@ -650,7 +652,7 @@
 		{ unexpected(this_file, "output_class") }
 	),
 	{ ClassDefn = class_defn(Kind, _Imports, BaseClasses, Implements,
-		AllMembers) },
+		_Ctors, AllMembers) },
 	( { Kind = mlds__interface } -> 
 		io__write_string("interface ")
 	;
@@ -2019,6 +2021,10 @@
 
 output_rval(mem_addr(_Lval)) -->
 	{ unexpected(this_file, "output_rval: mem_addr(_) not supported") }.
+
+output_rval(self) -->
+	% XXX how do we reference the self pointer in Java?
+	{ sorry(this_file, "output_rval: self not yet implemented") }.
 
 :- pred output_unop(mlds__unary_op, mlds__rval, io__state, io__state).
 :- mode output_unop(in, in, di, uo) is det.
Index: compiler/mlds_to_mcpp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_mcpp.m,v
retrieving revision 1.2.2.6
diff -u -r1.2.2.6 mlds_to_mcpp.m
--- compiler/mlds_to_mcpp.m	2001/06/08 09:46:44	1.2.2.6
+++ compiler/mlds_to_mcpp.m	2001/06/08 15:08:15
@@ -429,6 +429,9 @@
 write_managed_cpp_rval(mem_addr(_)) -->
 	io__write_string(" /* mem_addr rval -- unimplemented */ ").
 	
+write_managed_cpp_rval(self) -->
+	io__write_string(" /* self rval -- unimplemented */ ").
+	
 :- pred write_managed_cpp_rval_const(mlds__rval_const, io__state, io__state).
 :- mode write_managed_cpp_rval_const(in, di, uo) is det.
 write_managed_cpp_rval_const(true) --> io__write_string("1").
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.65.2.5
diff -u -r1.65.2.5 module_qual.m
--- compiler/module_qual.m	2001/05/18 14:25:11	1.65.2.5
+++ compiler/module_qual.m	2001/06/08 15:08:16
@@ -938,6 +938,9 @@
 qualify_pragma(source_file(File), source_file(File), Info, Info) --> [].
 qualify_pragma(foreign_decl(L, Code), foreign_decl(L, Code), Info, Info) --> [].
 qualify_pragma(foreign_code(L, C), foreign_code(L, C), Info, Info) --> [].
+qualify_pragma(foreign_class(A, Type0, C, D),
+		foreign_class(A, Type, C, D), Info0, Info) -->
+	qualify_type(Type0, Type, Info0, Info).
 qualify_pragma(foreign_type(Type0, SymName, F, L),
 		foreign_type(Type, SymName, F, L), Info0, Info) -->
 	qualify_type(Type0, Type, Info0, Info).
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.158.2.9
diff -u -r1.158.2.9 modules.m
--- compiler/modules.m	2001/06/07 12:09:01	1.158.2.9
+++ compiler/modules.m	2001/06/08 15:08:17
@@ -1030,6 +1030,7 @@
 pragma_allowed_in_interface(foreign_decl(_, _), no).
 pragma_allowed_in_interface(foreign_code(_, _), no).
 pragma_allowed_in_interface(foreign_proc(_, _, _, _, _, _), no).
+pragma_allowed_in_interface(foreign_class(_, _, _, _), yes).
 pragma_allowed_in_interface(foreign_type(_, _, _, _), yes).
 pragma_allowed_in_interface(inline(_, _), no).
 pragma_allowed_in_interface(no_inline(_, _), no).
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.208.2.2
diff -u -r1.208.2.2 polymorphism.m
--- compiler/polymorphism.m	2001/05/25 13:07:22	1.208.2.2
+++ compiler/polymorphism.m	2001/06/08 15:08:18
@@ -3293,7 +3293,7 @@
 :- 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, 
+expand_one_body(hlds_class_proc(PredId, ProcId, _), ProcNum0, ProcNum, 
 		ModuleInfo0, ModuleInfo) :-
 	module_info_preds(ModuleInfo0, PredTable0),
 	map__lookup(PredTable0, PredId, PredInfo0),
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.65.2.5
diff -u -r1.65.2.5 prog_data.m
--- compiler/prog_data.m	2001/05/18 14:25:24	1.65.2.5
+++ compiler/prog_data.m	2001/06/08 15:08:19
@@ -159,6 +159,11 @@
 			% PredName, Predicate or Function, Vars/Mode, 
 			% VarNames, Foreign Code Implementation Info
 
+	;	foreign_class(sym_name,
+			(type), list(pair(sym_name, arity)), string)
+			% Instance name, instance argument type,
+			% list of constructors, foreign name
+
 	;	foreign_type((type), sym_name, sym_name, string)
 			% MercuryType, MercuryTypeName, ForeignType,
 			% ForeignTypeLocation
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.30.2.3
diff -u -r1.30.2.3 prog_io_pragma.m
--- compiler/prog_io_pragma.m	2001/05/18 14:25:26	1.30.2.3
+++ compiler/prog_io_pragma.m	2001/06/08 15:08:19
@@ -70,6 +70,66 @@
 			ErrorTerm)
 	).
 
+parse_pragma_type(ModuleName, "foreign_class", PragmaTerms,
+            ErrorTerm, _VarSet, Result) :-
+    ( PragmaTerms = [InstanceTerm, ConstructorListTerm, ForeignNameTerm] -> 
+	parse_implicitly_qualified_term(ModuleName, InstanceTerm,
+		ErrorTerm, "`:- pragma foreign_class' declaration",
+		MaybeInstance),
+	(
+	    MaybeInstance = ok(InstanceSymName, InstanceArgs),
+	    ( InstanceArgs = [MercuryTypeTerm] ->
+		parse_implicitly_qualified_term(ModuleName, MercuryTypeTerm,
+			ErrorTerm, "`:- pragma foreign_class' declaration",
+			MaybeMercuryType),
+		(
+		    MaybeMercuryType = ok(_MercuryTypeSymName, MercuryArgs),
+		    ( MercuryArgs = [] ->
+			(
+			    ForeignNameTerm = term__functor(
+				    term__string(ForeignNameStr), [], _)
+			->
+			    term__coerce(MercuryTypeTerm, MercuryType),
+				% XXX Handle ConstructorListTerm correctly
+			    parse_pred_name_and_arity(ModuleName,
+				"foreign_class", ConstructorListTerm,
+				ErrorTerm, NameArityResult),
+			    (
+				NameArityResult = ok(PredName, Arity),
+			    	Result = ok(pragma(
+					foreign_class(InstanceSymName,
+			    		MercuryType, [PredName - Arity],
+					ForeignNameStr)))
+			    ;
+				NameArityResult = error(ErrorMsg, _),
+				Result = error(ErrorMsg, ConstructorListTerm)
+			    )
+			;
+			    Result = error("foreign class name not a string",
+				    ForeignNameTerm)
+			)
+		    ;
+			Result = error("instance type arity not 0",
+				MercuryTypeTerm)
+		    )
+		;
+		    MaybeMercuryType = error(String, Term),
+		    Result = error(String, Term)
+		)
+	    ;
+		Result = error("instance can only have one type argument",
+			InstanceTerm)
+	    )
+	;
+	    MaybeInstance = error(String, Term),
+	    Result = error(String, Term)
+	)
+    ;
+        Result = error(
+    "wrong number of arguments in `:- pragma foreign_class' declaration",
+            ErrorTerm)
+    ).
+
 parse_pragma_type(ModuleName, "foreign_type", PragmaTerms,
             ErrorTerm, _VarSet, Result) :-
     ( PragmaTerms = [MercuryName, ForeignName, ForeignLocation] ->
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.92.4.2
diff -u -r1.92.4.2 unify_proc.m
--- compiler/unify_proc.m	2001/04/11 11:16:26	1.92.4.2
+++ compiler/unify_proc.m	2001/06/08 15:08:23
@@ -746,7 +746,9 @@
 		{ error("trying to create unify proc for abstract type") }
 	;
 		{ TypeBody = foreign_type(_, _) },
-		{ error("trying to create unify proc for foreign type") }
+		% XXXX fix me!
+		{ Clauses = [] }
+		%  { error("trying to create unify proc for foreign type") }
 	).
 
 	% This predicate generates the bodies of index predicates for the
@@ -803,7 +805,9 @@
 		{ error("trying to create index proc for abstract type") }
 	;
 		{ TypeBody = foreign_type(_, _) },
-		{ error("trying to create index proc for foreign type") }
+		% XXXX fix me!
+		{ Clauses = [] }
+		% { error("trying to create index proc for foreign type") }
 	).
 
 :- pred unify_proc__generate_compare_clauses((type)::in, hlds_type_body::in,
@@ -873,7 +877,9 @@
 		{ error("trying to create compare proc for abstract type") }
 	;
 		{ TypeBody = foreign_type(_, _) },
-		{ error("trying to create compare proc for foreign type") }
+		% XXXX Fix me
+		{ Clauses = [] }
+		% { error("trying to create compare proc for foreign type") }
 	).
 
 :- pred unify_proc__quantify_clauses_body(list(prog_var)::in, hlds_goal::in,

--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------



More information about the reviews mailing list