[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