[m-dev.] Generating methods for foreign classes

Peter Ross peter.ross at miscrit.be
Wed May 23 23:26:35 AEST 2001


Hi,

The following is a diff which currently generates for the following decl

:- pragma foreign_class(
                'Employee'(employee), % instance used to determine
                                      % methods implementations
                [],                   % List of constructor functions NYI
                "Employee"            % Name of exported class
            ).

the following IL

.namespace 'use_person'
{
  .class public 'Employee' extends ['Person']'Person'.'Person'
  {
    .field private class ['mscorlib']'System'.'Object'[] 'state'
  }
}

Now if the instance decl is

:- instance 'Employee'(employee) where [
    pred('Salary'/3) is salary
].

:- pred salary(int::in, employee::di, employee::uo) is det.

I now want to generate a .NET method body along the lines of 

.method void Salary(int s)
{
    ldarg s
    ldarg this_pointer
    ldfld store
    ldarg this_pointer
    ldflda store
    call mercury_salary_3(int, object[], object[]&)
}

Any hints on the best way to do this using the MLDS?
The bit that I am finding difficult is how I will go about generating
the instructions to retrieve the store argument.

Thanks,
Pete

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



Index: hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.53.4.3
diff -u -r1.53.4.3 hlds_data.m
--- hlds_data.m	2001/05/08 11:46:12	1.53.4.3
+++ hlds_data.m	2001/05/23 13:02:20
@@ -898,6 +898,24 @@
 
 :- interface.
 
+:- type foreign_class_table == map(string, foreign_class_defn).
+
+:- type foreign_class_defn
+	--->	foreign_class(
+			(instance)	:: sym_name,
+			(type)		:: (type),
+			constructors	:: list(int),
+			foreign_name	:: string,
+			context		:: prog_context
+		).
+
+:- implementation.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- interface.
+
 	%
 	% A table that records all the assertions in the system.
 	% An assertion is a goal that will always evaluate to true,
Index: 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
--- hlds_module.m	2001/05/03 13:04:24	1.65.4.1
+++ hlds_module.m	2001/05/23 13:02:21
@@ -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: make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.368.2.6
diff -u -r1.368.2.6 make_hlds.m
--- make_hlds.m	2001/05/18 14:24:32	1.368.2.6
+++ make_hlds.m	2001/05/23 13:02:24
@@ -417,6 +417,15 @@
 		{ Module = Module0 }
 	;	
 		% XXXX
+		{ Pragma = foreign_class(Instance, Type, Constructors, Name) },
+		{ module_info_foreign_classes(Module0, ForeignClasses0) },
+		{ map__det_insert(ForeignClasses0, Name,
+				foreign_class(Instance, Type,
+				Constructors, Name, Context), ForeignClasses) },
+		{ module_info_set_foreign_classes(Module0,
+				ForeignClasses, Module) }
+	;	
+		% XXXX
 		{ Pragma = foreign_type(MercuryType, _, ForeignType,
 				ForeignTypeLocation) },
 		{ module_info_types(Module0, Types0) },
Index: mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.184.2.6
diff -u -r1.184.2.6 mercury_to_mercury.m
--- mercury_to_mercury.m	2001/05/18 14:24:44	1.184.2.6
+++ mercury_to_mercury.m	2001/05/23 13:02:24
@@ -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: ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.80.2.8
diff -u -r1.80.2.8 ml_code_gen.m
--- ml_code_gen.m	2001/05/18 14:24:49	1.80.2.8
+++ ml_code_gen.m	2001/05/23 13:02:25
@@ -769,6 +769,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
@@ -834,7 +835,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: mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.15.4.17
diff -u -r1.15.4.17 mlds_to_il.m
--- mlds_to_il.m	2001/05/18 14:25:06	1.15.4.17
+++ mlds_to_il.m	2001/05/23 13:02:27
@@ -543,9 +543,37 @@
 		)
 	; { 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, Defns) },
+			list__map_foldl(defn_to_class_decl, Defns, ILDefns),
+			{
+				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 = [] }
 	).
Index: 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
--- module_qual.m	2001/05/18 14:25:11	1.65.2.5
+++ module_qual.m	2001/05/23 13:02:28
@@ -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: modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.158.2.6
diff -u -r1.158.2.6 modules.m
--- modules.m	2001/05/18 14:25:16	1.158.2.6
+++ modules.m	2001/05/23 13:02:30
@@ -1029,6 +1029,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: 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
--- prog_data.m	2001/05/18 14:25:24	1.65.2.5
+++ prog_data.m	2001/05/23 13:02:30
@@ -159,6 +159,10 @@
 			% PredName, Predicate or Function, Vars/Mode, 
 			% VarNames, Foreign Code Implementation Info
 
+	;	foreign_class(sym_name, (type), list(int), string)
+			% Instance name, instance argument type,
+			% list of constructors, foreign name
+
 	;	foreign_type((type), sym_name, sym_name, string)
 			% MercuryType, MercuryTypeName, ForeignType,
 			% ForeignTypeLocation
Index: 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
--- prog_io_pragma.m	2001/05/18 14:25:26	1.30.2.3
+++ prog_io_pragma.m	2001/05/23 13:02:30
@@ -70,6 +70,56 @@
 			ErrorTerm)
 	).
 
+parse_pragma_type(ModuleName, "foreign_class", PragmaTerms,
+            ErrorTerm, _VarSet, Result) :-
+	% XXX Handle ConstructorListTerm
+    ( 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),
+			    Result = ok(pragma(foreign_class(InstanceSymName,
+			    		MercuryType, [], ForeignNameStr)))
+			    		
+			;
+			    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: 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
--- unify_proc.m	2001/04/11 11:16:26	1.92.4.2
+++ unify_proc.m	2001/05/23 13:02:32
@@ -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,

Index: ml_foreign_class.m
===================================================================
%-----------------------------------------------------------------------------%
% 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 hlds_data, prog_data, type_util.
:- import_module 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, Members) :-
	Kind = mlds__class,
	Imports = [],

	Inherits = [foreign_type_to_inherit_from(ModuleInfo, ForeignClass)],

	Implements = [],
	Members = [internal_state_of_class(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
		).
	
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to:       mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions:          mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------



More information about the developers mailing list