[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