[m-rev.] for review: merge foreign_type pragma on to the main branch
Peter Ross
peter.ross at miscrit.be
Tue Oct 23 00:32:16 AEST 2001
Hi,
For Tyson to review.
Tyson can you fix up the documentation for this change I know that you
will write it much better than me.
Also how should we handle the compare and unify predicates for foreign
types? I have left some XXXs in this diff where we generate the code
for compare and unify.
===================================================================
Estimated hours taken: 8
Branches: main
Merge the foreign_type pragma changes from the dotnet branch to the main
branch.
compiler/prog_data.m:
Add a type to hold the data from parsing a pragma foreign_type decl.
compiler/prog_io_pragma.m:
Parse the pragma foreign_type.
compiler/hlds_data.m:
Add a new alternative to hlds_type_body where the body of the type
is a foreign type.
compiler/make_hlds.m:
Place the foreign_type pragmas into the HLDS.
compiler/export.m:
Change export__type_to_type_string so that we return the
foreign type representation if it exists.
compiler/llds.m:
Since export__type_to_type_string needs a module_info, we add a new
field to pragma_c_arg_decl which is the result of calling
export__type_to_type_string. This avoids threading the module_info
around various llds passes.
compiler/mlds.m:
Table the result of export__type_to_type_string so as to avoid
passing the module_info around the MLDS backend.
Also add the foreign_type alternative to mlds__type.
Update mercury_type_to_mlds_type so that handles types which are
foreign types.
compiler/mlds_to_il.m:
Convert a mlds__foreign_type into an ilds__type. Note that the
basic types aren't allowed to appear in the assembler in their
System.* form so we detect all these cases and convert to the basic
type instead.
compiler/ilds.m:
The CLR spec requires that System.Object and System.String be
treated specially in the IL assembly (you have to use the name
object and string instead of the System.* names), so add them as
base types.
compiler/ilasm.m:
Changes to handle the additions to the simple ilds types.
doc/reference_manual.texi:
Document the new pragma.
compiler/fact_table.m:
compiler/llds_out.m:
compiler/ml_code_gen.m:
compiler/ml_code_util.m:
compiler/ml_simplify_switch.m:
compiler/ml_switch_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds_to_c.m:
compiler/mlds_to_csharp.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_java.m:
compiler/mlds_to_mcpp.m:
compiler/pragma_c_gen.m:
compiler/rtti_to_mlds.m:
Changes to handle the tabling of calls to export__type_to_string.
compiler/hlds_out.m:
compiler/intermod.m:
compiler/magic_util.m:
compiler/ml_type_gen.m:
compiler/recompilation_usage.m:
compiler/recompilation_version.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/unify_proc.m:
Changes to hanlde the new hlds_type_body.
compiler/mercury_to_mercury.m:
Output the pragma foreign_type declaration.
compiler/module_qual.m:
Qualify the pragma foreign_type declarations.
compiler/modules.m:
Pragma foreign_type is allowed in the interface.
Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.48
diff -u -r1.48 export.m
--- compiler/export.m 16 Jul 2001 08:09:58 -0000 1.48
+++ compiler/export.m 22 Oct 2001 14:05:18 -0000
@@ -50,8 +50,8 @@
% Convert the type to a string corresponding to its C type.
% (Defaults to MR_Word).
-:- pred export__type_to_type_string(type, string).
-:- mode export__type_to_type_string(in, out) is det.
+:- pred export__type_to_type_string(module_info, type, string).
+:- mode export__type_to_type_string(in, in, out) is det.
% Generate C code to convert an rval (represented as a string), from
% a C type to a mercury C type (ie. convert strings and floats to
@@ -71,7 +71,7 @@
:- implementation.
:- import_module modules.
-:- import_module hlds_pred, type_util.
+:- import_module hlds_data, hlds_pred, type_util.
:- import_module code_model.
:- import_module code_gen, code_util, llds_out.
:- import_module globals, options.
@@ -88,23 +88,24 @@
module_info_get_pragma_exported_procs(HLDS, ExportedProcs),
module_info_globals(HLDS, Globals),
export__get_foreign_export_decls_2(Preds, ExportedProcs, Globals,
- C_ExportDecls).
+ HLDS, C_ExportDecls).
:- pred export__get_foreign_export_decls_2(pred_table,
- list(pragma_exported_proc), globals, list(foreign_export_decl)).
-:- mode export__get_foreign_export_decls_2(in, in, in, out) is det.
+ list(pragma_exported_proc), globals,
+ module_info, list(foreign_export_decl)).
+:- mode export__get_foreign_export_decls_2(in, in, in, in, out) is det.
-export__get_foreign_export_decls_2(_Preds, [], _, []).
-export__get_foreign_export_decls_2(Preds, [E|ExportedProcs], Globals,
+export__get_foreign_export_decls_2(_Preds, [], _, _, []).
+export__get_foreign_export_decls_2(Preds, [E|ExportedProcs], Globals, Module,
C_ExportDecls) :-
E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
- get_export_info(Preds, PredId, ProcId, Globals, _HowToDeclare,
+ get_export_info(Preds, PredId, ProcId, Globals, Module, _HowToDeclare,
C_RetType, _DeclareReturnVal, _FailureAction, _SuccessAction,
HeadArgInfoTypes),
- get_argument_declarations(HeadArgInfoTypes, no, ArgDecls),
+ get_argument_declarations(HeadArgInfoTypes, no, Module, ArgDecls),
C_ExportDecl = foreign_export_decl(c, C_RetType, C_Function, ArgDecls),
export__get_foreign_export_decls_2(Preds, ExportedProcs, Globals,
- C_ExportDecls0),
+ Module, C_ExportDecls0),
C_ExportDecls = [C_ExportDecl | C_ExportDecls0].
%-----------------------------------------------------------------------------%
@@ -216,10 +217,10 @@
export__to_c(Preds, [E|ExportedProcs], Module, ExportedProcsCode) :-
E = pragma_exported_proc(PredId, ProcId, C_Function, _Ctxt),
module_info_globals(Module, Globals),
- get_export_info(Preds, PredId, ProcId, Globals, DeclareString,
+ get_export_info(Preds, PredId, ProcId, Globals, Module, DeclareString,
C_RetType, MaybeDeclareRetval, MaybeFail, MaybeSucceed,
ArgInfoTypes),
- get_argument_declarations(ArgInfoTypes, yes, ArgDecls),
+ get_argument_declarations(ArgInfoTypes, yes, Module, ArgDecls),
% work out which arguments are input, and which are output,
% and copy to/from the mercury registers.
@@ -293,13 +294,15 @@
% - the actions on success and failure, and
% - the argument locations/modes/types.
-:- pred get_export_info(pred_table, pred_id, proc_id, globals,
+:- pred get_export_info(pred_table, pred_id, proc_id, globals, module_info,
string, string, string, string, string,
assoc_list(arg_info, type)).
-:- mode get_export_info(in, in, in, in, out, out, out, out, out, out) is det.
+:- mode get_export_info(in, in, in, in, in,
+ out, out, out, out, out, out) is det.
-get_export_info(Preds, PredId, ProcId, Globals, HowToDeclareLabel, C_RetType,
- MaybeDeclareRetval, MaybeFail, MaybeSucceed, ArgInfoTypes) :-
+get_export_info(Preds, PredId, ProcId, Globals, Module,
+ HowToDeclareLabel, C_RetType, MaybeDeclareRetval,
+ MaybeFail, MaybeSucceed, ArgInfoTypes) :-
map__lookup(Preds, PredId, PredInfo),
pred_info_import_status(PredInfo, Status),
(
@@ -333,7 +336,7 @@
RetArgMode = top_out,
\+ type_util__is_dummy_argument_type(RetType)
->
- export__type_to_type_string(RetType, C_RetType),
+ export__type_to_type_string(Module, RetType, C_RetType),
argloc_to_string(RetArgLoc, RetArgString0),
convert_type_from_mercury(RetArgString0, RetType,
RetArgString),
@@ -391,37 +394,41 @@
% build a string to declare the argument types (and if
% NameThem = yes, the argument names) of a C function.
-:- pred get_argument_declarations(assoc_list(arg_info, type), bool, string).
-:- mode get_argument_declarations(in, in, out) is det.
-
-get_argument_declarations([], _, "void").
-get_argument_declarations([X|Xs], NameThem, Result) :-
- get_argument_declarations_2([X|Xs], 0, NameThem, Result).
+:- pred get_argument_declarations(assoc_list(arg_info, type), bool,
+ module_info, string).
+:- mode get_argument_declarations(in, in, in, out) is det.
+
+get_argument_declarations([], _, _, "void").
+get_argument_declarations([X|Xs], NameThem, Module, Result) :-
+ get_argument_declarations_2([X|Xs], 0, NameThem, Module, Result).
:- pred get_argument_declarations_2(assoc_list(arg_info, type), int, bool,
- string).
-:- mode get_argument_declarations_2(in, in, in, out) is det.
+ module_info, string).
+:- mode get_argument_declarations_2(in, in, in, in, out) is det.
-get_argument_declarations_2([], _, _, "").
-get_argument_declarations_2([AT|ATs], Num0, NameThem, Result) :-
+get_argument_declarations_2([], _, _, _, "").
+get_argument_declarations_2([AT|ATs], Num0, NameThem, Module, Result) :-
AT = ArgInfo - Type,
Num is Num0 + 1,
- get_argument_declaration(ArgInfo, Type, Num, NameThem,
+ get_argument_declaration(ArgInfo, Type, Num, NameThem, Module,
TypeString, ArgName),
(
ATs = []
->
string__append(TypeString, ArgName, Result)
;
- get_argument_declarations_2(ATs, Num, NameThem, TheRest),
+ get_argument_declarations_2(ATs, Num, NameThem, Module,
+ TheRest),
string__append_list([TypeString, ArgName, ", ", TheRest],
Result)
).
-:- pred get_argument_declaration(arg_info, type, int, bool, string, string).
-:- mode get_argument_declaration(in, in, in, in, out, out) is det.
+:- pred get_argument_declaration(arg_info, type, int, bool, module_info,
+ string, string).
+:- mode get_argument_declaration(in, in, in, in, in, out, out) is det.
-get_argument_declaration(ArgInfo, Type, Num, NameThem, TypeString, ArgName) :-
+get_argument_declaration(ArgInfo, Type, Num, NameThem, Module,
+ TypeString, ArgName) :-
ArgInfo = arg_info(_Loc, Mode),
( NameThem = yes ->
string__int_to_string(Num, NumString),
@@ -429,7 +436,7 @@
;
ArgName = ""
),
- export__type_to_type_string(Type, TypeString0),
+ export__type_to_type_string(Module, Type, TypeString0),
(
Mode = top_out
->
@@ -626,7 +633,7 @@
% Convert a term representation of a variable type to a string which
% represents the C type of the variable
% Apart from special cases, local variables become MR_Words
-export__type_to_type_string(Type, Result) :-
+export__type_to_type_string(ModuleInfo, Type, Result) :-
( Type = term__functor(term__atom("int"), [], _) ->
Result = "MR_Integer"
; Type = term__functor(term__atom("float"), [], _) ->
@@ -636,7 +643,28 @@
; Type = term__functor(term__atom("character"), [], _) ->
Result = "MR_Char"
;
- Result = "MR_Word"
+ module_info_types(ModuleInfo, Types),
+ (
+ type_to_type_id(Type, TypeId, _),
+ map__search(Types, TypeId, TypeDefn)
+ ->
+ % XXX how we output the type depends on
+ % which foreign language we are using.
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+ ( Body = foreign_type(ForeignType, _) ->
+ Result = sym_name_to_string(ForeignType) ++ " *"
+ ;
+ Result = "MR_Word"
+ )
+ ;
+ Result = "MR_Word"
+ )
).
+
+:- func sym_name_to_string(sym_name) = string.
+
+sym_name_to_string(unqualified(Name)) = Name.
+sym_name_to_string(qualified(ModuleSpec, Name))
+ = sym_name_to_string(ModuleSpec) ++ ("::" ++ Name).
%-----------------------------------------------------------------------------%
Index: compiler/fact_table.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/fact_table.m,v
retrieving revision 1.39
diff -u -r1.39 fact_table.m
--- compiler/fact_table.m 20 Feb 2001 14:08:33 -0000 1.39
+++ compiler/fact_table.m 22 Oct 2001 14:05:19 -0000
@@ -3188,16 +3188,17 @@
list__map(lambda([X::in, Y::out] is det, X = pragma_var(_,_,Y)),
PragmaVars, Modes),
make_arg_infos(Types, Modes, model_non, ModuleInfo, ArgInfos),
- generate_argument_vars_code_2(PragmaVars, ArgInfos, Types, DeclCode,
- InputCode, OutputCode, SaveRegsCode, GetRegsCode, 1,
+ generate_argument_vars_code_2(PragmaVars, ArgInfos, Types, ModuleInfo,
+ DeclCode, InputCode, OutputCode, SaveRegsCode, GetRegsCode, 1,
NumInputArgs).
:- pred generate_argument_vars_code_2(list(pragma_var), list(arg_info),
- list(type), string, string, string, string, string, int, int).
-:- mode generate_argument_vars_code_2(in, in, in, out, out, out, out, out,
+ list(type), module_info, string,
+ string, string, string, string, int, int).
+:- mode generate_argument_vars_code_2(in, in, in, in, out, out, out, out, out,
in, out) is det.
-generate_argument_vars_code_2(PragmaVars0, ArgInfos0, Types0, DeclCode,
+generate_argument_vars_code_2(PragmaVars0, ArgInfos0, Types0, Module, DeclCode,
InputCode, OutputCode, SaveRegsCode, GetRegsCode,
NumInputArgs0, NumInputArgs) :-
(
@@ -3216,7 +3217,7 @@
ArgInfos0 = [arg_info(Loc, ArgMode) | ArgInfos],
Types0 = [Type | Types]
->
- generate_arg_decl_code(VarName, Type, DeclCode0),
+ generate_arg_decl_code(VarName, Type, Module, DeclCode0),
( ArgMode = top_in ->
NumInputArgs1 is NumInputArgs0 + 1,
generate_arg_input_code(VarName, Type, Loc,
@@ -3234,8 +3235,9 @@
error("generate_argument_vars_code: invalid mode")
),
generate_argument_vars_code_2(PragmaVars, ArgInfos, Types,
- DeclCode1, InputCode1, OutputCode1, SaveRegsCode1,
- GetRegsCode1, NumInputArgs1, NumInputArgs),
+ Module, DeclCode1, InputCode1, OutputCode1,
+ SaveRegsCode1, GetRegsCode1, NumInputArgs1,
+ NumInputArgs),
string__append(DeclCode0, DeclCode1, DeclCode),
string__append(InputCode0, InputCode1, InputCode),
string__append(OutputCode0, OutputCode1, OutputCode),
@@ -3245,10 +3247,11 @@
error("generate_argument_vars_code: list length mismatch")
).
-:- pred generate_arg_decl_code(string::in, (type)::in, string::out) is det.
+:- pred generate_arg_decl_code(string::in, (type)::in, module_info::in,
+ string::out) is det.
-generate_arg_decl_code(Name, Type, DeclCode) :-
- export__type_to_type_string(Type, C_Type),
+generate_arg_decl_code(Name, Type, Module, DeclCode) :-
+ export__type_to_type_string(Module, Type, C_Type),
string__format("\t\t%s %s;\n", [s(C_Type), s(Name)], DeclCode).
:- pred generate_arg_input_code(string::in, (type)::in, int::in, int::in,
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.56
diff -u -r1.56 hlds_data.m
--- compiler/hlds_data.m 10 Jul 2001 10:45:22 -0000 1.56
+++ compiler/hlds_data.m 22 Oct 2001 14:05:19 -0000
@@ -291,6 +291,12 @@
)
; uu_type(list(type)) % not yet implemented!
; eqv_type(type)
+ ; foreign_type(
+ sym_name, % structured name of foreign type
+ % which represents the mercury type.
+ string % String which represents where I can
+ % find a definition for this type.
+ )
; abstract_type.
% The `cons_tag_values' type stores the information on how
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.269
diff -u -r1.269 hlds_out.m
--- compiler/hlds_out.m 18 Aug 2001 11:33:45 -0000 1.269
+++ compiler/hlds_out.m 22 Oct 2001 14:05:21 -0000
@@ -2663,6 +2663,9 @@
hlds_out__write_type_body(_Indent, _Tvarset, abstract_type) -->
io__write_string(".\n").
+hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_, _)) -->
+ { error("hlds_out__write_type_body: foreign type body found") }.
+
:- pred hlds_out__write_constructors(int, tvarset, list(constructor),
io__state, io__state).
:- mode hlds_out__write_constructors(in, in, in, di, uo) is det.
Index: compiler/ilasm.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ilasm.m,v
retrieving revision 1.24
diff -u -r1.24 ilasm.m
--- compiler/ilasm.m 17 Oct 2001 05:10:27 -0000 1.24
+++ compiler/ilasm.m 22 Oct 2001 14:05:22 -0000
@@ -697,6 +697,8 @@
output_simple_type(native_float, I, I) --> io__write_string("native float").
output_simple_type(bool, I, I) --> io__write_string("bool").
output_simple_type(char, I, I) --> io__write_string("char").
+output_simple_type(object, I, I) --> io__write_string("object").
+output_simple_type(string, I, I) --> io__write_string("string").
output_simple_type(refany, I, I) --> io__write_string("refany").
output_simple_type(class(Name), Info0, Info) -->
io__write_string("class "),
@@ -742,6 +744,8 @@
% all reference types use "ref" as their opcode.
% XXX is "ref" here correct for value classes?
+output_simple_type_opcode(object) --> io__write_string("ref").
+output_simple_type_opcode(string) --> io__write_string("ref").
output_simple_type_opcode(refany) --> io__write_string("ref").
output_simple_type_opcode(class(_Name)) --> io__write_string("ref").
output_simple_type_opcode(value_class(_Name)) --> io__write_string("ref").
Index: compiler/ilds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ilds.m,v
retrieving revision 1.11
diff -u -r1.11 ilds.m
--- compiler/ilds.m 22 Aug 2001 10:22:14 -0000 1.11
+++ compiler/ilds.m 22 Oct 2001 14:05:22 -0000
@@ -169,6 +169,8 @@
; native_float
; bool
; char % A unicode character.
+ ; object
+ ; string
; refany % a reference to value with an attached
% type
; class(class_name)
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.107
diff -u -r1.107 intermod.m
--- compiler/intermod.m 18 Aug 2001 11:33:47 -0000 1.107
+++ compiler/intermod.m 22 Oct 2001 14:05:23 -0000
@@ -1175,6 +1175,9 @@
;
{ Body = abstract_type },
{ TypeBody = abstract_type }
+ ;
+ { Body = foreign_type(_, _) },
+ { error("foreign types not implemented") }
),
mercury_output_item(type_defn(VarSet, Name, Args, TypeBody, true),
Context).
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.278
diff -u -r1.278 llds.m
--- compiler/llds.m 8 Jul 2001 16:40:05 -0000 1.278
+++ compiler/llds.m 22 Oct 2001 14:05:23 -0000
@@ -557,6 +557,8 @@
---> pragma_c_arg_decl(
% This local variable corresponds to a procedure arg.
type, % The Mercury type of the argument.
+ string, % The string which is used to describe the
+ % type in the C code.
string % The name of the local variable that
% will hold the value of that argument
% inside the C block.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.180
diff -u -r1.180 llds_out.m
--- compiler/llds_out.m 25 Sep 2001 09:36:50 -0000 1.180
+++ compiler/llds_out.m 22 Oct 2001 14:05:25 -0000
@@ -1915,11 +1915,10 @@
output_pragma_decls([]) --> [].
output_pragma_decls([D|Decls]) -->
(
- { D = pragma_c_arg_decl(Type, VarName) },
% Apart from special cases, the local variables are MR_Words
- { export__type_to_type_string(Type, VarType) },
+ { D = pragma_c_arg_decl(_Type, TypeString, VarName) },
io__write_string("\t"),
- io__write_string(VarType),
+ io__write_string(TypeString),
io__write_string("\t"),
io__write_string(VarName),
io__write_string(";\n")
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.14
diff -u -r1.14 magic_util.m
--- compiler/magic_util.m 27 Jun 2001 05:04:09 -0000 1.14
+++ compiler/magic_util.m 22 Oct 2001 14:05:25 -0000
@@ -1379,6 +1379,8 @@
{ error("magic_util__check_type_defn: eqv_type") }.
magic_util__check_type_defn(abstract_type, _, Errors0, Errors) -->
{ set__insert(Errors0, abstract, Errors) }.
+magic_util__check_type_defn(foreign_type(_, _), _, _, _) -->
+ { error("magic_util__check_type_defn: foreign_type") }.
:- pred magic_util__check_ctor(set(type_id)::in, constructor::in,
set(argument_error)::in, set(argument_error)::out,
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.385
diff -u -r1.385 make_hlds.m
--- compiler/make_hlds.m 9 Oct 2001 03:50:18 -0000 1.385
+++ compiler/make_hlds.m 22 Oct 2001 14:05:28 -0000
@@ -391,6 +391,19 @@
{ Pragma = foreign_proc(_, _, _, _, _, _) },
{ Module = Module0 }
;
+ { Pragma = foreign_type(Backend, _MercuryType, Name,
+ ForeignType) },
+
+ { Backend = il(ForeignTypeLocation) },
+
+ { varset__init(VarSet) },
+ { Args = [] },
+ { Body = foreign_type(ForeignType, ForeignTypeLocation) },
+ { Cond = true },
+
+ module_add_type_defn_2(Module0, VarSet, Name, Args, Body,
+ Cond, Context, Status, Module)
+ ;
% Handle pragma tabled decls later on (when we process
% clauses).
{ Pragma = tabled(_, _, _, _, _) },
@@ -1784,11 +1797,23 @@
:- mode module_add_type_defn(in, in, in, in, in,
in, in, in, out, di, uo) is det.
-module_add_type_defn(Module0, TVarSet, Name, Args, TypeDefn, _Cond, Context,
+module_add_type_defn(Module0, TVarSet, Name, Args, TypeDefn, Cond, Context,
item_status(Status0, NeedQual), Module) -->
- { module_info_types(Module0, Types0) },
globals__io_get_globals(Globals),
{ convert_type_defn(TypeDefn, Globals, Body) },
+ module_add_type_defn_2(Module0, TVarSet, Name, Args, Body, Cond,
+ Context, item_status(Status0, NeedQual), Module).
+
+:- pred module_add_type_defn_2(module_info, tvarset, sym_name, list(type_param),
+ hlds_type_body, condition, prog_context, item_status,
+ module_info, io__state, io__state).
+:- mode module_add_type_defn_2(in, in, in, in, in,
+ in, in, in, out, di, uo) is det.
+
+module_add_type_defn_2(Module0, TVarSet, Name, Args, Body, _Cond, Context,
+ item_status(Status0, NeedQual), Module) -->
+ { module_info_types(Module0, Types0) },
+ globals__io_get_globals(Globals),
{ list__length(Args, Arity) },
{ TypeId = Name - Arity },
{ Body = abstract_type ->
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.193
diff -u -r1.193 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 25 Sep 2001 09:36:51 -0000 1.193
+++ compiler/mercury_to_mercury.m 22 Oct 2001 14:05:29 -0000
@@ -459,6 +459,20 @@
mercury_output_pragma_foreign_code(Attributes, Pred,
PredOrFunc, Vars, VarSet, PragmaCode)
;
+ { Pragma = foreign_type(Backend, _MercuryType,
+ MercuryTypeSymName, ForeignType) },
+ io__write_string(":- pragma foreign_type("),
+ % output_type(varset__init, no, MercuryType),
+ mercury_output_sym_name(MercuryTypeSymName),
+ io__write_string(", "),
+ mercury_output_sym_name(ForeignType),
+ io__write_string(", "),
+
+ { Backend = il(ForeignLocStr) },
+ io__write_string("il(\""),
+ io__write_string(ForeignLocStr),
+ io__write_string("\").\n")
+ ;
{ Pragma = import(Pred, PredOrFunc, ModeList, Attributes,
C_Function) },
mercury_format_pragma_import(Pred, PredOrFunc, ModeList,
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.101
diff -u -r1.101 ml_code_gen.m
--- compiler/ml_code_gen.m 17 Oct 2001 05:10:28 -0000 1.101
+++ compiler/ml_code_gen.m 22 Oct 2001 14:05:30 -0000
@@ -2767,11 +2767,14 @@
ml_gen_pragma_c_decl(Lang, ml_c_arg(_Var, MaybeNameAndMode, Type),
Decl) -->
+ =(MLDSGenInfo),
+ { ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
{
MaybeNameAndMode = yes(ArgName - _Mode),
\+ var_is_singleton(ArgName)
->
- TypeString = foreign_type_to_type_string(Lang, Type),
+ TypeString = foreign_type_to_type_string(ModuleInfo,
+ Lang, Type),
string__format("\t%s %s;\n", [s(TypeString), s(ArgName)],
DeclString)
;
@@ -2781,15 +2784,16 @@
},
{ Decl = raw_target_code(DeclString, []) }.
-:- func foreign_type_to_type_string(foreign_language, prog_data__type) = string.
-foreign_type_to_type_string(Lang, Type) = TypeString :-
+:- func foreign_type_to_type_string(module_info,
+ foreign_language, prog_data__type) = string.
+foreign_type_to_type_string(ModuleInfo, Lang, Type) = TypeString :-
(
type_util__var(Type, _),
Lang = managed_cplusplus
->
TypeString = "MR_Box"
;
- export__type_to_type_string(Type, TypeString)
+ export__type_to_type_string(ModuleInfo, Type, TypeString)
).
%-----------------------------------------------------------------------------%
@@ -2859,8 +2863,8 @@
% --high-level-data, so we always use a cast here.
% (Strictly speaking the cast is not needed for
% a few cases like `int', but it doesn't do any harm.)
- TypeString = foreign_type_to_type_string(Lang,
- OrigType),
+ TypeString = foreign_type_to_type_string(ModuleInfo,
+ Lang, OrigType),
string__format("(%s)", [s(TypeString)], Cast)
;
% For --no-high-level-data, we only need to use
@@ -2946,8 +2950,8 @@
% Note that we can't easily obtain the type string
% for the RHS of the assignment, so instead we
% cast the LHS.
- TypeString = foreign_type_to_type_string(Lang,
- OrigType),
+ TypeString = foreign_type_to_type_string(ModuleInfo,
+ Lang, OrigType),
string__format("*(%s *)&", [s(TypeString)], LHS_Cast),
RHS_Cast = ""
;
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.44
diff -u -r1.44 ml_code_util.m
--- compiler/ml_code_util.m 24 Aug 2001 15:44:51 -0000 1.44
+++ compiler/ml_code_util.m 22 Oct 2001 14:05:31 -0000
@@ -956,7 +956,7 @@
ml_gen_array_elem_type(elem_type_int) = mlds__native_int_type.
ml_gen_array_elem_type(elem_type_generic) = mlds__generic_type.
-ml_string_type = mercury_type(string_type, str_type).
+ml_string_type = mercury_type(string_type, str_type, "MR_String").
%-----------------------------------------------------------------------------%
%
Index: compiler/ml_simplify_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_simplify_switch.m,v
retrieving revision 1.2
diff -u -r1.2 ml_simplify_switch.m
--- compiler/ml_simplify_switch.m 20 Jan 2001 15:42:47 -0000 1.2
+++ compiler/ml_simplify_switch.m 22 Oct 2001 14:05:31 -0000
@@ -100,9 +100,9 @@
:- pred is_integral_type(mlds__type::in) is semidet.
is_integral_type(mlds__native_int_type).
is_integral_type(mlds__native_char_type).
-is_integral_type(mlds__mercury_type(_, int_type)).
-is_integral_type(mlds__mercury_type(_, char_type)).
-is_integral_type(mlds__mercury_type(_, enum_type)).
+is_integral_type(mlds__mercury_type(_, int_type, _)).
+is_integral_type(mlds__mercury_type(_, char_type, _)).
+is_integral_type(mlds__mercury_type(_, enum_type, _)).
:- pred is_dense_switch(list(mlds__switch_case)::in, int::in) is semidet.
is_dense_switch(Cases, ReqDensity) :-
Index: compiler/ml_switch_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_switch_gen.m,v
retrieving revision 1.7
diff -u -r1.7 ml_switch_gen.m
--- compiler/ml_switch_gen.m 10 Jan 2001 11:15:32 -0000 1.7
+++ compiler/ml_switch_gen.m 22 Oct 2001 14:05:31 -0000
@@ -1,5 +1,5 @@
%-----------------------------------------------------------------------------%
-% Copyright (C) 1994-2000 The University of Melbourne.
+% Copyright (C) 1994-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.
%-----------------------------------------------------------------------------%
@@ -99,7 +99,7 @@
:- import_module ml_tag_switch, ml_string_switch.
:- import_module ml_code_gen, ml_unify_gen, ml_code_util, ml_simplify_switch.
:- import_module switch_util, type_util.
-:- import_module options.
+:- import_module export, options.
:- import_module bool, int, string, map, tree, std_util, require.
@@ -395,8 +395,9 @@
ml_switch_gen_range(MLDS_Type, Range) -->
=(MLGenInfo),
{
- MLDS_Type = mercury_type(Type, TypeCategory),
ml_gen_info_get_module_info(MLGenInfo, ModuleInfo),
+ export__type_to_type_string(ModuleInfo, Type, TypeString),
+ MLDS_Type = mercury_type(Type, TypeCategory, TypeString),
switch_util__type_range(TypeCategory, Type, ModuleInfo,
MinRange, MaxRange)
->
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.13
diff -u -r1.13 ml_type_gen.m
--- compiler/ml_type_gen.m 24 Aug 2001 15:44:52 -0000 1.13
+++ compiler/ml_type_gen.m 22 Oct 2001 14:05:32 -0000
@@ -115,6 +115,9 @@
ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn,
Ctors, TagValues, MaybeEqualityMembers)
).
+ % XXX Fixme!
+ml_gen_type_2(foreign_type(_, _), _, _, _) -->
+ { error("sorry, foreign types not implemented") }.
%-----------------------------------------------------------------------------%
%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.40
diff -u -r1.40 ml_unify_gen.m
--- compiler/ml_unify_gen.m 12 Aug 2001 23:01:16 -0000 1.40
+++ compiler/ml_unify_gen.m 22 Oct 2001 14:05:32 -0000
@@ -1144,7 +1144,7 @@
ml_gen_box_const_rval(Type, Rval, Context, ConstDefns, BoxedRval) -->
(
- { Type = mercury_type(term__variable(_), _)
+ { Type = mercury_type(term__variable(_), _, _)
; Type = mlds__generic_type
}
->
@@ -1159,7 +1159,7 @@
% but calls to malloc() are not).
%
{ Type = mercury_type(term__functor(term__atom("float"),
- [], _), _)
+ [], _), _, _)
; Type = mlds__native_float_type
}
->
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.70
diff -u -r1.70 mlds.m
--- compiler/mlds.m 24 Aug 2001 15:44:53 -0000 1.70
+++ compiler/mlds.m 22 Oct 2001 14:05:33 -0000
@@ -535,8 +535,10 @@
---> % Mercury data types
mercury_type(
prog_data__type, % the exact Mercury type
- builtin_type % what kind of type it is:
+ builtin_type, % what kind of type it is:
% enum, float, etc.
+ string % the result of
+ % export__type_to_type_string
)
% The Mercury array type is treated specially, some backends
@@ -588,6 +590,10 @@
; mlds__native_float_type
; mlds__native_char_type
+ % This is a type of the MLDS target language. Currently
+ % this is only used by the il backend.
+ ; mlds__foreign_type(sym_name, string)
+
% MLDS types defined using mlds__class_defn
; mlds__class_type(
mlds__class, % name
@@ -1502,7 +1508,7 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module modules.
+:- import_module export, modules.
:- import_module int, term, string, require.
%-----------------------------------------------------------------------------%
@@ -1536,8 +1542,17 @@
MLDSElemType = mercury_type_to_mlds_type(ModuleInfo, ElemType),
MLDSType = mlds__mercury_array_type(MLDSElemType)
;
+ type_to_type_id(Type, TypeId, _),
+ module_info_types(ModuleInfo, Types),
+ map__search(Types, TypeId, TypeDefn),
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+ Body = foreign_type(ForeignType, ForeignLocation)
+ ->
+ MLDSType = mlds__foreign_type(ForeignType, ForeignLocation)
+ ;
classify_type(Type, ModuleInfo, Category),
- MLDSType = mercury_type(Type, Category)
+ export__type_to_type_string(ModuleInfo, Type, TypeString),
+ MLDSType = mercury_type(Type, Category, TypeString)
).
%-----------------------------------------------------------------------------%
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.103
diff -u -r1.103 mlds_to_c.m
--- compiler/mlds_to_c.m 24 Aug 2001 15:44:53 -0000 1.103
+++ compiler/mlds_to_c.m 22 Oct 2001 14:05:34 -0000
@@ -622,9 +622,8 @@
% Array types are exported as MR_Word
mlds_output_pragma_export_type(prefix, mercury_array_type(_ElemType)) -->
io__write_string("MR_Word").
-mlds_output_pragma_export_type(prefix, mercury_type(Type, _)) -->
- { export__type_to_type_string(Type, String) },
- io__write_string(String).
+mlds_output_pragma_export_type(prefix, mercury_type(_, _, TypeString)) -->
+ io__write_string(TypeString).
mlds_output_pragma_export_type(prefix, mlds__cont_type(_)) -->
io__write_string("MR_Word").
mlds_output_pragma_export_type(prefix, mlds__commit_type) -->
@@ -637,6 +636,8 @@
io__write_string("MR_Float").
mlds_output_pragma_export_type(prefix, mlds__native_char_type) -->
io__write_string("MR_Char").
+mlds_output_pragma_export_type(prefix, mlds__foreign_type(_, _)) -->
+ { error("mlds_output_pragma_export_type: foreign_type") }.
mlds_output_pragma_export_type(prefix, mlds__class_type(_, _, _)) -->
io__write_string("MR_Word").
mlds_output_pragma_export_type(prefix, mlds__array_type(_)) -->
@@ -880,7 +881,7 @@
Kind \= mlds__enum,
ClassType = Type
;
- Type = mercury_type(MercuryType, user_type),
+ Type = mercury_type(MercuryType, user_type, _),
type_to_type_id(MercuryType, TypeId, _ArgsTypes),
ml_gen_type_name(TypeId, ClassName, ClassArity),
ClassType = mlds__class_type(ClassName, ClassArity,
@@ -1542,7 +1543,7 @@
:- pred mlds_output_type_prefix(mlds__type, io__state, io__state).
:- mode mlds_output_type_prefix(in, di, uo) is det.
-mlds_output_type_prefix(mercury_type(Type, TypeCategory)) -->
+mlds_output_type_prefix(mercury_type(Type, TypeCategory, _)) -->
mlds_output_mercury_type_prefix(Type, TypeCategory).
mlds_output_type_prefix(mercury_array_type(_ElemType)) -->
globals__io_lookup_bool_option(highlevel_data, HighLevelData),
@@ -1559,6 +1560,8 @@
mlds_output_type_prefix(mlds__native_float_type) --> io__write_string("float").
mlds_output_type_prefix(mlds__native_bool_type) --> io__write_string("bool").
mlds_output_type_prefix(mlds__native_char_type) --> io__write_string("char").
+mlds_output_type_prefix(mlds__foreign_type(_, _)) -->
+ { error("mlds_output_type_prefix: foreign_type") }.
mlds_output_type_prefix(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
%
@@ -1719,12 +1722,13 @@
io__state, io__state).
:- mode mlds_output_type_suffix(in, in, di, uo) is det.
-mlds_output_type_suffix(mercury_type(_, _), _) --> [].
+mlds_output_type_suffix(mercury_type(_, _, _), _) --> [].
mlds_output_type_suffix(mercury_array_type(_), _) --> [].
mlds_output_type_suffix(mlds__native_int_type, _) --> [].
mlds_output_type_suffix(mlds__native_float_type, _) --> [].
mlds_output_type_suffix(mlds__native_bool_type, _) --> [].
mlds_output_type_suffix(mlds__native_char_type, _) --> [].
+mlds_output_type_suffix(mlds__foreign_type(_, _), _) --> [].
mlds_output_type_suffix(mlds__class_type(_, _, _), _) --> [].
mlds_output_type_suffix(mlds__ptr_type(_), _) --> [].
mlds_output_type_suffix(mlds__array_type(_), ArraySize) -->
@@ -2611,7 +2615,7 @@
FieldType, _ClassType)) -->
(
{ FieldType = mlds__generic_type
- ; FieldType = mlds__mercury_type(term__variable(_), _)
+ ; FieldType = mlds__mercury_type(term__variable(_), _, _)
}
->
io__write_string("(")
@@ -2809,7 +2813,7 @@
mlds_output_boxed_rval(Type, InnerExprn)
;
{ Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _)
+ [], _), _, _)
; Type = mlds__native_float_type
}
->
@@ -2817,8 +2821,8 @@
mlds_output_rval(Exprn),
io__write_string(")")
;
- { Type = mlds__mercury_type(term__functor(term__atom("character"),
- [], _), _)
+ { Type = mlds__mercury_type(term__functor(
+ term__atom("character"), [], _), _, _)
; Type = mlds__native_char_type
; Type = mlds__native_bool_type
; Type = mlds__native_int_type
@@ -2842,7 +2846,7 @@
mlds_output_unboxed_rval(Type, Exprn) -->
(
{ Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _)
+ [], _), _, _)
; Type = mlds__native_float_type
}
->
@@ -2850,8 +2854,8 @@
mlds_output_rval(Exprn),
io__write_string(")")
;
- { Type = mlds__mercury_type(term__functor(term__atom("character"),
- [], _), _)
+ { Type = mlds__mercury_type(term__functor(
+ term__atom("character"), [], _), _, _)
; Type = mlds__native_char_type
; Type = mlds__native_bool_type
; Type = mlds__native_int_type
Index: compiler/mlds_to_csharp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_csharp.m,v
retrieving revision 1.17
diff -u -r1.17 mlds_to_csharp.m
--- compiler/mlds_to_csharp.m 17 Oct 2001 05:10:29 -0000 1.17
+++ compiler/mlds_to_csharp.m 22 Oct 2001 14:05:34 -0000
@@ -481,6 +481,10 @@
io__write_string("bool").
write_il_simple_type_as_csharp_type(char) -->
io__write_string("char").
+write_il_simple_type_as_csharp_type(string) -->
+ io__write_string("string").
+write_il_simple_type_as_csharp_type(object) -->
+ io__write_string("object").
write_il_simple_type_as_csharp_type(refany) -->
io__write_string("mercury.MR_RefAny").
write_il_simple_type_as_csharp_type(class(ClassName)) -->
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.51
diff -u -r1.51 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 24 Aug 2001 15:44:54 -0000 1.51
+++ compiler/mlds_to_gcc.m 22 Oct 2001 14:05:35 -0000
@@ -1677,8 +1677,10 @@
;
{ GCC_Type = 'MR_Word' }
).
-build_type(mercury_type(Type, TypeCategory), _, _, GCC_Type) -->
+build_type(mercury_type(Type, TypeCategory, _), _, _, GCC_Type) -->
build_mercury_type(Type, TypeCategory, GCC_Type).
+build_type(mlds__foreign_type(_, _), _, _, _) -->
+ { sorry(this_file, "foreign_type not implemented") }.
build_type(mlds__native_int_type, _, _, gcc__integer_type_node) --> [].
build_type(mlds__native_float_type, _, _, gcc__double_type_node) --> [].
build_type(mlds__native_bool_type, _, _, gcc__boolean_type_node) --> [].
@@ -2812,7 +2814,7 @@
% sanity check (copied from mlds_to_c.m)
(
{ FieldType = mlds__generic_type
- ; FieldType = mlds__mercury_type(term__variable(_), _)
+ ; FieldType = mlds__mercury_type(term__variable(_), _, _)
}
->
[]
@@ -3014,7 +3016,7 @@
:- pred type_is_float(mlds__type::in) is semidet.
type_is_float(Type) :-
( Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _)
+ [], _), _, _)
; Type = mlds__native_float_type
).
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.85
diff -u -r1.85 mlds_to_il.m
--- compiler/mlds_to_il.m 17 Oct 2001 05:10:29 -0000 1.85
+++ compiler/mlds_to_il.m 22 Oct 2001 14:05:37 -0000
@@ -1016,7 +1016,8 @@
{ UnivMercuryType = term__functor(term__atom("univ"), [],
context("", 0)) },
- { UnivMLDSType = mercury_type(UnivMercuryType, user_type) },
+ { UnivMLDSType = mercury_type(UnivMercuryType,
+ user_type, "XXX") },
{ UnivType = mlds_type_to_ilds_type(DataRep, UnivMLDSType) },
{ RenameNode = (func(N) = list__map(RenameRets, N)) },
@@ -1886,7 +1887,7 @@
Type = mlds__class_type(_, _, mlds__class)
;
DataRep ^ highlevel_data = yes,
- Type = mlds__mercury_type(_, user_type)
+ Type = mlds__mercury_type(_, user_type, _)
}
->
% If this is a class, we should call the
@@ -2390,7 +2391,7 @@
)
;
( already_boxed(SrcILType) ->
- ( SrcType = mercury_type(_, user_type) ->
+ ( SrcType = mercury_type(_, user_type, _) ->
% XXX we should look into a nicer way to
% generate MLDS so we don't need to do this
% XXX This looks wrong for --high-level-data. -fjh.
@@ -2850,7 +2851,7 @@
mlds_type_to_ilds_type(_, mlds__rtti_type(_RttiName)) = il_object_array_type.
mlds_type_to_ilds_type(DataRep, mlds__mercury_array_type(ElementType)) =
- ( ElementType = mlds__mercury_type(_, polymorphic_type) ->
+ ( ElementType = mlds__mercury_type(_, polymorphic_type, _) ->
il_generic_array_type
;
ilds__type([], '[]'(mlds_type_to_ilds_type(DataRep,
@@ -2900,19 +2901,65 @@
mlds_type_to_ilds_type(_, mlds__native_float_type) = ilds__type([], float64).
+mlds_type_to_ilds_type(_, mlds__foreign_type(ForeignType, Assembly))
+ = ilds__type([], Class) :-
+ ( ForeignType = qualified(unqualified("System"), "Boolean") ->
+ Class = bool
+ ; ForeignType = qualified(unqualified("System"), "Char") ->
+ Class = char
+ ; ForeignType = qualified(unqualified("System"), "Object") ->
+ Class = object
+ ; ForeignType = qualified(unqualified("System"), "String") ->
+ Class = string
+ ; ForeignType = qualified(unqualified("System"), "Single") ->
+ Class = float32
+ ; ForeignType = qualified(unqualified("System"), "Double") ->
+ Class = float64
+ ; ForeignType = qualified(unqualified("System"), "SByte") ->
+ Class = int8
+ ; ForeignType = qualified(unqualified("System"), "Int16") ->
+ Class = int16
+ ; ForeignType = qualified(unqualified("System"), "Int32") ->
+ Class = int32
+ ; ForeignType = qualified(unqualified("System"), "Int64") ->
+ Class = int64
+ ; ForeignType = qualified(unqualified("System"), "IntPtr") ->
+ Class = native_int
+ ; ForeignType = qualified(unqualified("System"), "UIntPtr") ->
+ Class = native_uint
+ ; ForeignType = qualified(unqualified("System"), "TypedReference") ->
+ Class = refany
+ ; ForeignType = qualified(unqualified("System"), "Byte") ->
+ Class = uint8
+ ; ForeignType = qualified(unqualified("System"), "UInt16") ->
+ Class = uint16
+ ; ForeignType = qualified(unqualified("System"), "UInt32") ->
+ Class = uint32
+ ; ForeignType = qualified(unqualified("System"), "UInt64") ->
+ Class = uint64
+ ;
+ sym_name_to_class_name(ForeignType, ForeignClassName),
+ Class = class(structured_name(assembly(Assembly),
+ ForeignClassName, []))
+ ).
+
mlds_type_to_ilds_type(ILDataRep, mlds__ptr_type(MLDSType)) =
ilds__type([], '&'(mlds_type_to_ilds_type(ILDataRep, MLDSType))).
-mlds_type_to_ilds_type(_, mercury_type(_, int_type)) = ilds__type([], int32).
-mlds_type_to_ilds_type(_, mercury_type(_, char_type)) = ilds__type([], char).
-mlds_type_to_ilds_type(_, mercury_type(_, float_type)) =
+mlds_type_to_ilds_type(_, mercury_type(_, int_type, _)) =
+ ilds__type([], int32).
+mlds_type_to_ilds_type(_, mercury_type(_, char_type, _)) =
+ ilds__type([], char).
+mlds_type_to_ilds_type(_, mercury_type(_, float_type, _)) =
ilds__type([], float64).
-mlds_type_to_ilds_type(_, mercury_type(_, str_type)) = il_string_type.
-mlds_type_to_ilds_type(_, mercury_type(_, pred_type)) = il_object_array_type.
-mlds_type_to_ilds_type(_, mercury_type(_, tuple_type)) = il_object_array_type.
-mlds_type_to_ilds_type(_, mercury_type(_, enum_type)) = il_object_array_type.
-mlds_type_to_ilds_type(_, mercury_type(_, polymorphic_type)) = il_generic_type.
-mlds_type_to_ilds_type(DataRep, mercury_type(MercuryType, user_type)) =
+mlds_type_to_ilds_type(_, mercury_type(_, str_type, _)) = il_string_type.
+mlds_type_to_ilds_type(_, mercury_type(_, pred_type, _)) = il_object_array_type.
+mlds_type_to_ilds_type(_, mercury_type(_, tuple_type, _)) =
+ il_object_array_type.
+mlds_type_to_ilds_type(_, mercury_type(_, enum_type, _)) = il_object_array_type.
+mlds_type_to_ilds_type(_, mercury_type(_, polymorphic_type, _)) =
+ il_generic_type.
+mlds_type_to_ilds_type(DataRep, mercury_type(MercuryType, user_type, _)) =
( DataRep ^ highlevel_data = yes ->
mercury_type_to_highlevel_class_type(MercuryType)
;
@@ -3418,16 +3465,22 @@
mlds__array_type(mlds__generic_type).
rval_const_to_type(code_addr_const(_)) = mlds__func_type(
mlds__func_params([], [])).
-rval_const_to_type(int_const(_)) = mercury_type(
- term__functor(term__atom("int"), [], context("", 0)), int_type).
-rval_const_to_type(float_const(_)) = mercury_type(
- term__functor(term__atom("float"), [], context("", 0)), float_type).
+rval_const_to_type(int_const(_))
+ = mercury_type(term__functor(term__atom("int"), [], context("", 0)),
+ int_type, "MR_Integer").
+rval_const_to_type(float_const(_))
+ = mercury_type(term__functor(term__atom("float"), [], context("", 0)),
+ float_type, "MR_Float").
rval_const_to_type(false) = mlds__native_bool_type.
rval_const_to_type(true) = mlds__native_bool_type.
-rval_const_to_type(string_const(_)) = mercury_type(
- term__functor(term__atom("string"), [], context("", 0)), str_type).
-rval_const_to_type(multi_string_const(_, _)) = mercury_type(
- term__functor(term__atom("string"), [], context("", 0)), str_type).
+rval_const_to_type(string_const(_))
+ = mercury_type(
+ term__functor(term__atom("string"), [], context("", 0)),
+ str_type, "MR_String").
+rval_const_to_type(multi_string_const(_, _))
+ = mercury_type(term__functor(term__atom("string"), [], context("", 0)),
+ % XXX Should this be MR_Word instead?
+ str_type, "MR_String").
rval_const_to_type(null(MldsType)) = MldsType.
%-----------------------------------------------------------------------------%
@@ -3629,6 +3682,12 @@
ilds__type([], value_class(il_system_name(["Boolean"]))).
simple_type_to_value_class(char) =
ilds__type([], value_class(il_system_name(["Char"]))).
+simple_type_to_value_class(object) = _ :-
+ % ilds__type([], value_class(il_system_name(["Object"]))).
+ error("no value class for System.Object").
+simple_type_to_value_class(string) = _ :-
+ % ilds__type([], value_class(il_system_name(["String"]))).
+ error("no value class for System.String").
simple_type_to_value_class(refany) = _ :-
error("no value class for refany").
simple_type_to_value_class(class(_)) = _ :-
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.13
diff -u -r1.13 mlds_to_java.m
--- compiler/mlds_to_java.m 24 Aug 2001 15:44:56 -0000 1.13
+++ compiler/mlds_to_java.m 22 Oct 2001 14:05:38 -0000
@@ -130,7 +130,7 @@
:- mode type_is_enum(in) is semidet.
type_is_enum(Type) :-
- Type = mercury_type(_, Builtin),
+ Type = mercury_type(_, Builtin, _),
Builtin = enum_type.
% Succeeds iff this type is something that
@@ -141,7 +141,7 @@
:- mode type_is_object(in) is semidet.
type_is_object(Type) :-
- Type = mercury_type(_, Builtin),
+ Type = mercury_type(_, Builtin, _),
( Builtin = enum_type
; Builtin = polymorphic_type
; Builtin = user_type
@@ -848,15 +848,15 @@
:- func get_java_type_initializer(mlds__type) = string.
:- mode get_java_type_initializer(in) = out is det.
-get_java_type_initializer(mercury_type(_, int_type)) = "0".
-get_java_type_initializer(mercury_type(_, char_type)) = "0".
-get_java_type_initializer(mercury_type(_, float_type)) = "0".
-get_java_type_initializer(mercury_type(_, str_type)) = "null".
-get_java_type_initializer(mercury_type(_, pred_type)) = "null".
-get_java_type_initializer(mercury_type(_, tuple_type)) = "null".
-get_java_type_initializer(mercury_type(_, enum_type)) = "null".
-get_java_type_initializer(mercury_type(_, polymorphic_type)) = "null".
-get_java_type_initializer(mercury_type(_, user_type)) = "null".
+get_java_type_initializer(mercury_type(_, int_type, _)) = "0".
+get_java_type_initializer(mercury_type(_, char_type, _)) = "0".
+get_java_type_initializer(mercury_type(_, float_type, _)) = "0".
+get_java_type_initializer(mercury_type(_, str_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, pred_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, tuple_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, enum_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, polymorphic_type, _)) = "null".
+get_java_type_initializer(mercury_type(_, user_type, _)) = "null".
get_java_type_initializer(mlds__mercury_array_type(_)) = "null".
get_java_type_initializer(mlds__cont_type(_)) = "null".
get_java_type_initializer(mlds__commit_type) = "null".
@@ -864,6 +864,9 @@
get_java_type_initializer(mlds__native_int_type) = "0".
get_java_type_initializer(mlds__native_float_type) = "0".
get_java_type_initializer(mlds__native_char_type) = "0".
+get_java_type_initializer(mlds__foreign_type(_, _)) = _ :-
+ unexpected(this_file,
+ "get_type_initializer: variable has foreign_type").
get_java_type_initializer(mlds__class_type(_, _, _)) = "null".
get_java_type_initializer(mlds__array_type(_)) = "null".
get_java_type_initializer(mlds__ptr_type(_)) = "null".
@@ -1206,7 +1209,7 @@
:- pred output_type(mlds__type, io__state, io__state).
:- mode output_type(in, di, uo) is det.
-output_type(mercury_type(Type, TypeCategory)) -->
+output_type(mercury_type(Type, TypeCategory, _)) -->
output_mercury_type(Type, TypeCategory).
output_type(mercury_array_type(MLDSType)) -->
@@ -1216,6 +1219,8 @@
output_type(mlds__native_float_type) --> io__write_string("double").
output_type(mlds__native_bool_type) --> io__write_string("boolean").
output_type(mlds__native_char_type) --> io__write_string("char").
+output_type(mlds__foreign_type(_, _)) -->
+ { unexpected(this_file, "output_type: foreign_type NYI.") }.
output_type(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
output_fully_qualified(Name, output_mangled_name),
@@ -1888,9 +1893,10 @@
(
{ TargetType = ArgType }
;
- { TargetType =
- mercury_type(_, TargetBuiltinType),
- ArgType = mercury_type(_, ArgBuiltinType),
+ { TargetType = mercury_type(
+ _, TargetBuiltinType, _),
+ ArgType = mercury_type(
+ _, ArgBuiltinType, _),
TargetBuiltinType = ArgBuiltinType }
)
@@ -2102,17 +2108,18 @@
java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
Type = mlds__native_int_type.
java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
- Type = mlds__mercury_type(term__functor(term__atom("int"), [], _), _).
+ Type = mlds__mercury_type(term__functor(term__atom("int"),
+ [], _), _, _).
java_builtin_type(Type, "double", "java.lang.Double", "doubleValue") :-
Type = mlds__native_float_type.
java_builtin_type(Type, "double", "java.lang.Double", "doubleValue") :-
Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _).
+ [], _), _, _).
java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
Type = mlds__native_char_type.
java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
Type = mlds__mercury_type(term__functor(term__atom("character"),
- [], _), _).
+ [], _), _, _).
java_builtin_type(Type, "boolean", "java.lang.Boolean", "booleanValue") :-
Type = mlds__native_bool_type.
Index: compiler/mlds_to_mcpp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_mcpp.m,v
retrieving revision 1.20
diff -u -r1.20 mlds_to_mcpp.m
--- compiler/mlds_to_mcpp.m 17 Oct 2001 05:10:33 -0000 1.20
+++ compiler/mlds_to_mcpp.m 22 Oct 2001 14:05:38 -0000
@@ -582,6 +582,10 @@
io__write_string("mercury::MR_Bool").
write_il_simple_type_as_managed_cpp_type(char) -->
io__write_string("mercury::MR_Char").
+write_il_simple_type_as_managed_cpp_type(string) -->
+ io__write_string("mercury::MR_String").
+write_il_simple_type_as_managed_cpp_type(object) -->
+ io__write_string("mercury::MR_Box").
write_il_simple_type_as_managed_cpp_type(refany) -->
io__write_string("mercury::MR_RefAny").
write_il_simple_type_as_managed_cpp_type(class(ClassName)) -->
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.68
diff -u -r1.68 module_qual.m
--- compiler/module_qual.m 27 Jun 2001 05:04:15 -0000 1.68
+++ compiler/module_qual.m 22 Oct 2001 14:05:38 -0000
@@ -246,7 +246,20 @@
process_module_defn(ModuleDefn, Info0, Info).
collect_mq_info_2(pred_or_func(_,_,__,_,_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pred_or_func_mode(_,_,_,_,_,_), Info, Info).
-collect_mq_info_2(pragma(_), Info, Info).
+collect_mq_info_2(pragma(Pragma), Info0, Info) :-
+ ( Pragma = foreign_type(_, Type, SymName, _ForeignType) ->
+ ( type_to_type_id(Type, _ - Arity0, _) ->
+ Arity = Arity0
+ ;
+ Arity = 0
+ ),
+ mq_info_get_types(Info0, Types0),
+ mq_info_get_need_qual_flag(Info0, NeedQualifier),
+ id_set_insert(NeedQualifier, SymName - Arity, Types0, Types),
+ mq_info_set_types(Info0, Types, Info)
+ ;
+ Info = Info0
+ ).
collect_mq_info_2(assertion(Goal, _ProgVarSet), Info0, Info) :-
process_assert(Goal, SymNames, Success),
(
@@ -880,6 +893,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_type(Backend, Type0, SymName, F),
+ foreign_type(Backend, Type, SymName, F), Info0, Info) -->
+ qualify_type(Type0, Type, Info0, Info).
qualify_pragma(
foreign_proc(Rec, SymName, PredOrFunc, PragmaVars0, Varset, Code),
foreign_proc(Rec, SymName, PredOrFunc, PragmaVars, Varset, Code),
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.198
diff -u -r1.198 modules.m
--- compiler/modules.m 28 Aug 2001 13:35:53 -0000 1.198
+++ compiler/modules.m 22 Oct 2001 14:05:40 -0000
@@ -1141,6 +1141,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_type(_, _, _, _), yes).
pragma_allowed_in_interface(inline(_, _), no).
pragma_allowed_in_interface(no_inline(_, _), no).
pragma_allowed_in_interface(obsolete(_, _), yes).
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.46
diff -u -r1.46 pragma_c_gen.m
--- compiler/pragma_c_gen.m 24 Apr 2001 03:59:02 -0000 1.46
+++ compiler/pragma_c_gen.m 22 Oct 2001 14:05:41 -0000
@@ -42,7 +42,7 @@
:- implementation.
:- import_module hlds_module, hlds_pred, llds_out, trace, tree.
-:- import_module code_util.
+:- import_module code_util, export.
:- import_module options, globals.
:- import_module bool, string, int, assoc_list, set, map, require, term.
@@ -438,13 +438,13 @@
%
% Generate <declaration of one local variable for each arg>
%
- { make_pragma_decls(Args, Decls) },
+ code_info__get_module_info(ModuleInfo),
+ { make_pragma_decls(Args, ModuleInfo, Decls) },
%
% Generate #define MR_PROC_LABEL <procedure label> /* see note (5) */
% and #undef MR_PROC_LABEL
%
- code_info__get_module_info(ModuleInfo),
code_info__get_pred_id(CallerPredId),
code_info__get_proc_id(CallerProcId),
{ make_proc_label_hash_define(ModuleInfo, CallerPredId, CallerProcId,
@@ -665,8 +665,8 @@
{ make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes, ArgInfos, Args) },
{ pragma_select_in_args(Args, InArgs) },
{ pragma_select_out_args(Args, OutArgs) },
- { make_pragma_decls(Args, Decls) },
- { make_pragma_decls(OutArgs, OutDecls) },
+ { make_pragma_decls(Args, ModuleInfo, Decls) },
+ { make_pragma_decls(OutArgs, ModuleInfo, OutDecls) },
{ input_descs_from_arg_info(InArgs, InputDescs) },
{ output_descs_from_arg_info(OutArgs, OutputDescs) },
@@ -1127,21 +1127,23 @@
% data structure in the LLDS. It is essentially a list of pairs of type and
% variable name, so that declarations of the form "Type Name;" can be made.
-:- pred make_pragma_decls(list(c_arg)::in, list(pragma_c_decl)::out) is det.
+:- pred make_pragma_decls(list(c_arg)::in, module_info::in,
+ list(pragma_c_decl)::out) is det.
-make_pragma_decls([], []).
-make_pragma_decls([Arg | Args], Decls) :-
+make_pragma_decls([], _, []).
+make_pragma_decls([Arg | Args], Module, Decls) :-
Arg = c_arg(_Var, ArgName, OrigType, _ArgInfo),
(
var_is_not_singleton(ArgName, Name)
->
- Decl = pragma_c_arg_decl(OrigType, Name),
- make_pragma_decls(Args, Decls1),
+ export__type_to_type_string(Module, OrigType, OrigTypeString),
+ Decl = pragma_c_arg_decl(OrigType, OrigTypeString, Name),
+ make_pragma_decls(Args, Module, Decls1),
Decls = [Decl | Decls1]
;
% if the variable doesn't occur in the ArgNames list,
% it can't be used, so we just ignore it
- make_pragma_decls(Args, Decls)
+ make_pragma_decls(Args, Module, Decls)
).
%---------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.69
diff -u -r1.69 prog_data.m
--- compiler/prog_data.m 18 Jul 2001 10:20:57 -0000 1.69
+++ compiler/prog_data.m 22 Oct 2001 14:05:41 -0000
@@ -165,6 +165,10 @@
% names from the pred declaration), TVarSet,
% Equivalence types used
+ ; foreign_type(backend, (type), sym_name, sym_name)
+ % Backend, MercuryType, MercuryTypeName,
+ % ForeignType, ForeignTypeLocation
+
; inline(sym_name, arity)
% Predname, Arity
@@ -272,6 +276,14 @@
; check_termination(sym_name, arity).
% Predname, Arity
+
+%
+% Stuff for the foreign interfacing pragmas.
+%
+
+:- type backend
+ % The location of the il name.
+ ---> il(string).
%
% Stuff for tabling pragmas
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.34
diff -u -r1.34 prog_io_pragma.m
--- compiler/prog_io_pragma.m 25 Sep 2001 09:36:54 -0000 1.34
+++ compiler/prog_io_pragma.m 22 Oct 2001 14:05:42 -0000
@@ -70,6 +70,51 @@
ErrorTerm)
).
+parse_pragma_type(ModuleName, "foreign_type", PragmaTerms,
+ ErrorTerm, _VarSet, Result) :-
+ ( PragmaTerms = [MercuryName, ForeignName, Target] ->
+ (
+ parse_backend(Target, Backend)
+ ->
+ parse_implicitly_qualified_term(ModuleName, MercuryName,
+ ErrorTerm, "`:- pragma foreign_type' declaration",
+ MaybeMercuryType),
+ (
+ MaybeMercuryType = ok(MercuryTypeSymName, MercuryArgs),
+ ( MercuryArgs = [] ->
+ parse_qualified_term(ForeignName, ErrorTerm,
+ "`:- pragma foreign_type' declaration",
+ MaybeForeignType),
+ (
+ MaybeForeignType = ok(ForeignType, ForeignArgs),
+ ( ForeignArgs = [] ->
+ term__coerce(MercuryName, MercuryType),
+ Result = ok(pragma(foreign_type(Backend,
+ MercuryType, MercuryTypeSymName,
+ ForeignType)))
+ ;
+ Result = error("foreign type arity not 0", ErrorTerm)
+ )
+ ;
+ MaybeForeignType = error(String, Term),
+ Result = error(String, Term)
+ )
+ ;
+ Result = error("mercury type arity not 0", ErrorTerm)
+ )
+ ;
+ MaybeMercuryType = error(String, Term),
+ Result = error(String, Term)
+ )
+ ;
+ Result = error("invalid backend parameter", Target)
+ )
+ ;
+ Result = error(
+ "wrong number of arguments in `:- pragma foreign_type' declaration",
+ ErrorTerm)
+ ).
+
parse_pragma_type(ModuleName, "foreign_decl", PragmaTerms,
ErrorTerm, VarSet, Result) :-
parse_pragma_foreign_decl_pragma(ModuleName, "foreign_decl",
@@ -129,6 +174,14 @@
parse_foreign_language(term__functor(term__string(String), _, _), Lang) :-
globals__convert_foreign_language(String, Lang).
+
+:- pred parse_backend(term, backend).
+:- mode parse_backend(in, out) is semidet.
+
+parse_backend(term__functor(Functor, Args, _), Backend) :-
+ Functor = term__atom("il"),
+ Args = [term__functor(term__string(Module), [], _)],
+ Backend = il(Module).
% This predicate parses both c_header_code and foreign_decl pragmas.
:- pred parse_pragma_foreign_decl_pragma(module_name, string,
Index: compiler/recompilation_usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation_usage.m,v
retrieving revision 1.2
diff -u -r1.2 recompilation_usage.m
--- compiler/recompilation_usage.m 11 Jul 2001 15:44:21 -0000 1.2
+++ compiler/recompilation_usage.m 22 Oct 2001 14:05:42 -0000
@@ -1026,6 +1026,7 @@
recompilation_usage__find_items_used_by_type_body(uu_type(Types)) -->
recompilation_usage__find_items_used_by_types(Types).
recompilation_usage__find_items_used_by_type_body(abstract_type) --> [].
+recompilation_usage__find_items_used_by_type_body(foreign_type(_, _)) --> [].
:- pred recompilation_usage__find_items_used_by_mode_defn(hlds_mode_defn::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
Index: compiler/recompilation_version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation_version.m,v
retrieving revision 1.4
diff -u -r1.4 recompilation_version.m
--- compiler/recompilation_version.m 24 Jul 2001 17:16:43 -0000 1.4
+++ compiler/recompilation_version.m 22 Oct 2001 14:05:42 -0000
@@ -452,6 +452,7 @@
is_pred_pragma(foreign_proc(_, Name, PredOrFunc, Args, _, _),
yes(yes(PredOrFunc) - Name / Arity)) :-
adjust_func_arity(PredOrFunc, Arity, list__length(Args)).
+is_pred_pragma(foreign_type(_, _, _, _), no).
is_pred_pragma(type_spec(Name, _, Arity, MaybePredOrFunc, _, _, _, _),
yes(MaybePredOrFunc - Name / Arity)).
is_pred_pragma(inline(Name, Arity), yes(no - Name / Arity)).
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.18
diff -u -r1.18 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 9 Jul 2001 15:55:07 -0000 1.18
+++ compiler/rtti_to_mlds.m 22 Oct 2001 14:05:44 -0000
@@ -135,7 +135,7 @@
Init, []) :-
Init = gen_init_array(gen_init_maybe(
mercury_type(functor(atom("string"), [],
- context("", 0)), str_type),
+ context("", 0)), str_type, "MR_String"),
gen_init_string), MaybeNames).
gen_init_rtti_data_defn(field_types(_RttiTypeId, _Ordinal, Types),
ModuleName, _, Init, []) :-
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.14
diff -u -r1.14 term_util.m
--- compiler/term_util.m 18 Sep 2000 11:51:47 -0000 1.14
+++ compiler/term_util.m 22 Oct 2001 14:05:44 -0000
@@ -268,6 +268,10 @@
% but we will never see them in this analysis
TypeBody = abstract_type,
Weights = Weights0
+ ;
+ % This type does not introduce any functors
+ TypeBody = foreign_type(_, _),
+ Weights = Weights0
).
:- pred find_weights_for_cons_list(list(constructor)::in,
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.13
diff -u -r1.13 type_ctor_info.m
--- compiler/type_ctor_info.m 18 Mar 2001 23:09:59 -0000 1.13
+++ compiler/type_ctor_info.m 22 Oct 2001 14:05:44 -0000
@@ -261,6 +261,14 @@
TypeTables = [],
NumPtags = -1
;
+ TypeBody = foreign_type(_, _),
+ TypeCtorRep = unknown,
+ NumFunctors = -1,
+ FunctorsInfo = no_functors,
+ LayoutInfo = no_layout,
+ TypeTables = [],
+ NumPtags = -1
+ ;
TypeBody = eqv_type(Type),
( term__is_ground(Type) ->
TypeCtorRep = equiv(equiv_type_is_ground)
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.95
diff -u -r1.95 unify_proc.m
--- compiler/unify_proc.m 31 Jul 2001 14:29:56 -0000 1.95
+++ compiler/unify_proc.m 22 Oct 2001 14:05:45 -0000
@@ -756,6 +756,16 @@
unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
Clauses)
;
+ { TypeBody = foreign_type(_, _) },
+ % XXX Is this the correct thing to do?
+ % I assume at code gen time I could examine the types
+ % of the unification and output different code because
+ % they are foreign types.
+ { create_atomic_unification(H1, var(H2), Context, explicit, [],
+ Goal) },
+ unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
+ Clauses)
+ ;
{ TypeBody = uu_type(_) },
{ error("trying to create unify proc for uu type") }
;
@@ -810,6 +820,9 @@
% invoked.
{ error("trying to create index proc for eqv type") }
;
+ { TypeBody = foreign_type(_, _) },
+ { error("trying to create index proc for a foreign type") }
+ ;
{ TypeBody = uu_type(_) },
{ error("trying to create index proc for uu type") }
;
@@ -872,6 +885,15 @@
%
% XXX Somebody should document here what the later stages
% of the compiler do to prevent an infinite recursion here.
+ { ArgVars = [Res, H1, H2] },
+ unify_proc__build_call("compare", ArgVars, Context, Goal),
+ unify_proc__quantify_clauses_body(ArgVars, Goal, Context,
+ Clauses)
+ ;
+ { TypeBody = foreign_type(_, _) },
+ % XXX
+ % I think we should delay handling this for foreign types until
+ % code gen time.
{ ArgVars = [Res, H1, H2] },
unify_proc__build_call("compare", ArgVars, Context, Goal),
unify_proc__quantify_clauses_body(ArgVars, Goal, Context,
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.219
diff -u -r1.219 reference_manual.texi
--- doc/reference_manual.texi 12 Oct 2001 05:23:46 -0000 1.219
+++ doc/reference_manual.texi 22 Oct 2001 14:05:53 -0000
@@ -6656,6 +6656,8 @@
@samp{#@var{line}} directives provide support
for preprocessors and other tools that
generate Mercury code.
+* Interfacing:: Pragmas can be used to ease interfacing
+ with other languages.
@end menu
@node Inlining
@@ -6832,6 +6834,32 @@
to reset the source file name and line number to point back to the
generated file for the automatically generated text, as in the above
example.
+
+ at node Interfacing
+ at section Interfacing
+
+A declaration of the form
+
+ at example
+:- pragma foreign_type(xmldoc, 'System__Xml__XmlDocument', il("System.Xml")).
+ at end example
+
+ensures that on the IL backend the mercury type @samp{xmldoc} is
+represented by the backend as a @samp{System.Xml.XmlDocument}. This
+avoids the need to marshall values when interfacing with libraries
+written in other languages. The following example shows how to do this
+interfacing.
+
+ at example
+:- pred loadxml(string::in, xmldoc::di, xmldoc::uo) is det.
+
+:- pragma foreign_proc("C#", load(String::in, XML0::di, XML::uo),
+ [will_not_call_mercury],
+"
+ XML0.LoadXml(String);
+ XML = XML0;
+").
+ at end example
@node Implementation-dependent extensions
@chapter Implementation-dependent extensions
--------------------------------------------------------------------------
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