[m-rev.] [dotnet-foreign] for review: stage 1 of pragma foreign_type
Peter Ross
peter.ross at miscrit.be
Tue Apr 10 00:08:45 AEST 2001
Hi,
===================================================================
Estimated hours taken: 24
Branches: dotnet-foreign
Introduce the new pragma `foreign_type'. This allows the mercury code
generator to use the more specific foreign type when generating code.
This is a big win on the IL backend as casting between different
types is a very expensive operation.
Currently this change is very heavily tied to the IL backend, and needs
to be generalised before merging back onto 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 exits.
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, and we also table the result of
export__type_to_type_string.
compiler/pragma_c_gen.m:
Table the results of export__type_to_type_string in
pragma_c_arg_decl.
compiler/mlds_to_il.m:
Convert a mlds__foreign_type into an ilds__type.
compiler/fact_table.m:
compiler/llds_out.m:
compiler/ml_code_gen.m:
compiler/ml_simplify_switch.m:
compiler/ml_string_switch.m:
compiler/ml_switch_gen.m:
compiler/ml_unify_gen.m:
compiler/mlds_to_c.m:
compiler/mlds_to_java.m:
compiler/rtti_to_mlds.m:
Changes to handle the tabling of calls to export__type_to_type_string.
compiler/hlds_out.m:
compiler/intermod.m:
compiler/magic_util.m:
compiler/ml_type_gen.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/unify_proc.m:
Changes to handle 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.46
diff -u -r1.46 export.m
--- compiler/export.m 2001/02/05 08:01:40 1.46
+++ compiler/export.m 2001/04/09 13:06:24
@@ -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].
%-----------------------------------------------------------------------------%
@@ -203,10 +204,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.
@@ -266,13 +267,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),
(
@@ -306,7 +309,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),
@@ -364,37 +367,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.
+:- 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).
-get_argument_declarations([], _, "void").
-get_argument_declarations([X|Xs], NameThem, Result) :-
- get_argument_declarations_2([X|Xs], 0, NameThem, 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),
@@ -402,7 +409,7 @@
;
ArgName = ""
),
- export__type_to_type_string(Type, TypeString0),
+ export__type_to_type_string(Module, Type, TypeString0),
(
Mode = top_out
->
@@ -596,7 +603,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"), [], _) ->
@@ -606,7 +613,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 2001/02/20 14:08:33 1.39
+++ compiler/fact_table.m 2001/04/09 13:06:25
@@ -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.53
diff -u -r1.53 hlds_data.m
--- compiler/hlds_data.m 2001/03/01 12:52:48 1.53
+++ compiler/hlds_data.m 2001/04/09 13:06:25
@@ -289,7 +289,9 @@
)
; uu_type(list(type)) % not yet implemented!
; eqv_type(type)
- ; abstract_type.
+ ; abstract_type
+ ; foreign_type(sym_name). % Name of foreign type which represents
+ % the mercury type.
% The `cons_tag_values' type stores the information on how
% a discriminated union type is represented.
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.258
diff -u -r1.258 hlds_out.m
--- compiler/hlds_out.m 2001/04/07 14:04:40 1.258
+++ compiler/hlds_out.m 2001/04/09 13:06:26
@@ -2570,6 +2570,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/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.97
diff -u -r1.97 intermod.m
--- compiler/intermod.m 2001/04/07 14:04:42 1.97
+++ compiler/intermod.m 2001/04/09 13:06:26
@@ -1256,6 +1256,9 @@
{ Body = abstract_type },
mercury_output_type_defn(VarSet,
abstract_type(Name, Args), Context)
+ ;
+ { Body = foreign_type(_) },
+ { error("foreign types not implemented") }
).
:- pred intermod__write_modes(module_info::in,
Index: compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.274
diff -u -r1.274 llds.m
--- compiler/llds.m 2001/03/13 12:40:12 1.274
+++ compiler/llds.m 2001/04/09 13:06:27
@@ -542,6 +542,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.174
diff -u -r1.174 llds_out.m
--- compiler/llds_out.m 2001/02/20 14:08:34 1.174
+++ compiler/llds_out.m 2001/04/09 13:06:28
@@ -1848,11 +1848,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.12
diff -u -r1.12 magic_util.m
--- compiler/magic_util.m 2000/10/13 13:55:33 1.12
+++ compiler/magic_util.m 2001/04/09 13:06:29
@@ -1380,6 +1380,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.368
diff -u -r1.368 make_hlds.m
--- compiler/make_hlds.m 2001/04/07 14:04:45 1.368
+++ compiler/make_hlds.m 2001/04/09 13:06:31
@@ -413,6 +413,23 @@
{ Pragma = foreign_proc(_, _, _, _, _, _) },
{ Module = Module0 }
;
+ % XXXX
+ { Pragma = foreign_type(MercuryType, _, ForeignType) },
+ { module_info_types(Module0, Types0) },
+
+ { type_to_type_id(MercuryType, TypeId, _) ->
+ Body = foreign_type(ForeignType),
+
+ hlds_data__set_type_defn(varset__init, [], Body,
+ ImportStatus, Context, TypeDefn),
+
+ % XXX do we need to add special preds!
+ map__set(Types0, TypeId, TypeDefn, Types),
+ module_info_set_types(Module0, Types, Module)
+ ;
+ error("add_item_decl_pass_2: type_to_type_id failed")
+ }
+ ;
% Handle pragma tabled decls later on (when we process
% clauses).
{ Pragma = tabled(_, _, _, _, _) },
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.184
diff -u -r1.184 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 2001/04/03 03:19:57 1.184
+++ compiler/mercury_to_mercury.m 2001/04/09 13:06:32
@@ -358,6 +358,15 @@
mercury_output_pragma_foreign_code(Attributes, Pred,
PredOrFunc, Vars, VarSet, PragmaCode)
;
+ { Pragma = foreign_type(_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(").\n")
+ ;
{ Pragma = import(Pred, PredOrFunc, ModeList, Attributes,
C_Function) },
mercury_output_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.80
diff -u -r1.80 ml_code_gen.m
--- compiler/ml_code_gen.m 2001/04/07 14:04:49 1.80
+++ compiler/ml_code_gen.m 2001/04/09 13:06:33
@@ -2111,8 +2111,12 @@
%
% Combine all the information about the each arg
%
+ =(MLDSGenInfo),
+ { ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
+ { list__map(export__type_to_type_string(ModuleInfo),
+ OrigArgTypes, OrigArgTypeStrings) },
{ ml_make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes,
- ArgList) },
+ OrigArgTypeStrings, ArgList) },
%
% Generate <declaration of one local variable for each arg>
@@ -2189,8 +2193,6 @@
raw_target_code("\t\tif (MR_succeeded) {\n")],
AssignOutputsList
]) },
- =(MLDSGenInfo),
- { ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
{ module_info_globals(ModuleInfo, Globals) },
{ globals__lookup_string_option(Globals, target, Target) },
( { CodeModel = model_non } ->
@@ -2312,8 +2314,12 @@
%
% Combine all the information about the each arg
%
+ =(MLDSGenInfo),
+ { ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
+ { list__map(export__type_to_type_string(ModuleInfo),
+ OrigArgTypes, OrigArgTypeStrings) },
{ ml_make_c_arg_list(ArgVars, ArgDatas, OrigArgTypes,
- ArgList) },
+ OrigArgTypeStrings, ArgList) },
%
% Generate <declaration of one local variable for each arg>
@@ -2462,23 +2468,26 @@
---> ml_c_arg(
prog_var,
maybe(pair(string, mode)), % name and mode
- prog_type % original type before
+ prog_type, % original type before
% inlining/specialization
% (the actual type may be an instance
% of this type, if this type is
% polymorphic).
+ string % For the original type the result
+ % of export:type_to_type_string
).
:- pred ml_make_c_arg_list(list(prog_var)::in,
list(maybe(pair(string, mode)))::in, list(prog_type)::in,
- list(ml_c_arg)::out) is det.
+ list(string)::in, list(ml_c_arg)::out) is det.
-ml_make_c_arg_list(Vars, ArgDatas, Types, ArgList) :-
- ( Vars = [], ArgDatas = [], Types = [] ->
+ml_make_c_arg_list(Vars, ArgDatas, Types, TypeStrings, ArgList) :-
+ ( Vars = [], ArgDatas = [], Types = [], TypeStrings = [] ->
ArgList = []
- ; Vars = [V|Vs], ArgDatas = [N|Ns], Types = [T|Ts] ->
- Arg = ml_c_arg(V, N, T),
- ml_make_c_arg_list(Vs, Ns, Ts, Args),
+ ; Vars = [V|Vs], ArgDatas = [N|Ns],
+ Types = [T|Ts], TypeStrings = [TS|TSs] ->
+ Arg = ml_c_arg(V, N, T, TS),
+ ml_make_c_arg_list(Vs, Ns, Ts, TSs, Args),
ArgList = [Arg | Args]
;
error("ml_code_gen:make_c_arg_list - length mismatch")
@@ -2502,12 +2511,12 @@
%
:- pred ml_gen_pragma_c_decl(ml_c_arg::in, target_code_component::out) is det.
-ml_gen_pragma_c_decl(ml_c_arg(_Var, MaybeNameAndMode, Type), Decl) :-
+ml_gen_pragma_c_decl(ml_c_arg(_Var, MaybeNameAndMode, _Type, TypeString),
+ Decl) :-
(
MaybeNameAndMode = yes(ArgName - _Mode),
\+ var_is_singleton(ArgName)
->
- export__type_to_type_string(Type, TypeString),
string__format("\t%s %s;\n", [s(TypeString), s(ArgName)],
DeclString)
;
@@ -2551,7 +2560,7 @@
list(target_code_component)::out,
ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_pragma_c_input_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType),
+ml_gen_pragma_c_input_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType, TypeString),
AssignInput) -->
=(MLDSGenInfo),
{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
@@ -2583,7 +2592,6 @@
% --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.)
- export__type_to_type_string(OrigType, TypeString),
string__format("(%s)", [s(TypeString)], Cast)
;
% For --no-high-level-data, we only need to use
@@ -2634,7 +2642,8 @@
mlds__defns::out, mlds__statements::out,
ml_gen_info::in, ml_gen_info::out) is det.
-ml_gen_pragma_c_output_arg(ml_c_arg(Var, MaybeNameAndMode, OrigType),
+ml_gen_pragma_c_output_arg(
+ ml_c_arg(Var, MaybeNameAndMode, OrigType, TypeString),
Context, AssignOutput, ConvDecls, ConvOutputStatements) -->
=(MLDSGenInfo),
{ ml_gen_info_get_module_info(MLDSGenInfo, ModuleInfo) },
@@ -2661,7 +2670,6 @@
% Note that we can't easily obtain the type string
% for the RHS of the assignment, so instead we
% cast the LHS.
- export__type_to_type_string(OrigType, TypeString),
string__format("*(%s *)&", [s(TypeString)], LHS_Cast),
RHS_Cast = ""
;
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 2001/01/20 15:42:47 1.2
+++ compiler/ml_simplify_switch.m 2001/04/09 13:06:33
@@ -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_string_switch.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_string_switch.m,v
retrieving revision 1.5
diff -u -r1.5 ml_string_switch.m
--- compiler/ml_string_switch.m 2001/02/20 07:52:18 1.5
+++ compiler/ml_string_switch.m 2001/04/09 13:06:33
@@ -291,4 +291,4 @@
).
:- func ml_string_type = mlds__type.
-ml_string_type = mercury_type(string_type, str_type).
+ml_string_type = mercury_type(string_type, str_type, "MR_String").
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 2001/01/10 11:15:32 1.7
+++ compiler/ml_switch_gen.m 2001/04/09 13:06:33
@@ -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.5
diff -u -r1.5 ml_type_gen.m
--- compiler/ml_type_gen.m 2001/02/20 07:52:17 1.5
+++ compiler/ml_type_gen.m 2001/04/09 13:06:34
@@ -106,6 +106,9 @@
ml_gen_du_parent_type(ModuleInfo, TypeId, TypeDefn,
Ctors, TagValues, MaybeEqualityMembers)
).
+ % XXXX
+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.32
diff -u -r1.32 ml_unify_gen.m
--- compiler/ml_unify_gen.m 2001/03/13 12:40:16 1.32
+++ compiler/ml_unify_gen.m 2001/04/09 13:06:34
@@ -1129,7 +1129,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
}
->
@@ -1144,7 +1144,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.49
diff -u -r1.49 mlds.m
--- compiler/mlds.m 2001/02/28 15:59:18 1.49
+++ compiler/mlds.m 2001/04/09 13:06:35
@@ -486,9 +486,12 @@
:- type mlds__type
---> % Mercury data types
mercury_type(
- prog_data__type, % the exact Mercury type
- builtin_type % what kind of type it is:
- % enum, float, etc.
+ prog_data__type, % the exact Mercury type
+ builtin_type, % what kind of type it is:
+ % enum, float, etc.
+ string % the result of
+ % export__type_to_type_string
+
)
% The type for the continuation functions used
@@ -508,6 +511,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)
+
% MLDS types defined using mlds__class_defn
; mlds__class_type(
mlds__class, % name
@@ -1354,8 +1361,8 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module modules.
-:- import_module int, term, string, require.
+:- import_module export, modules.
+:- import_module int, map, require, string, term.
%-----------------------------------------------------------------------------%
@@ -1380,8 +1387,24 @@
% XXX It might be a better idea to get rid of the mercury_type/2
% MLDS type and instead fully convert all Mercury types to MLDS types.
-mercury_type_to_mlds_type(ModuleInfo, Type) = mercury_type(Type, Category) :-
- classify_type(Type, ModuleInfo, Category).
+mercury_type_to_mlds_type(ModuleInfo, Type) = MLDS_Type :-
+ module_info_types(ModuleInfo, Types),
+ classify_type(Type, ModuleInfo, Category),
+ export__type_to_type_string(ModuleInfo, Type, TypeString),
+ (
+ type_to_type_id(Type, TypeId, _),
+ map__search(Types, TypeId, TypeDefn)
+ ->
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+ ( Body = foreign_type(ForeignType) ->
+ MLDS_Type = mlds__foreign_type(ForeignType)
+ ;
+ MLDS_Type = mercury_type(Type, Category, TypeString)
+ )
+ ;
+ MLDS_Type = 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.83
diff -u -r1.83 mlds_to_c.m
--- compiler/mlds_to_c.m 2001/03/09 14:35:27 1.83
+++ compiler/mlds_to_c.m 2001/04/09 13:06:36
@@ -42,7 +42,6 @@
:- import_module ml_code_util. % for ml_gen_public_field_decl_flags, which is
% used by the code that handles derived classes
:- import_module ml_type_gen. % for ml_gen_type_name
-:- import_module export. % for export__type_to_type_string
:- import_module globals, options, passes_aux.
:- import_module builtin_ops, c_util, modules.
:- import_module prog_data, prog_out, type_util, error_util.
@@ -600,9 +599,8 @@
:- mode mlds_output_pragma_export_type(in, in, di, uo) is det.
mlds_output_pragma_export_type(suffix, _Type) --> [].
-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) -->
@@ -615,6 +613,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(_)) -->
@@ -857,7 +857,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,
@@ -1513,12 +1513,14 @@
:- 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(mlds__native_int_type) --> io__write_string("int").
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 } ->
%
@@ -1671,11 +1673,12 @@
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(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) -->
@@ -2557,7 +2560,7 @@
FieldType, _ClassType)) -->
(
{ FieldType = mlds__generic_type
- ; FieldType = mlds__mercury_type(term__variable(_), _)
+ ; FieldType = mlds__mercury_type(term__variable(_), _, _)
}
->
% XXX this generated code is ugly;
@@ -2742,7 +2745,7 @@
mlds_output_boxed_rval(Type, Exprn) -->
(
{ Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _)
+ [], _), _, _)
; Type = mlds__native_float_type
}
->
@@ -2751,7 +2754,7 @@
io__write_string(")")
;
{ Type = mlds__mercury_type(term__functor(term__atom("character"),
- [], _), _)
+ [], _), _, _)
; Type = mlds__native_char_type
; Type = mlds__native_bool_type
; Type = mlds__native_int_type
@@ -2775,7 +2778,7 @@
mlds_output_unboxed_rval(Type, Exprn) -->
(
{ Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _)
+ [], _), _, _)
; Type = mlds__native_float_type
}
->
@@ -2784,7 +2787,7 @@
io__write_string(")")
;
{ 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_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.15
diff -u -r1.15 mlds_to_il.m
--- compiler/mlds_to_il.m 2001/03/16 04:17:46 1.15
+++ compiler/mlds_to_il.m 2001/04/09 13:06:37
@@ -1810,11 +1810,15 @@
mlds_type_to_ilds_type(mlds__native_float_type) = ilds__type([], float64).
+mlds_type_to_ilds_type(mlds__foreign_type(ForeignType))
+ = ilds__type([], Class) :-
+ Class = class(sym_name_to_structured_name(ForeignType)).
+
mlds_type_to_ilds_type(mlds__ptr_type(MLDSType)) =
ilds__type([], '&'(mlds_type_to_ilds_type(MLDSType))).
% XXX should use the classification now that it is available.
-mlds_type_to_ilds_type(mercury_type(Type, _Classification)) = ILType :-
+mlds_type_to_ilds_type(mercury_type(Type, _Classification, _)) = ILType :-
(
Type = term__functor(term__atom(Atom), [], _),
( Atom = "string", SimpleType = il_string_simple_type
@@ -1843,6 +1847,13 @@
mlds_type_to_ilds_type(mlds__unknown_type) = _ :-
unexpected(this_file, "mlds_type_to_ilds_type: unknown_type").
+
+:- func sym_name_to_structured_name(sym_name) = structured_name.
+
+sym_name_to_structured_name(unqualified(Name)) = [Name].
+sym_name_to_structured_name(qualified(Specifier, Name))
+ = sym_name_to_structured_name(Specifier) ++ [Name].
+
%-----------------------------------------------------------------------------
%
% Name mangling.
@@ -2110,16 +2121,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.
%-----------------------------------------------------------------------------%
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.2
diff -u -r1.2 mlds_to_java.m
--- compiler/mlds_to_java.m 2001/03/01 15:52:35 1.2
+++ compiler/mlds_to_java.m 2001/04/09 13:06:37
@@ -61,7 +61,6 @@
:- import_module ml_code_util. % for ml_gen_mlds_var_decl, which is used by
% the code that handles derived classes
:- import_module ml_type_gen. % for ml_gen_type_name
-:- import_module export. % for export__type_to_type_string
:- import_module globals, options, passes_aux.
:- import_module builtin_ops.
:- import_module prog_data, prog_out, type_util, error_util.
@@ -157,7 +156,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
@@ -168,7 +167,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
@@ -861,21 +860,24 @@
:- 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__cont_type(_)) = "null".
get_java_type_initializer(mlds__commit_type) = "null".
get_java_type_initializer(mlds__native_bool_type) = "false".
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".
@@ -1208,12 +1210,14 @@
:- 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(mlds__native_int_type) --> io__write_string("int").
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),
@@ -1882,9 +1886,10 @@
(
{ TargetType = ArgType }
;
- { TargetType =
- mercury_type(_, TargetBuiltinType),
- ArgType = mercury_type(_, ArgBuiltinType),
+ { TargetType = mercury_type(
+ _, TargetBuiltinType, _),
+ ArgType = mercury_type(
+ _, ArgBuiltinType, _),
TargetBuiltinType = ArgBuiltinType }
)
@@ -2093,17 +2098,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/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.65
diff -u -r1.65 module_qual.m
--- compiler/module_qual.m 2001/04/03 03:20:06 1.65
+++ compiler/module_qual.m 2001/04/09 13:06:38
@@ -210,7 +210,12 @@
collect_mq_info_2(func(_,_,__,_,_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pred_mode(_,_,_,_,_), Info, Info).
collect_mq_info_2(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) ->
+ add_type_defn(abstract_type(SymName, []), Info0, Info)
+ ;
+ Info = Info0
+ ).
collect_mq_info_2(assertion(Goal, _ProgVarSet), Info0, Info) :-
process_assert(Goal, SymNames, Success),
(
@@ -901,6 +906,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(Type0, SymName, F),
+ foreign_type(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.158
diff -u -r1.158 modules.m
--- compiler/modules.m 2001/04/08 08:59:21 1.158
+++ compiler/modules.m 2001/04/09 13:06:39
@@ -1029,6 +1029,7 @@
pragma_allowed_in_interface(foreign_decl(_, _), no).
pragma_allowed_in_interface(foreign_code(_, _), no).
pragma_allowed_in_interface(foreign_proc(_, _, _, _, _, _), no).
+pragma_allowed_in_interface(foreign_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.44
diff -u -r1.44 pragma_c_gen.m
--- compiler/pragma_c_gen.m 2001/04/03 03:20:14 1.44
+++ compiler/pragma_c_gen.m 2001/04/09 13:06:40
@@ -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.
@@ -423,13 +423,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,
@@ -637,8 +637,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) },
@@ -1090,21 +1090,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.65
diff -u -r1.65 prog_data.m
--- compiler/prog_data.m 2001/04/03 03:20:15 1.65
+++ compiler/prog_data.m 2001/04/09 13:06:40
@@ -158,6 +158,9 @@
% whether or not the code is thread-safe
% PredName, Predicate or Function, Vars/Mode,
% VarNames, Foreign Code Implementation Info
+
+ ; foreign_type((type), sym_name, sym_name)
+ % MercuryType, MercuryTypeName, ForeignType
; type_spec(sym_name, sym_name, arity, maybe(pred_or_func),
maybe(list(mode)), type_subst, tvarset)
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.30
diff -u -r1.30 prog_io_pragma.m
--- compiler/prog_io_pragma.m 2001/04/03 03:20:16 1.30
+++ compiler/prog_io_pragma.m 2001/04/09 13:06:40
@@ -70,6 +70,44 @@
ErrorTerm)
).
+parse_pragma_type(ModuleName, "foreign_type", PragmaTerms,
+ ErrorTerm, _VarSet, Result) :-
+ ( PragmaTerms = [MercuryName, ForeignName] ->
+ parse_implicitly_qualified_term(ModuleName, MercuryName,
+ ErrorTerm, "`:- pragma unused_args' 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(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(
+ "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",
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.12
diff -u -r1.12 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 2001/02/20 07:52:19 1.12
+++ compiler/rtti_to_mlds.m 2001/04/09 13:06:41
@@ -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, []) :-
@@ -249,7 +249,7 @@
Init = gen_init_pseudo_type_info_defn(Pseudo, ModuleName).
:- func ml_string_type = mlds__type.
-ml_string_type = mercury_type(string_type, str_type).
+ml_string_type = mercury_type(string_type, str_type, "MR_String").
:- func gen_init_functors_info(type_ctor_functors_info, module_name,
rtti_type_id) = mlds__initializer.
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 2000/09/18 11:51:47 1.14
+++ compiler/term_util.m 2001/04/09 13:06:41
@@ -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 2001/03/18 23:09:59 1.13
+++ compiler/type_ctor_info.m 2001/04/09 13:06:41
@@ -87,6 +87,8 @@
map__lookup(TypeTable, TypeId, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
TypeBody \= abstract_type,
+ % XXXX
+ TypeBody \= foreign_type(_),
\+ type_id_has_hand_defined_rtti(TypeId)
->
type_ctor_info__gen_type_ctor_gen_info(TypeId,
@@ -254,6 +256,15 @@
error("type_ctor_layout: sorry, undiscriminated union unimplemented\n")
;
TypeBody = abstract_type,
+ TypeCtorRep = unknown,
+ NumFunctors = -1,
+ FunctorsInfo = no_functors,
+ LayoutInfo = no_layout,
+ TypeTables = [],
+ NumPtags = -1
+ ;
+ % XXXX
+ TypeBody = foreign_type(_),
TypeCtorRep = unknown,
NumFunctors = -1,
FunctorsInfo = no_functors,
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.92
diff -u -r1.92 unify_proc.m
--- compiler/unify_proc.m 2001/03/18 23:10:00 1.92
+++ compiler/unify_proc.m 2001/04/09 13:06:46
@@ -744,6 +744,9 @@
;
{ TypeBody = abstract_type },
{ error("trying to create unify proc for abstract type") }
+ ;
+ { TypeBody = foreign_type(_) },
+ { error("trying to create unify proc for foreign type") }
).
% This predicate generates the bodies of index predicates for the
@@ -798,6 +801,9 @@
;
{ TypeBody = abstract_type },
{ error("trying to create index proc for abstract type") }
+ ;
+ { TypeBody = foreign_type(_) },
+ { error("trying to create index proc for foreign type") }
).
:- pred unify_proc__generate_compare_clauses((type)::in, hlds_type_body::in,
@@ -865,6 +871,9 @@
;
{ TypeBody = abstract_type },
{ error("trying to create compare proc for abstract type") }
+ ;
+ { TypeBody = foreign_type(_) },
+ { 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