[m-rev.] for review: C foreign types
Peter Ross
peter.ross at miscrit.be
Sat May 4 03:56:21 AEST 2002
Estimated hours taken: 16
Branches: main
Get pragma foreign_type working for the C backend.
doc/reference_manual.texi:
Document C pragma foreign_types.
compiler/prog_data.m:
Add il_foreign_type and c_foreign_type which contain all the
necessary data to output a foreign_type on the respective backends.
Change foreign_language_type to refer to these new types.
compiler/prog_io_pragma.m:
Handle the changes to foreign_language_type, and parse C
foreign_type declarations.
compiler/hlds_data.m:
Change the hlds_data__foreign_type type so that it records both the
C and IL foreign types. This will allow one to output both foreign
type declarations when doing intermodule optimization.
compiler/make_hlds.m:
Changes so that we store both the IL and C foreign types in
hlds_data__foreign_type.
Also add an error checking pass where we check that there is a
foreign type for the back-end we are currently compiling to.
compiler/foreign.m:
Change to_exported_type so that it works for both the C and IL
backends by getting either the C or IL foreign_type definition.
compiler/llds.m:
compiler/pragma_c_gen.m:
Change pragma_c_input and pragma_c_output so that they record
whether or not a type is a foreign_type and if so what is the string
which represents that foreign_type.
compiler/llds_out.m:
When outputting pragma c_code variables that represent foreign_types
get the casts correct. Note that this adds the constraint on C
foreign types that they are word sized, as all we are doing is
casts, not boxing and unboxing.
compiler/mlds.m:
Change mlds__foreign_type so that we store whether a type is an IL
type or a C type. It is the responsibility of the code generator
that we never create a reference to a IL foreign type when on the C
back-end, and vice versa.
compiler/mercury_to_mercury.m:
Handle changes to prog_data__foreign_type.
compiler/hlds_out.m:
compiler/intermod.m:
compiler/magic_util.m:
compiler/ml_code_gen.m:
compiler/ml_type_gen.m:
compiler/recompilation_usage.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/unify_proc.m:
Handle changes to hlds_data__foreign_type.
compiler/exprn_aux.m:
compiler/livemap.m:
compiler/middle_rec.m:
compiler/opt_util.m:
Handle changes to the pragma_c_input and pragma_c_output types.
compiler/ml_code_util.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_il.m:
compiler/mlds_to_java.m:
compiler/mlds_to_c.m:
Handle changes to mlds__foreign_type.
Here is interdiff
reverted:
--- compiler/exprn_aux.m 5 Mar 2002 12:05:20 -0000
+++ compiler/exprn_aux.m 24 Apr 2001 03:58:55 -0000 1.41
@@ -599,20 +599,20 @@
exprn_aux__substitute_lval_in_pragma_c_input(OldLval, NewLval, Out0, Out,
N0, N) :-
+ Out0 = pragma_c_input(Name, Type, Rval0),
- Out0 = pragma_c_input(Name, Type, Rval0, MaybeForeign),
exprn_aux__substitute_lval_in_rval_count(OldLval, NewLval, Rval0, Rval,
N0, N),
+ Out = pragma_c_input(Name, Type, Rval).
- Out = pragma_c_input(Name, Type, Rval, MaybeForeign).
:- pred exprn_aux__substitute_lval_in_pragma_c_output(lval::in, lval::in,
pragma_c_output::in, pragma_c_output::out, int::in, int::out) is det.
exprn_aux__substitute_lval_in_pragma_c_output(OldLval, NewLval, Out0, Out,
N0, N) :-
+ Out0 = pragma_c_output(Lval0, Type, Name),
- Out0 = pragma_c_output(Lval0, Type, Name, MaybeForeign),
exprn_aux__substitute_lval_in_lval_count(OldLval, NewLval, Lval0, Lval,
N0, N),
+ Out = pragma_c_output(Lval, Type, Name).
- Out = pragma_c_output(Lval, Type, Name, MaybeForeign).
:- pred exprn_aux__substitute_lval_in_rval_count(lval::in, lval::in,
rval::in, rval::out, int::in, int::out) is det.
reverted:
--- compiler/foreign.m 5 Mar 2002 12:05:21 -0000
+++ compiler/foreign.m 16 Jan 2002 01:13:18 -0000 1.10
@@ -71,7 +71,7 @@
:- func foreign__non_foreign_type((type)) = exported_type.
% Given an arbitary mercury type, get the exported_type representation
+ % of that type.
- % of that type on the current backend.
:- func foreign__to_exported_type(module_info, (type)) = exported_type.
% Given a representation of a type determine the string which
@@ -576,35 +576,13 @@
to_exported_type(ModuleInfo, Type) = ExportType :-
module_info_types(ModuleInfo, Types),
- module_info_globals(ModuleInfo, Globals),
- globals__get_target(Globals, Target),
(
type_to_type_id(Type, TypeId, _),
map__search(Types, TypeId, TypeDefn)
->
hlds_data__get_type_defn_body(TypeDefn, Body),
+ ( Body = foreign_type(_, ForeignType, _) ->
+ ExportType = foreign(ForeignType)
- ( Body = foreign_type(MaybeIL, MaybeC) ->
- ( Target = c,
- ( MaybeC = yes(c(NameStr)),
- Name = unqualified(NameStr)
- ; MaybeC = no,
- error("to_exported_type: no C type")
- )
- ; Target = il,
- ( MaybeIL = yes(il(_, _, Name))
- ; MaybeIL = no,
- error("to_exported_type: no IL type")
- )
- ; Target = java,
- error("to_exported_type: java NYI")
- ; Target = asm,
- ( MaybeC = yes(c(NameStr)),
- Name = unqualified(NameStr)
- ; MaybeC = no,
- error("to_exported_type: no C type")
- )
- ),
- ExportType = foreign(Name)
;
ExportType = mercury(Type)
)
@@ -615,12 +593,8 @@
to_type_string(Lang, ModuleInfo, Type) =
to_type_string(Lang, to_exported_type(ModuleInfo, Type)).
+to_type_string(c, foreign(_ForeignType)) = _ :-
+ sorry(this_file, "foreign types on a C backend").
-to_type_string(c, foreign(ForeignType)) = Result :-
- ( ForeignType = unqualified(Result0) ->
- Result = Result0
- ;
- error("to_type_string: qualifed C type")
- ).
to_type_string(csharp, foreign(ForeignType)) = Result :-
sym_name_to_string(ForeignType, ".", Result).
to_type_string(managed_cplusplus, foreign(ForeignType)) = Result ++ " *":-
reverted:
--- compiler/hlds_data.m 5 Mar 2002 12:05:21 -0000
+++ compiler/hlds_data.m 26 Feb 2002 02:45:36 -0000 1.66
@@ -299,8 +299,12 @@
)
; eqv_type(type)
; foreign_type(
+ bool, % is the type already boxed
+ sym_name, % structured name of foreign type
+ % which represents the mercury type.
+ string % Location of the definition for this
+ % type (such as assembly or
+ % library name)
- il :: maybe(il_foreign_type),
- c :: maybe(c_foreign_type)
)
; abstract_type.
reverted:
--- compiler/hlds_out.m 5 Mar 2002 12:05:22 -0000
+++ compiler/hlds_out.m 27 Feb 2002 17:41:06 -0000 1.276
@@ -2722,7 +2722,7 @@
hlds_out__write_type_body(_Indent, _Tvarset, abstract_type) -->
io__write_string(".\n").
+hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_, _, _)) -->
-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),
reverted:
--- compiler/intermod.m 5 Mar 2002 12:05:23 -0000
+++ compiler/intermod.m 26 Feb 2002 02:45:39 -0000 1.113
@@ -1215,7 +1215,7 @@
{ Body = abstract_type },
{ TypeBody = abstract_type }
;
+ { Body = foreign_type(_, _, _) },
- { Body = foreign_type(_, _) },
{ TypeBody = abstract_type },
% XXX trd
% Also here we need to output the pragma
reverted:
--- compiler/livemap.m 5 Mar 2002 12:05:23 -0000
+++ compiler/livemap.m 24 Apr 2001 03:58:56 -0000 1.51
@@ -424,7 +424,7 @@
livemap__build_livemap_pragma_inputs([], Livevals, Livevals).
livemap__build_livemap_pragma_inputs([Input | Inputs], Livevals0, Livevals) :-
+ Input = pragma_c_input(_, _, Rval),
- Input = pragma_c_input(_, _, Rval, _),
( Rval = lval(Lval) ->
livemap__insert_proper_liveval(Lval, Livevals0, Livevals1)
;
reverted:
--- compiler/llds.m 5 Mar 2002 12:05:24 -0000
+++ compiler/llds.m 6 Nov 2001 15:20:46 -0000 1.280
@@ -551,17 +551,15 @@
% A pragma_c_input represents the code that initializes one
% of the input variables for a pragma_c instruction.
:- type pragma_c_input
+ ---> pragma_c_input(string, type, rval).
+ % variable name, type, variable value.
- ---> pragma_c_input(string, type, rval, maybe(string)).
- % variable name, type, variable value,
- % maybe C type if foreign type.
% A pragma_c_output represents the code that stores one of
% of the outputs for a pragma_c instruction.
:- type pragma_c_output
+ ---> pragma_c_output(lval, type, string).
- ---> pragma_c_output(lval, type, string, maybe(string)).
% where to put the output val, type and name
% of variable containing the output val
- % followed by maybe C type if foreign type.
% see runtime/mercury_trail.h
:- type reset_trail_reason
reverted:
--- compiler/llds_out.m 5 Mar 2002 12:05:25 -0000
+++ compiler/llds_out.m 20 Feb 2002 03:14:07 -0000 1.186
@@ -1945,7 +1945,7 @@
output_pragma_input_rval_decls([], DeclSet, DeclSet) --> [].
output_pragma_input_rval_decls([I | Inputs], DeclSet0, DeclSet) -->
+ { I = pragma_c_input(_VarName, _Type, Rval) },
- { I = pragma_c_input(_VarName, _Type, Rval, _) },
output_rval_decls(Rval, "\t", "\t", 0, _N, DeclSet0, DeclSet1),
output_pragma_input_rval_decls(Inputs, DeclSet1, DeclSet).
@@ -1956,7 +1956,7 @@
output_pragma_inputs([]) --> [].
output_pragma_inputs([I|Inputs]) -->
+ { I = pragma_c_input(VarName, Type, Rval) },
- { I = pragma_c_input(VarName, Type, Rval, MaybeForeignType) },
io__write_string("\t"),
io__write_string(VarName),
io__write_string(" = "),
@@ -1970,11 +1970,6 @@
->
output_rval_as_type(Rval, float)
;
- ( { MaybeForeignType = yes(ForeignTypeStr) } ->
- io__write_string("(" ++ ForeignTypeStr ++ ") ")
- ;
- []
- ),
output_rval_as_type(Rval, word)
),
io__write_string(";\n"),
@@ -1987,7 +1982,7 @@
output_pragma_output_lval_decls([], DeclSet, DeclSet) --> [].
output_pragma_output_lval_decls([O | Outputs], DeclSet0, DeclSet) -->
+ { O = pragma_c_output(Lval, _Type, _VarName) },
- { O = pragma_c_output(Lval, _Type, _VarName, _) },
output_lval_decls(Lval, "\t", "\t", 0, _N, DeclSet0, DeclSet1),
output_pragma_output_lval_decls(Outputs, DeclSet1, DeclSet).
@@ -1998,7 +1993,7 @@
output_pragma_outputs([]) --> [].
output_pragma_outputs([O|Outputs]) -->
+ { O = pragma_c_output(Lval, Type, VarName) },
- { O = pragma_c_output(Lval, Type, VarName, MaybeForeignType) },
io__write_string("\t"),
output_lval_as_word(Lval),
io__write_string(" = "),
@@ -2014,11 +2009,6 @@
io__write_string(VarName),
io__write_string(")")
;
- ( { MaybeForeignType = yes(_) } ->
- output_llds_type_cast(word)
- ;
- []
- ),
io__write_string(VarName)
),
io__write_string(";\n"),
reverted:
--- compiler/magic_util.m 5 Mar 2002 12:05:26 -0000
+++ compiler/magic_util.m 26 Feb 2002 02:45:40 -0000 1.18
@@ -1377,7 +1377,7 @@
{ 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(_, _, _), _, _, _) -->
-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,
reverted:
--- compiler/make_hlds.m 5 Mar 2002 12:05:30 -0000
+++ compiler/make_hlds.m 26 Feb 2002 02:45:41 -0000 1.401
@@ -396,18 +396,21 @@
{ Pragma = foreign_proc(_, _, _, _, _, _) },
{ Module = Module0 }
;
- % Note that we check during add_item_clause that we have
- % defined a foreign_type which is usable by the back-end
- % we are compiling on.
{ Pragma = foreign_type(ForeignType, _MercuryType, Name) },
+ { ForeignType = il(RefOrVal,
+ ForeignTypeLocation, ForeignTypeName) },
+
+ { RefOrVal = reference,
+ IsBoxed = yes
+ ; RefOrVal = value,
+ IsBoxed = no
+ },
+
{ varset__init(VarSet) },
{ Args = [] },
+ { Body = foreign_type(IsBoxed,
+ ForeignTypeName, ForeignTypeLocation) },
- { ForeignType = il(ILForeignType),
- Body = foreign_type(yes(ILForeignType), no)
- ; ForeignType = c(CForeignType),
- Body = foreign_type(no, yes(CForeignType))
- },
{ Cond = true },
{ TypeId = Name - 0 },
@@ -791,61 +794,6 @@
add_pragma_type_spec(Pragma, Context, Module0, Module,
Info0, Info)
;
- { Pragma = foreign_type(_, _, Name) }
- ->
- { TypeId = Name - 0 },
- { module_info_types(Module0, Types) },
- { TypeStr = error_util__describe_sym_name_and_arity(
- Name / 0) },
- (
- { map__search(Types, TypeId, Defn) },
- { hlds_data__get_type_defn_body(Defn, Body) },
- { Body = foreign_type(MaybeIL, MaybeC) }
- ->
- { module_info_globals(Module0, Globals) },
- { globals__lookup_bool_option(Globals, target_code_only,
- TargetCode) },
- ( { TargetCode = yes } ->
- { globals__get_target(Globals, Target) },
- ( { Target = c },
- ( { MaybeC = yes(_) },
- { Module = Module0 }
- ; { MaybeC = no },
- { ErrorPieces = [
- words("Error: No C pragma"),
- words("foreign_type for"),
- fixed(TypeStr)
- ] },
- error_util__write_error_pieces(Context,
- 0, ErrorPieces),
- { module_info_incr_errors(Module0, Module) }
- )
- ; { Target = il },
- ( { MaybeIL = yes(_) },
- { Module = Module0 }
- ; { MaybeIL = no },
- { ErrorPieces = [
- words("Error: No IL pragma"),
- words("foreign_type for"),
- fixed(TypeStr)
- ] },
- error_util__write_error_pieces(Context,
- 0, ErrorPieces),
- { module_info_incr_errors(Module0, Module) }
- )
- ; { Target = java },
- { Module = Module0 }
- ; { Target = asm },
- { Module = Module0 }
- )
- ;
- { Module = Module0 }
- )
- ;
- { error("add_item_clause: unable to find foreign type") }
- ),
- { Info = Info0 }
- ;
% don't worry about any pragma decs but c_code, tabling,
% type_spec and fact_table here
{ Module = Module0 },
@@ -1968,13 +1916,7 @@
module_info_set_types(Module0, Types, Module)
}
;
+
- { merge_foreign_type_bodies(Body, Body_2, NewBody) }
- ->
- { hlds_data__set_type_defn(TVarSet_2, Params_2,
- NewBody, Status, Context, T3) },
- { map__det_update(Types0, TypeId, T3, Types) },
- { module_info_set_types(Module0, Types, Module) }
- ;
% otherwise issue an error message if the second
% definition wasn't read while reading .opt files.
{ Status = opt_imported }
@@ -2061,19 +2003,6 @@
[]
)
).
-
-:- pred merge_foreign_type_bodies(hlds_type_body::in,
- hlds_type_body::in, hlds_type_body::out) is semidet.
-
-merge_foreign_type_bodies(foreign_type(MaybeILA, MaybeCA),
- foreign_type(MaybeILB, MaybeCB),
- foreign_type(MaybeIL, MaybeC)) :-
- merge_maybe(MaybeILA, MaybeILB, MaybeIL),
- merge_maybe(MaybeCA, MaybeCB, MaybeC).
-
-:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
-merge_maybe(yes(T), no, yes(T)).
-merge_maybe(no, yes(T), yes(T)).
:- pred make_status_abstract(import_status, import_status).
:- mode make_status_abstract(in, out) is det.
reverted:
--- compiler/mercury_to_mercury.m 5 Mar 2002 12:05:31 -0000
+++ compiler/mercury_to_mercury.m 26 Feb 2002 02:45:45 -0000 1.206
@@ -496,28 +496,20 @@
;
{ Pragma = foreign_type(ForeignType, _MercuryType,
MercuryTypeSymName) },
+ { ForeignType = il(RefOrVal, ForeignLocStr, ForeignTypeName) },
io__write_string(":- pragma foreign_type("),
+ io__write_string("il, "),
- ( { ForeignType = il(_) },
- io__write_string("il, ")
- ; { ForeignType = c(_) },
- io__write_string("c, ")
- ),
mercury_output_sym_name(MercuryTypeSymName),
io__write_string(", "),
+ ( { RefOrVal = reference },
+ io__write_string("\"class [")
+ ; { RefOrVal = value },
+ io__write_string("\"valuetype [")
+ ),
+ io__write_string(ForeignLocStr),
+ io__write_string("]"),
+ { sym_name_to_string(ForeignTypeName, ".", ForeignTypeStr) },
- io__write_string(", \""),
- { ForeignType = il(il(RefOrVal,
- ForeignLocStr, ForeignTypeName)),
- ( RefOrVal = reference,
- RefOrValStr = "class "
- ; RefOrVal = value,
- RefOrValStr = "valuetype "
- ),
- sym_name_to_string(ForeignTypeName, ".", NameStr),
- ForeignTypeStr = RefOrValStr ++ "[" ++ ForeignLocStr ++
- "]" ++ NameStr
- ; ForeignType = c(c(ForeignTypeStr))
- },
io__write_string(ForeignTypeStr),
io__write_string("\").\n")
;
reverted:
--- compiler/middle_rec.m 5 Mar 2002 12:05:31 -0000
+++ compiler/middle_rec.m 24 Apr 2001 03:58:59 -0000 1.87
@@ -545,7 +545,7 @@
insert_pragma_c_input_registers([], Used, Used).
insert_pragma_c_input_registers([Input|Inputs], Used0, Used) :-
+ Input = pragma_c_input(_, _, Rval),
- Input = pragma_c_input(_, _, Rval, _),
middle_rec__find_used_registers_rval(Rval, Used0, Used1),
insert_pragma_c_input_registers(Inputs, Used1, Used).
@@ -555,7 +555,7 @@
insert_pragma_c_output_registers([], Used, Used).
insert_pragma_c_output_registers([Output|Outputs], Used0, Used) :-
+ Output = pragma_c_output(Lval, _, _),
- Output = pragma_c_output(Lval, _, _, _),
middle_rec__find_used_registers_lval(Lval, Used0, Used1),
insert_pragma_c_output_registers(Outputs, Used1, Used).
reverted:
--- compiler/ml_code_gen.m 5 Mar 2002 12:05:32 -0000
+++ compiler/ml_code_gen.m 5 Mar 2002 10:59:19 -0000 1.110
@@ -850,8 +850,6 @@
ml_gen_imports(ModuleInfo, MLDS_ImportList) :-
% Determine all the mercury imports.
- module_info_globals(ModuleInfo, Globals),
- globals__get_target(Globals, Target),
module_info_get_all_deps(ModuleInfo, AllImports),
P = (func(Name) = mercury_import(mercury_module_name_to_mlds(Name))),
@@ -860,16 +858,7 @@
module_info_types(ModuleInfo, Types),
list__filter_map((pred(TypeDefn::in, Import::out) is semidet :-
hlds_data__get_type_defn_body(TypeDefn, Body),
+ Body = foreign_type(_, _, Location),
- Body = foreign_type(MaybeIL, _MaybeC),
- ( Target = c,
- fail
- ; Target = il,
- MaybeIL = yes(il(_, Location, _))
- ; Target = java,
- fail
- ; Target = asm,
- fail
- ),
Name = il_assembly_name(mercury_module_name_to_mlds(
unqualified(Location))),
Import = foreign_import(Name)
reverted:
--- compiler/ml_code_util.m 5 Mar 2002 12:05:33 -0000
+++ compiler/ml_code_util.m 4 Mar 2002 07:31:35 -0000 1.57
@@ -2113,11 +2113,14 @@
ml_type_might_contain_pointers(mlds__native_float_type) = no.
ml_type_might_contain_pointers(mlds__native_bool_type) = no.
ml_type_might_contain_pointers(mlds__native_char_type) = no.
+ml_type_might_contain_pointers(mlds__foreign_type(_, _, _)) = _ :-
+ % It might contain pointers, so it's not safe to return `no',
+ % but it also might not be word-sized, so it's not safe to
+ % return `yes'. Currently this case should not occur, since
+ % currently `foreign_type' is only used for the IL back-end,
+ % where GC is handled by the target language.
+ unexpected(this_file, "--gc accurate and foreign_type").
+
- % Due to constraints from the LLDS back-end this type must be
- % word sized and on all other backends where this type is
- % supported garbage collection is handled by the target
- % language, so it is safe to return yes.
-ml_type_might_contain_pointers(mlds__foreign_type(_)) = yes.
ml_type_might_contain_pointers(mlds__class_type(_, _, Category)) =
(if Category = mlds__enum then no else yes).
ml_type_might_contain_pointers(mlds__ptr_type(_)) = yes.
reverted:
--- compiler/ml_type_gen.m 5 Mar 2002 12:05:34 -0000
+++ compiler/ml_type_gen.m 26 Feb 2002 02:45:48 -0000 1.24
@@ -124,7 +124,7 @@
Ctors, TagValues, MaybeEqualityMembers)
).
% XXX Fixme! Same issues here as for eqv_type/1.
+ml_gen_type_2(foreign_type(_, _, _), _, _, _) --> [].
-ml_gen_type_2(foreign_type(_, _), _, _, _) --> [].
%-----------------------------------------------------------------------------%
%
reverted:
--- compiler/mlds.m 5 Mar 2002 12:05:34 -0000
+++ compiler/mlds.m 3 Mar 2002 17:27:08 -0000 1.85
@@ -628,9 +628,12 @@
; 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.
- % This is a type of the MLDS target language.
; mlds__foreign_type(
+ bool, % is type already boxed?
+ sym_name, % structured name representing the type
+ string % location of the type (ie assembly)
- foreign_language_type
)
% MLDS types defined using mlds__class_defn
@@ -1593,7 +1596,7 @@
%-----------------------------------------------------------------------------%
:- implementation.
+:- import_module foreign, modules.
-:- import_module error_util, globals, foreign, modules.
:- import_module int, term, string, require.
%-----------------------------------------------------------------------------%
@@ -1631,28 +1634,10 @@
module_info_types(ModuleInfo, Types),
map__search(Types, TypeId, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
+ Body = foreign_type(IsBoxed, ForeignType, ForeignLocation)
- Body = foreign_type(MaybeIL, MaybeC)
->
+ MLDSType = mlds__foreign_type(IsBoxed,
+ ForeignType, ForeignLocation)
- module_info_globals(ModuleInfo, Globals),
- globals__get_target(Globals, Target),
- ( Target = c,
- ( MaybeC = yes(CForeignType),
- ForeignType = c(CForeignType)
- ; MaybeC = no,
- error("mercury_type_to_mlds_type: No C foreign type")
- )
- ; Target = il,
- ( MaybeIL = yes(ILForeignType),
- ForeignType = il(ILForeignType)
- ; MaybeIL = no,
- error("mercury_type_to_mlds_type: No IL foreign type")
- )
- ; Target = java,
- sorry(this_file, "foreign types on the java backend")
- ; Target = asm,
- sorry(this_file, "foreign types on the asm backend")
- ),
- MLDSType = mlds__foreign_type(ForeignType)
;
classify_type(Type, ModuleInfo, Category),
ExportedType = to_exported_type(ModuleInfo, Type),
@@ -1861,10 +1846,5 @@
finality_bits(Finality) \/
constness_bits(Constness) \/
abstractness_bits(Abstractness).
-
-%-----------------------------------------------------------------------------%
-
-:- func this_file = string.
-this_file = "mlds.m".
%-----------------------------------------------------------------------------%
reverted:
--- compiler/mlds_to_c.m 5 Mar 2002 12:05:36 -0000
+++ compiler/mlds_to_c.m 27 Feb 2002 13:56:58 -0000 1.121
@@ -661,12 +661,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__foreign_type(ForeignType)) -->
- ( { ForeignType = c(c(Name)) },
- io__write_string(Name)
- ; { ForeignType = il(_) },
- { error("mlds_output_pragma_export_type: il 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(_)) -->
@@ -1639,12 +1635,8 @@
mlds_output_type_prefix(mlds__native_bool_type) -->
io__write_string("MR_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__foreign_type(ForeignType)) -->
- ( { ForeignType = c(c(Name)) },
- io__write_string(Name)
- ; { ForeignType = il(_) },
- { error("mlds_output_type_prefix: il foreign_type") }
- ).
mlds_output_type_prefix(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
%
@@ -1811,8 +1803,7 @@
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(_, _, _), _) --> [].
- % XXX Currently we can't output a type suffix.
-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) -->
reverted:
--- compiler/mlds_to_gcc.m 5 Mar 2002 12:05:37 -0000
+++ compiler/mlds_to_gcc.m 18 Feb 2002 07:00:57 -0000 1.63
@@ -1685,7 +1685,7 @@
).
build_type(mercury_type(Type, TypeCategory, _), _, _, GCC_Type) -->
build_mercury_type(Type, TypeCategory, GCC_Type).
+build_type(mlds__foreign_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) --> [].
reverted:
--- compiler/mlds_to_il.m 5 Mar 2002 12:05:38 -0000
+++ compiler/mlds_to_il.m 3 Mar 2002 12:12:49 -0000 1.106
@@ -2976,19 +2976,15 @@
mlds_type_to_ilds_type(_, mlds__native_float_type) = ilds__type([], float64).
+mlds_type_to_ilds_type(_, mlds__foreign_type(IsBoxed, ForeignType, Assembly))
-mlds_type_to_ilds_type(_, mlds__foreign_type(ForeignType))
= ilds__type([], Class) :-
+ sym_name_to_class_name(ForeignType, ForeignClassName),
+ ( IsBoxed = yes,
+ Class = class(structured_name(assembly(Assembly),
+ ForeignClassName, []))
+ ; IsBoxed = no,
+ Class = valuetype(structured_name(assembly(Assembly),
+ ForeignClassName, []))
- ( ForeignType = il(il(RefOrVal, Assembly, Type)),
- sym_name_to_class_name(Type, ForeignClassName),
- ( RefOrVal = reference,
- Class = class(structured_name(assembly(Assembly),
- ForeignClassName, []))
- ; RefOrVal = value,
- Class = valuetype(structured_name(assembly(Assembly),
- ForeignClassName, []))
- )
- ; ForeignType = c(_),
- error("mlds_to_il: c foreign type")
).
mlds_type_to_ilds_type(ILDataRep, mlds__ptr_type(MLDSType)) =
reverted:
--- compiler/mlds_to_java.m 5 Mar 2002 12:05:39 -0000
+++ compiler/mlds_to_java.m 22 Feb 2002 01:51:09 -0000 1.24
@@ -1250,7 +1250,7 @@
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(_, _, _)) = _ :-
-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".
@@ -1618,7 +1618,7 @@
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(_, _, _)) -->
-output_type(mlds__foreign_type(_)) -->
{ unexpected(this_file, "output_type: foreign_type NYI.") }.
output_type(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
reverted:
--- compiler/opt_util.m 5 Mar 2002 12:05:40 -0000
+++ compiler/opt_util.m 18 Feb 2002 07:00:58 -0000 1.113
@@ -1340,7 +1340,7 @@
pragma_c_inputs_get_rvals([], []).
pragma_c_inputs_get_rvals([I|Inputs], [R|Rvals]) :-
+ I = pragma_c_input(_Name, _Type, R),
- I = pragma_c_input(_Name, _Type, R, _),
pragma_c_inputs_get_rvals(Inputs, Rvals).
% extract the lvals from the pragma_c_output
@@ -1349,7 +1349,7 @@
pragma_c_outputs_get_lvals([], []).
pragma_c_outputs_get_lvals([O|Outputs], [L|Lvals]) :-
+ O = pragma_c_output(L, _Type, _Name),
- O = pragma_c_output(L, _Type, _Name, _),
pragma_c_outputs_get_lvals(Outputs, Lvals).
% determine all the rvals and lvals referenced by a list of instructions
reverted:
--- compiler/pragma_c_gen.m 5 Mar 2002 12:05:41 -0000
+++ compiler/pragma_c_gen.m 13 Feb 2002 09:56:25 -0000 1.48
@@ -44,7 +44,6 @@
:- import_module hlds_module, hlds_pred, llds_out, trace, tree.
:- import_module code_util, foreign.
:- import_module options, globals.
-:- import_module type_util, hlds_data, prog_out.
:- import_module bool, string, int, assoc_list, set, map, require, term.
@@ -669,8 +668,8 @@
{ 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) },
- input_descs_from_arg_info(InArgs, InputDescs),
- output_descs_from_arg_info(OutArgs, OutputDescs),
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
{ pred_info_module(PredInfo, ModuleName) },
@@ -1178,8 +1177,7 @@
code_info__produce_variable(Var, FirstCode, Rval),
% code_info__produce_variable_in_reg(Var, FirstCode, Lval),
% { Rval = lval(Lval) },
+ { Input = pragma_c_input(Name, Type, Rval) },
- get_maybe_foreign_type_name(Type, MaybeForeign),
- { Input = pragma_c_input(Name, Type, Rval, MaybeForeign) },
get_pragma_input_vars(Args, Inputs1, RestCode),
{ Inputs = [Input | Inputs1] },
{ Code = tree(FirstCode, RestCode) }
@@ -1189,27 +1187,6 @@
get_pragma_input_vars(Args, Inputs, Code)
).
-:- pred get_maybe_foreign_type_name((type)::in, maybe(string)::out,
- code_info::in, code_info::out) is det.
-
-get_maybe_foreign_type_name(Type, MaybeForeignType) -->
- code_info__get_module_info(Module),
- { module_info_types(Module, Types) },
- {
- type_to_type_id(Type, TypeId, _SubTypes),
- map__search(Types, TypeId, Defn),
- hlds_data__get_type_defn_body(Defn, Body),
- Body = foreign_type(_MaybeIL, MaybeC)
- ->
- ( MaybeC = yes(c(Name)),
- MaybeForeignType = yes(Name)
- ; MaybeC = no,
- error("get_maybe_foreign_type_name: no c foreigm type")
- )
- ;
- MaybeForeignType = no
- }.
-
%---------------------------------------------------------------------------%
% pragma_acquire_regs acquires a list of registers in which to place each
@@ -1240,12 +1217,10 @@
code_info__release_reg(Reg),
( code_info__variable_is_forward_live(Var) ->
code_info__set_var_location(Var, Reg),
- get_maybe_foreign_type_name(OrigType, MaybeForeign),
{
var_is_not_singleton(MaybeName, Name)
->
+ PragmaCOutput = pragma_c_output(Reg, OrigType, Name),
- PragmaCOutput = pragma_c_output(Reg, OrigType,
- Name, MaybeForeign),
Outputs = [PragmaCOutput | Outputs0]
;
Outputs = Outputs0
@@ -1263,24 +1238,22 @@
% input_descs_from_arg_info returns a list of pragma_c_inputs, which
% are pairs of rvals and (C) variables which receive the input value.
+:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out)
+ is det.
-:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out,
- code_info::in, code_info::out) is det.
+input_descs_from_arg_info([], []).
+input_descs_from_arg_info([Arg | Args], Inputs) :-
-input_descs_from_arg_info([], [], CodeInfo, CodeInfo).
-input_descs_from_arg_info([Arg | Args], Inputs, CodeInfo0, CodeInfo) :-
Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
(
var_is_not_singleton(MaybeName, Name)
->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
+ Input = pragma_c_input(Name, OrigType, lval(Reg)),
- get_maybe_foreign_type_name(OrigType, MaybeForeign,
- CodeInfo0, CodeInfo1),
- Input = pragma_c_input(Name, OrigType, lval(Reg), MaybeForeign),
Inputs = [Input | Inputs1],
+ input_descs_from_arg_info(Args, Inputs1)
- input_descs_from_arg_info(Args, Inputs1, CodeInfo1, CodeInfo)
;
+ input_descs_from_arg_info(Args, Inputs)
- input_descs_from_arg_info(Args, Inputs, CodeInfo0, CodeInfo)
).
%---------------------------------------------------------------------------%
@@ -1289,26 +1262,22 @@
% are pairs of names of output registers and (C) variables which hold the
% output value.
+:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out)
+ is det.
-:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out,
- code_info::in, code_info::out) is det.
+output_descs_from_arg_info([], []).
+output_descs_from_arg_info([Arg | Args], Outputs) :-
-output_descs_from_arg_info([], [], CodeInfo, CodeInfo).
-output_descs_from_arg_info([Arg | Args], Outputs, CodeInfo0, CodeInfo) :-
Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
- output_descs_from_arg_info(Args, Outputs0, CodeInfo0, CodeInfo1),
(
var_is_not_singleton(MaybeName, Name)
->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
+ Outputs = [pragma_c_output(Reg, OrigType, Name) | Outputs0]
- get_maybe_foreign_type_name(OrigType, MaybeForeign,
- CodeInfo1, CodeInfo),
- Outputs = [pragma_c_output(Reg, OrigType, Name, MaybeForeign) |
- Outputs0]
;
+ Outputs = Outputs0
+ ),
+ output_descs_from_arg_info(Args, Outputs0).
- Outputs = Outputs0,
- CodeInfo = CodeInfo1
- ).
%---------------------------------------------------------------------------%
reverted:
--- compiler/prog_data.m 5 Mar 2002 12:05:41 -0000
+++ compiler/prog_data.m 26 Feb 2002 02:45:49 -0000 1.79
@@ -314,12 +314,11 @@
% for each of these cases.
%
+:- type ref_or_val
+ ---> reference
+ ; value.
+
:- type foreign_language_type
- ---> il(il_foreign_type)
- ; c(c_foreign_type)
- .
-
-:- type il_foreign_type
---> il(
ref_or_val, % An indicator of whether the type is a
% reference of value type.
@@ -327,15 +326,6 @@
% assembly)
sym_name % The .NET type name
).
-
-:- type c_foreign_type
- ---> c(
- string % The C type name
- ).
-
-:- type ref_or_val
- ---> reference
- ; value.
%
% Stuff for tabling pragmas
reverted:
--- compiler/prog_io_pragma.m 5 Mar 2002 12:05:41 -0000
+++ compiler/prog_io_pragma.m 19 Feb 2002 09:48:21 -0000 1.47
@@ -224,19 +224,6 @@
InputTerm)
)
;
- Language = c
- ->
- (
- InputTerm = term__functor(term__string(CTypeName),
- [], _)
- ->
- Result = ok(c(c(CTypeName)))
- ;
- Result = error("invalid backend specification term",
- InputTerm)
- )
- ;
-
Result = error("unsupported language specified, unable to parse backend type", InputTerm)
).
@@ -247,7 +234,7 @@
(
parse_special_il_type_name(String0, ForeignTypeResult)
->
+ ForeignType = ok(ForeignTypeResult)
- ForeignType = ok(il(ForeignTypeResult))
;
string__append("class [", String1, String0),
string__sub_string_search(String1, "]", Index)
@@ -255,7 +242,7 @@
string__left(String1, Index, AssemblyName),
string__split(String1, Index + 1, _, TypeNameStr),
string_to_sym_name(TypeNameStr, ".", TypeSymName),
+ ForeignType = ok(il(reference, AssemblyName, TypeSymName))
- ForeignType = ok(il(il(reference, AssemblyName, TypeSymName)))
;
string__append("valuetype [", String1, String0),
string__sub_string_search(String1, "]", Index)
@@ -263,7 +250,7 @@
string__left(String1, Index, AssemblyName),
string__split(String1, Index + 1, _, TypeNameStr),
string_to_sym_name(TypeNameStr, ".", TypeSymName),
+ ForeignType = ok(il(value, AssemblyName, TypeSymName))
- ForeignType = ok(il(il(value, AssemblyName, TypeSymName)))
;
ForeignType = error(
"invalid foreign language type description", ErrorTerm)
@@ -272,7 +259,8 @@
% Parse all the special assembler names for all the builtin types.
% See Parition I 'Built-In Types' (Section 8.2.2) for the list
% of all builtin types.
+:- pred parse_special_il_type_name(string::in,
+ foreign_language_type::out) is semidet.
-:- pred parse_special_il_type_name(string::in, il_foreign_type::out) is semidet.
parse_special_il_type_name("bool", il(value, "mscorlib",
qualified(unqualified("System"), "Boolean"))).
reverted:
--- compiler/recompilation_usage.m 5 Mar 2002 12:05:42 -0000
+++ compiler/recompilation_usage.m 26 Feb 2002 02:45:53 -0000 1.5
@@ -1024,7 +1024,7 @@
recompilation_usage__find_items_used_by_type_body(eqv_type(Type)) -->
recompilation_usage__find_items_used_by_type(Type).
recompilation_usage__find_items_used_by_type_body(abstract_type) --> [].
+recompilation_usage__find_items_used_by_type_body(foreign_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.
reverted:
--- compiler/term_util.m 5 Mar 2002 12:05:42 -0000
+++ compiler/term_util.m 26 Feb 2002 02:45:53 -0000 1.17
@@ -267,7 +267,7 @@
Weights = Weights0
;
% This type does not introduce any functors
+ TypeBody = foreign_type(_, _, _),
- TypeBody = foreign_type(_, _),
Weights = Weights0
).
reverted:
--- compiler/type_ctor_info.m 5 Mar 2002 12:05:43 -0000
+++ compiler/type_ctor_info.m 26 Feb 2002 02:45:54 -0000 1.21
@@ -252,7 +252,7 @@
TypeTables = [],
NumPtags = -1
;
+ TypeBody = foreign_type(_, _, _),
- TypeBody = foreign_type(_, _),
TypeCtorRep = unknown,
NumFunctors = -1,
FunctorsInfo = no_functors,
reverted:
--- compiler/unify_proc.m 5 Mar 2002 12:05:43 -0000
+++ compiler/unify_proc.m 26 Feb 2002 02:45:54 -0000 1.104
@@ -755,7 +755,7 @@
unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
Clauses)
;
+ { TypeBody = foreign_type(_, _, _) },
- { TypeBody = foreign_type(_, _) },
unify_proc__build_call("nyi_foreign_type_unify", [H1, H2],
Context, Goal),
unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
@@ -811,7 +811,7 @@
% invoked.
{ error("trying to create index proc for eqv type") }
;
+ { TypeBody = foreign_type(_, _, _) },
- { TypeBody = foreign_type(_, _) },
{ error("trying to create index proc for a foreign type") }
;
{ TypeBody = abstract_type },
@@ -888,7 +888,7 @@
unify_proc__quantify_clauses_body([Res, H1, H2], Goal, Context,
Clauses)
;
+ { TypeBody = foreign_type(_, _, _) },
- { TypeBody = foreign_type(_, _) },
unify_proc__build_call("nyi_foreign_type_compare",
[Res, H1, H2], Context, Goal),
unify_proc__quantify_clauses_body([Res, H1, H2], Goal, Context,
reverted:
--- doc/reference_manual.texi 5 Mar 2002 12:05:48 -0000
+++ doc/reference_manual.texi 21 Feb 2002 14:20:44 -0000 1.242
@@ -5378,28 +5378,9 @@
@node Using pragma foreign_type for C
@subsubsection Using pragma foreign_type for C
+This pragma is currently not supported for C.
-The C @samp{pragma foreign_type} declaration is of the form:
+See the section on using C pointers (@pxref{Using C pointers}) for
- at example
-:- pragma foreign_type(c, @var{MercuryTypeName}, @var{CForeignType}).
- at end example
-
-The @var{CForeignType} can be any C type name that obeys the following
-restrictions.
-The type must fit into a machine word.
-The type must be contain no parts that would have to be output after a
-variable name in the generated C code.
-
-If the @var{MercuryTypeName} is the type of a parameter of a procedure
-defined using @samp{pragma foreign_proc},
-it will be passed to the foreign_proc's foreign language code
-as @var{CForeignType}.
-
-Furthermore, any Mercury procedure exported with @samp{pragma export}
-will use @var{CForeignType} as the type for any
-parameters whose Mercury type is @var{MercuryTypeName}.
-
-Also see the section on using C pointers (@pxref{Using C pointers}) for
information on how to use the c_pointer type with the C interface.
@c XXX we should eventually just move that section to here,
@c presenting it as an alternative to pragma foreign_type.
only in patch2:
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_type.m 3 May 2002 17:45:28 -0000
@@ -0,0 +1,56 @@
+:- module foreign_type.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+main -->
+ { _C = new(1, 2) },
+ { _E = north },
+ { _Pi = pi },
+ io__write_string("Success.\n").
+
+:- pragma foreign_decl(c, "
+typedef enum {
+ north,
+ east,
+ west,
+ south,
+} dirs;
+
+typedef struct {
+ int x, y;
+} coord;
+").
+
+:- type dir.
+:- pragma foreign_type(c, dir, "dirs").
+
+:- type coord.
+:- pragma foreign_type(c, coord, "coord").
+
+:- type double.
+:- pragma foreign_type(c, double, "double").
+
+:- func north = dir.
+:- pragma foreign_proc(c, north = (E::out),
+ [will_not_call_mercury, promise_pure], "
+ E = north;
+").
+
+:- func new(int, int) = coord.
+:- pragma foreign_proc(c, new(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure], "
+ C.x = X;
+ C.y = Y;
+").
+
+:- func pi = double.
+:- pragma foreign_proc(c, pi = (Pi::out),
+ [will_not_call_mercury, promise_pure], "
+ Pi = 3.14;
+").
only in patch2:
--- tests/invalid/Mmakefile 25 Mar 2002 21:13:29 -0000 1.108
+++ tests/invalid/Mmakefile 3 May 2002 17:45:28 -0000
@@ -52,6 +52,7 @@
ext_type_bug.m \
exported_mode.m \
field_syntax_error.m \
+ foreign_type.m \
func_errors.m \
funcs_as_preds.m \
ho_default_func_1.m \
only in patch2:
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type.m 3 May 2002 17:45:28 -0000
@@ -0,0 +1,94 @@
+:- module foreign_type.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- type coord.
+
+:- func new(int, int) = coord.
+
+:- func x(coord) = int.
+:- func y(coord) = int.
+
+main -->
+ { C = new(4, 5) },
+ io__write_string("X:"),
+ io__write_int(x(C)),
+ io__nl,
+ io__write_string("Y:"),
+ io__write_int(y(C)),
+ io__nl.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+% IL implementation
+:- pragma foreign_type(il, coord,
+ "class [foreign_type__csharp_code]coord").
+
+:- pragma foreign_decl("C#", "
+public class coord {
+ public int x;
+ public int y;
+}
+").
+
+:- pragma foreign_proc("C#", new(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure],
+"
+ C = new coord();
+ C.x = X;
+ C.y = Y;
+").
+
+:- pragma foreign_proc("C#", x(C::in) = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = C.x;
+").
+
+:- pragma foreign_proc("C#", y(C::in) = (Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ Y = C.y;
+").
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+% C implementation
+:- pragma foreign_type(c, coord, "coord *").
+
+:- pragma foreign_decl(c, "
+typedef struct {
+ int x, y;
+} coord;
+").
+
+:- pragma foreign_proc(c, new(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure],
+"
+ C = GC_NEW(coord);
+ C->x = X;
+ C->y = Y;
+").
+
+:- pragma foreign_proc(c, x(C::in) = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = C->x;
+").
+
+:- pragma foreign_proc(c, y(C::in) = (Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ Y = C->y;
+").
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
only in patch2:
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type.exp 3 May 2002 17:45:28 -0000
@@ -0,0 +1,2 @@
+X:4
+Y:5
only in patch2:
--- foreign/doc/reference_manual.texi 16 Mar 2002 05:37:03 -0000 1.246
+++ foreign/doc/reference_manual.texi 3 May 2002 17:45:27 -0000
@@ -5484,9 +5484,36 @@
@node Using pragma foreign_type for C
@subsubsection Using pragma foreign_type for C
-This pragma is currently not supported for C.
+The C @samp{pragma foreign_type} declaration is of the form:
-See the section on using C pointers (@pxref{Using C pointers}) for
+ at example
+:- pragma foreign_type(c, @var{MercuryTypeName}, @var{CForeignType}).
+ at end example
+
+The @var{CForeignType} can be any C type name that obeys the following
+restrictions.
+The following snippet of C code must evaluate to true
+ at code{sizeof(CForeignType) == sizeof(void *)},
+if not the result of using the foreign type is undefined.
+The type name must be such that no part of it is required after a
+variable name to be valid C.
+Function, array and incomplete types are not allowed.
+
+Currently only integer and pointer types are accepted as foreign_types,
+at a later date we plan to lift this restriction and allow enum, struct
+and float types.
+
+If the @var{MercuryTypeName} is the type of a parameter of a procedure
+defined using @samp{pragma foreign_proc},
+it will be passed to the foreign_proc's foreign language code
+as @var{CForeignType}.
+
+ at c XXX This is not currently true.
+ at c Furthermore, any Mercury procedure exported with @samp{pragma export}
+ at c will use @var{CForeignType} as the type for any
+ at c parameters whose Mercury type is @var{MercuryTypeName}.
+
+Also see the section on using C pointers (@pxref{Using C pointers}) for
information on how to use the c_pointer type with the C interface.
@c XXX we should eventually just move that section to here,
@c presenting it as an alternative to pragma foreign_type.
only in patch2:
--- foreign/compiler/unify_proc.m 28 Mar 2002 03:43:45 -0000 1.107
+++ foreign/compiler/unify_proc.m 3 May 2002 17:44:49 -0000
@@ -763,7 +763,7 @@
unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
Clauses)
;
- { TypeBody = foreign_type(_, _, _) },
+ { TypeBody = foreign_type(_, _) },
unify_proc__build_call("nyi_foreign_type_unify", [H1, H2],
Context, Goal),
unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
@@ -819,7 +819,7 @@
% invoked.
{ error("trying to create index proc for eqv type") }
;
- { TypeBody = foreign_type(_, _, _) },
+ { TypeBody = foreign_type(_, _) },
{ error("trying to create index proc for a foreign type") }
;
{ TypeBody = abstract_type },
@@ -896,7 +896,7 @@
unify_proc__quantify_clauses_body([Res, H1, H2], Goal, Context,
Clauses)
;
- { TypeBody = foreign_type(_, _, _) },
+ { TypeBody = foreign_type(_, _) },
unify_proc__build_call("nyi_foreign_type_compare",
[Res, H1, H2], Context, Goal),
unify_proc__quantify_clauses_body([Res, H1, H2], Goal, Context,
only in patch2:
--- foreign/compiler/type_ctor_info.m 24 Apr 2002 07:37:33 -0000 1.25
+++ foreign/compiler/type_ctor_info.m 3 May 2002 17:44:41 -0000
@@ -254,7 +254,7 @@
TypeTables = [],
NumPtags = -1
;
- TypeBody = foreign_type(_, _, _),
+ TypeBody = foreign_type(_, _),
TypeCtorRep = unknown,
NumFunctors = -1,
FunctorsInfo = no_functors,
only in patch2:
--- foreign/compiler/term_util.m 20 Mar 2002 12:37:28 -0000 1.19
+++ foreign/compiler/term_util.m 3 May 2002 17:44:40 -0000
@@ -270,7 +270,7 @@
Weights = Weights0
;
% This type does not introduce any functors
- TypeBody = foreign_type(_, _, _),
+ TypeBody = foreign_type(_, _),
Weights = Weights0
).
only in patch2:
--- foreign/compiler/special_pred.m 23 Apr 2002 17:49:16 -0000 1.31
+++ foreign/compiler/special_pred.m 3 May 2002 17:44:40 -0000
@@ -202,7 +202,7 @@
% polymorphism__process_generated_pred can't handle calls to
% polymorphic procedures after the initial polymorphism pass.
%
- Body \= foreign_type(_, _, _),
+ Body \= foreign_type(_, _),
% The special predicates for types with user-defined
% equality or existentially typed constructors are always
only in patch2:
--- foreign/compiler/recompilation.usage.m 20 Mar 2002 12:37:17 -0000 1.1
+++ foreign/compiler/recompilation.usage.m 3 May 2002 17:44:38 -0000
@@ -1045,7 +1045,7 @@
recompilation__usage__find_items_used_by_type_body(eqv_type(Type)) -->
recompilation__usage__find_items_used_by_type(Type).
recompilation__usage__find_items_used_by_type_body(abstract_type) --> [].
-recompilation__usage__find_items_used_by_type_body(foreign_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.
only in patch2:
--- foreign/compiler/prog_io_pragma.m 20 Mar 2002 12:37:13 -0000 1.49
+++ foreign/compiler/prog_io_pragma.m 3 May 2002 17:44:37 -0000
@@ -225,6 +225,19 @@
InputTerm)
)
;
+ Language = c
+ ->
+ (
+ InputTerm = term__functor(term__string(CTypeName),
+ [], _)
+ ->
+ Result = ok(c(c(CTypeName)))
+ ;
+ Result = error("invalid backend specification term",
+ InputTerm)
+ )
+ ;
+
Result = error("unsupported language specified, unable to parse backend type", InputTerm)
).
@@ -235,7 +248,7 @@
(
parse_special_il_type_name(String0, ForeignTypeResult)
->
- ForeignType = ok(ForeignTypeResult)
+ ForeignType = ok(il(ForeignTypeResult))
;
string__append("class [", String1, String0),
string__sub_string_search(String1, "]", Index)
@@ -243,7 +256,7 @@
string__left(String1, Index, AssemblyName),
string__split(String1, Index + 1, _, TypeNameStr),
string_to_sym_name(TypeNameStr, ".", TypeSymName),
- ForeignType = ok(il(reference, AssemblyName, TypeSymName))
+ ForeignType = ok(il(il(reference, AssemblyName, TypeSymName)))
;
string__append("valuetype [", String1, String0),
string__sub_string_search(String1, "]", Index)
@@ -251,7 +264,7 @@
string__left(String1, Index, AssemblyName),
string__split(String1, Index + 1, _, TypeNameStr),
string_to_sym_name(TypeNameStr, ".", TypeSymName),
- ForeignType = ok(il(value, AssemblyName, TypeSymName))
+ ForeignType = ok(il(il(value, AssemblyName, TypeSymName)))
;
ForeignType = error(
"invalid foreign language type description", ErrorTerm)
@@ -260,8 +273,7 @@
% Parse all the special assembler names for all the builtin types.
% See Parition I 'Built-In Types' (Section 8.2.2) for the list
% of all builtin types.
-:- pred parse_special_il_type_name(string::in,
- foreign_language_type::out) is semidet.
+:- pred parse_special_il_type_name(string::in, il_foreign_type::out) is semidet.
parse_special_il_type_name("bool", il(value, "mscorlib",
qualified(unqualified("System"), "Boolean"))).
only in patch2:
--- foreign/compiler/prog_data.m 20 Mar 2002 12:37:10 -0000 1.82
+++ foreign/compiler/prog_data.m 3 May 2002 17:44:36 -0000
@@ -316,11 +316,12 @@
% for each of these cases.
%
-:- type ref_or_val
- ---> reference
- ; value.
-
:- type foreign_language_type
+ ---> il(il_foreign_type)
+ ; c(c_foreign_type)
+ .
+
+:- type il_foreign_type
---> il(
ref_or_val, % An indicator of whether the type is a
% reference of value type.
@@ -328,6 +329,15 @@
% assembly)
sym_name % The .NET type name
).
+
+:- type c_foreign_type
+ ---> c(
+ string % The C type name
+ ).
+
+:- type ref_or_val
+ ---> reference
+ ; value.
%
% Stuff for tabling pragmas
only in patch2:
--- foreign/compiler/pragma_c_gen.m 28 Mar 2002 03:43:33 -0000 1.50
+++ foreign/compiler/pragma_c_gen.m 3 May 2002 17:44:35 -0000
@@ -42,9 +42,9 @@
:- implementation.
:- import_module hlds__hlds_module, hlds__hlds_pred, hlds__hlds_llds.
-:- import_module hlds__instmap.
-:- import_module ll_backend__llds_out, ll_backend__trace.
-:- import_module ll_backend__code_util.
+:- import_module hlds__instmap, hlds__hlds_data, hlds__error_util.
+:- import_module check_hlds__type_util.
+:- import_module ll_backend__llds_out, ll_backend__trace, ll_backend__code_util.
:- import_module backend_libs__foreign.
:- import_module libs__options, libs__globals, libs__tree.
@@ -677,8 +677,8 @@
{ 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) },
+ input_descs_from_arg_info(InArgs, InputDescs),
+ output_descs_from_arg_info(OutArgs, OutputDescs),
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
{ pred_info_module(PredInfo, ModuleName) },
@@ -1186,7 +1186,8 @@
code_info__produce_variable(Var, FirstCode, Rval),
% code_info__produce_variable_in_reg(Var, FirstCode, Lval),
% { Rval = lval(Lval) },
- { Input = pragma_c_input(Name, Type, Rval) },
+ get_maybe_foreign_type_name(Type, MaybeForeign),
+ { Input = pragma_c_input(Name, Type, Rval, MaybeForeign) },
get_pragma_input_vars(Args, Inputs1, RestCode),
{ Inputs = [Input | Inputs1] },
{ Code = tree(FirstCode, RestCode) }
@@ -1196,6 +1197,30 @@
get_pragma_input_vars(Args, Inputs, Code)
).
+:- pred get_maybe_foreign_type_name((type)::in, maybe(string)::out,
+ code_info::in, code_info::out) is det.
+
+get_maybe_foreign_type_name(Type, MaybeForeignType) -->
+ code_info__get_module_info(Module),
+ { module_info_types(Module, Types) },
+ {
+ type_to_ctor_and_args(Type, TypeId, _SubTypes),
+ map__search(Types, TypeId, Defn),
+ hlds_data__get_type_defn_body(Defn, Body),
+ Body = foreign_type(_MaybeIL, MaybeC)
+ ->
+ ( MaybeC = yes(c(Name)),
+ MaybeForeignType = yes(Name)
+ ; MaybeC = no,
+ % This is ensured by check_foreign_type in
+ % make_hlds.
+ unexpected(this_file,
+ "get_maybe_foreign_type_name: no c foreign type")
+ )
+ ;
+ MaybeForeignType = no
+ }.
+
%---------------------------------------------------------------------------%
% pragma_acquire_regs acquires a list of registers in which to place each
@@ -1226,10 +1251,12 @@
code_info__release_reg(Reg),
( code_info__variable_is_forward_live(Var) ->
code_info__set_var_location(Var, Reg),
+ get_maybe_foreign_type_name(OrigType, MaybeForeign),
{
var_is_not_singleton(MaybeName, Name)
->
- PragmaCOutput = pragma_c_output(Reg, OrigType, Name),
+ PragmaCOutput = pragma_c_output(Reg, OrigType,
+ Name, MaybeForeign),
Outputs = [PragmaCOutput | Outputs0]
;
Outputs = Outputs0
@@ -1247,22 +1274,24 @@
% input_descs_from_arg_info returns a list of pragma_c_inputs, which
% are pairs of rvals and (C) variables which receive the input value.
-:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out)
- is det.
+:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out,
+ code_info::in, code_info::out) is det.
-input_descs_from_arg_info([], []).
-input_descs_from_arg_info([Arg | Args], Inputs) :-
+input_descs_from_arg_info([], [], CodeInfo, CodeInfo).
+input_descs_from_arg_info([Arg | Args], Inputs, CodeInfo0, CodeInfo) :-
Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
(
var_is_not_singleton(MaybeName, Name)
->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
- Input = pragma_c_input(Name, OrigType, lval(Reg)),
+ get_maybe_foreign_type_name(OrigType, MaybeForeign,
+ CodeInfo0, CodeInfo1),
+ Input = pragma_c_input(Name, OrigType, lval(Reg), MaybeForeign),
Inputs = [Input | Inputs1],
- input_descs_from_arg_info(Args, Inputs1)
+ input_descs_from_arg_info(Args, Inputs1, CodeInfo1, CodeInfo)
;
- input_descs_from_arg_info(Args, Inputs)
+ input_descs_from_arg_info(Args, Inputs, CodeInfo0, CodeInfo)
).
%---------------------------------------------------------------------------%
@@ -1271,22 +1300,26 @@
% are pairs of names of output registers and (C) variables which hold the
% output value.
-:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out)
- is det.
+:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out,
+ code_info::in, code_info::out) is det.
-output_descs_from_arg_info([], []).
-output_descs_from_arg_info([Arg | Args], Outputs) :-
+output_descs_from_arg_info([], [], CodeInfo, CodeInfo).
+output_descs_from_arg_info([Arg | Args], Outputs, CodeInfo0, CodeInfo) :-
Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
+ output_descs_from_arg_info(Args, Outputs0, CodeInfo0, CodeInfo1),
(
var_is_not_singleton(MaybeName, Name)
->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
- Outputs = [pragma_c_output(Reg, OrigType, Name) | Outputs0]
+ get_maybe_foreign_type_name(OrigType, MaybeForeign,
+ CodeInfo1, CodeInfo),
+ Outputs = [pragma_c_output(Reg, OrigType, Name, MaybeForeign) |
+ Outputs0]
;
- Outputs = Outputs0
- ),
- output_descs_from_arg_info(Args, Outputs0).
+ Outputs = Outputs0,
+ CodeInfo = CodeInfo1
+ ).
%---------------------------------------------------------------------------%
@@ -1299,4 +1332,10 @@
string__append_list(["mercury_save__", MangledModuleName, "__",
MangledPredName, "__", ArityStr, "_", ProcNumStr], StructName).
+%---------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "pragma_c_gen.m".
+
+%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
only in patch2:
--- foreign/compiler/opt_util.m 20 Mar 2002 12:37:02 -0000 1.114
+++ foreign/compiler/opt_util.m 3 May 2002 17:44:35 -0000
@@ -1341,7 +1341,7 @@
pragma_c_inputs_get_rvals([], []).
pragma_c_inputs_get_rvals([I|Inputs], [R|Rvals]) :-
- I = pragma_c_input(_Name, _Type, R),
+ I = pragma_c_input(_Name, _Type, R, _),
pragma_c_inputs_get_rvals(Inputs, Rvals).
% extract the lvals from the pragma_c_output
@@ -1350,7 +1350,7 @@
pragma_c_outputs_get_lvals([], []).
pragma_c_outputs_get_lvals([O|Outputs], [L|Lvals]) :-
- O = pragma_c_output(L, _Type, _Name),
+ O = pragma_c_output(L, _Type, _Name, _),
pragma_c_outputs_get_lvals(Outputs, Lvals).
% determine all the rvals and lvals referenced by a list of instructions
only in patch2:
--- foreign/compiler/mlds_to_java.m 12 Apr 2002 01:24:11 -0000 1.28
+++ foreign/compiler/mlds_to_java.m 3 May 2002 17:44:34 -0000
@@ -1251,7 +1251,7 @@
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(_, _, _)) = _ :-
+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".
@@ -1619,7 +1619,7 @@
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(_, _, _)) -->
+output_type(mlds__foreign_type(_)) -->
{ unexpected(this_file, "output_type: foreign_type NYI.") }.
output_type(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
only in patch2:
--- foreign/compiler/mlds_to_il.m 1 May 2002 14:16:54 -0000 1.113
+++ foreign/compiler/mlds_to_il.m 3 May 2002 17:44:32 -0000
@@ -3005,15 +3005,19 @@
mlds_type_to_ilds_type(_, mlds__native_float_type) = ilds__type([], float64).
-mlds_type_to_ilds_type(_, mlds__foreign_type(IsBoxed, ForeignType, Assembly))
+mlds_type_to_ilds_type(_, mlds__foreign_type(ForeignType))
= ilds__type([], Class) :-
- sym_name_to_class_name(ForeignType, ForeignClassName),
- ( IsBoxed = yes,
- Class = class(structured_name(assembly(Assembly),
- ForeignClassName, []))
- ; IsBoxed = no,
- Class = valuetype(structured_name(assembly(Assembly),
- ForeignClassName, []))
+ ( ForeignType = il(il(RefOrVal, Assembly, Type)),
+ sym_name_to_class_name(Type, ForeignClassName),
+ ( RefOrVal = reference,
+ Class = class(structured_name(assembly(Assembly),
+ ForeignClassName, []))
+ ; RefOrVal = value,
+ Class = valuetype(structured_name(assembly(Assembly),
+ ForeignClassName, []))
+ )
+ ; ForeignType = c(_),
+ error("mlds_to_il: c foreign type")
).
mlds_type_to_ilds_type(ILDataRep, mlds__ptr_type(MLDSType)) =
only in patch2:
--- foreign/compiler/mlds_to_gcc.m 24 Apr 2002 07:37:31 -0000 1.70
+++ foreign/compiler/mlds_to_gcc.m 3 May 2002 17:44:29 -0000
@@ -1694,8 +1694,7 @@
).
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__foreign_type(_), _, _, 'MR_Box') --> [].
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) --> [].
only in patch2:
--- foreign/compiler/mlds_to_c.m 24 Apr 2002 07:37:30 -0000 1.127
+++ foreign/compiler/mlds_to_c.m 3 May 2002 17:44:28 -0000
@@ -663,8 +663,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__foreign_type(_)) -->
+ io__write_string("MR_Box").
mlds_output_pragma_export_type(prefix, mlds__class_type(_, _, _)) -->
io__write_string("MR_Word").
mlds_output_pragma_export_type(prefix, mlds__array_type(_)) -->
@@ -1639,8 +1639,13 @@
mlds_output_type_prefix(mlds__native_bool_type) -->
io__write_string("MR_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__foreign_type(ForeignType)) -->
+ ( { ForeignType = c(c(Name)) },
+ io__write_string(Name)
+ ; { ForeignType = il(_) },
+ { unexpected(this_file,
+ "mlds_output_type_prefix: il foreign_type") }
+ ).
mlds_output_type_prefix(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
%
@@ -1809,7 +1814,8 @@
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(_, _, _), _) --> [].
+ % XXX Currently we can't output a type suffix.
+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) -->
only in patch2:
--- foreign/compiler/mlds.m 12 Apr 2002 01:24:08 -0000 1.89
+++ foreign/compiler/mlds.m 3 May 2002 17:44:26 -0000
@@ -630,12 +630,9 @@
; 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.
+ % This is a type of the target language.
; mlds__foreign_type(
- bool, % is type already boxed?
- sym_name, % structured name representing the type
- string % location of the type (ie assembly)
+ foreign_language_type
)
% MLDS types defined using mlds__class_defn
@@ -1616,6 +1613,7 @@
:- implementation.
:- import_module backend_libs__foreign, parse_tree__modules.
+:- import_module hlds__error_util, libs__globals.
:- import_module int, term, string, require.
%-----------------------------------------------------------------------------%
@@ -1653,10 +1651,34 @@
module_info_types(ModuleInfo, Types),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = foreign_type(IsBoxed, ForeignType, ForeignLocation)
+ Body = foreign_type(MaybeIL, MaybeC)
->
- MLDSType = mlds__foreign_type(IsBoxed,
- ForeignType, ForeignLocation)
+ module_info_globals(ModuleInfo, Globals),
+ globals__get_target(Globals, Target),
+ ( Target = c,
+ ( MaybeC = yes(CForeignType),
+ ForeignType = c(CForeignType)
+ ; MaybeC = no,
+ % This is checked by check_foreign_type
+ % in make_hlds.
+ unexpected(this_file,
+ "mercury_type_to_mlds_type: No C foreign type")
+ )
+ ; Target = il,
+ ( MaybeIL = yes(ILForeignType),
+ ForeignType = il(ILForeignType)
+ ; MaybeIL = no,
+ % This is checked by check_foreign_type
+ % in make_hlds.
+ unexpected(this_file,
+ "mercury_type_to_mlds_type: No IL foreign type")
+ )
+ ; Target = java,
+ sorry(this_file, "foreign types on the java backend")
+ ; Target = asm,
+ sorry(this_file, "foreign types on the asm backend")
+ ),
+ MLDSType = mlds__foreign_type(ForeignType)
;
classify_type(Type, ModuleInfo, Category),
ExportedType = to_exported_type(ModuleInfo, Type),
@@ -1865,5 +1887,10 @@
finality_bits(Finality) \/
constness_bits(Constness) \/
abstractness_bits(Abstractness).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "mlds.m".
%-----------------------------------------------------------------------------%
only in patch2:
--- foreign/compiler/ml_type_gen.m 20 Mar 2002 12:36:47 -0000 1.26
+++ foreign/compiler/ml_type_gen.m 3 May 2002 17:44:25 -0000
@@ -127,7 +127,7 @@
Ctors, TagValues, MaybeEqualityMembers)
).
% XXX Fixme! Same issues here as for eqv_type/1.
-ml_gen_type_2(foreign_type(_, _, _), _, _, _) --> [].
+ml_gen_type_2(foreign_type(_, _), _, _, _) --> [].
%-----------------------------------------------------------------------------%
%
only in patch2:
--- foreign/compiler/ml_code_util.m 12 Apr 2002 01:24:07 -0000 1.62
+++ foreign/compiler/ml_code_util.m 3 May 2002 17:44:24 -0000
@@ -2160,14 +2160,11 @@
ml_type_might_contain_pointers(mlds__native_float_type) = no.
ml_type_might_contain_pointers(mlds__native_bool_type) = no.
ml_type_might_contain_pointers(mlds__native_char_type) = no.
-ml_type_might_contain_pointers(mlds__foreign_type(_, _, _)) = _ :-
+ml_type_might_contain_pointers(mlds__foreign_type(_)) = _ :-
+ sorry(this_file, "--gc accurate and foreign_type").
% It might contain pointers, so it's not safe to return `no',
% but it also might not be word-sized, so it's not safe to
- % return `yes'. Currently this case should not occur, since
- % currently `foreign_type' is only used for the IL back-end,
- % where GC is handled by the target language.
- unexpected(this_file, "--gc accurate and foreign_type").
-
+ % return `yes'.
ml_type_might_contain_pointers(mlds__class_type(_, _, Category)) =
(if Category = mlds__enum then no else yes).
ml_type_might_contain_pointers(mlds__ptr_type(_)) = yes.
only in patch2:
--- foreign/compiler/ml_code_gen.m 2 Apr 2002 16:36:10 -0000 1.113
+++ foreign/compiler/ml_code_gen.m 3 May 2002 17:44:22 -0000
@@ -854,22 +854,41 @@
ml_gen_imports(ModuleInfo, MLDS_ImportList) :-
% Determine all the mercury imports.
+ module_info_globals(ModuleInfo, Globals),
+ globals__get_target(Globals, Target),
module_info_get_all_deps(ModuleInfo, AllImports),
P = (func(Name) = mercury_import(mercury_module_name_to_mlds(Name))),
% For every foreign type determine the import needed to
% find the declaration for that type.
module_info_types(ModuleInfo, Types),
- list__filter_map((pred(TypeDefn::in, Import::out) is semidet :-
- hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = foreign_type(_, _, Location),
- Name = il_assembly_name(mercury_module_name_to_mlds(
- unqualified(Location))),
- Import = foreign_import(Name)
- ), map__values(Types), ForeignTypeImports),
+ ForeignTypeImports = list__condense(list__map(
+ foreign_type_required_imports(Target),
+ map__values(Types))),
MLDS_ImportList = ForeignTypeImports ++
list__map(P, set__to_sorted_list(AllImports)).
+
+:- func foreign_type_required_imports(compilation_target, hlds_type_defn)
+ = list(mlds__import).
+
+foreign_type_required_imports(c, _) = [].
+foreign_type_required_imports(il, TypeDefn) = Imports :-
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+ ( Body = foreign_type(MaybeIL, _MaybeC) ->
+ ( MaybeIL = yes(il(_, Location, _)) ->
+ Name = il_assembly_name(mercury_module_name_to_mlds(
+ unqualified(Location))),
+ Imports = [foreign_import(Name)]
+
+ ;
+ unexpected(this_file, "no IL type")
+ )
+ ;
+ Imports = []
+ ).
+foreign_type_required_imports(java, _) = [].
+foreign_type_required_imports(asm, _) = [].
:- pred ml_gen_defns(module_info, mlds__defns, io__state, io__state).
:- mode ml_gen_defns(in, out, di, uo) is det.
only in patch2:
--- foreign/compiler/middle_rec.m 28 Mar 2002 03:43:19 -0000 1.90
+++ foreign/compiler/middle_rec.m 3 May 2002 17:44:21 -0000
@@ -547,7 +547,7 @@
insert_pragma_c_input_registers([], Used, Used).
insert_pragma_c_input_registers([Input|Inputs], Used0, Used) :-
- Input = pragma_c_input(_, _, Rval),
+ Input = pragma_c_input(_, _, Rval, _),
middle_rec__find_used_registers_rval(Rval, Used0, Used1),
insert_pragma_c_input_registers(Inputs, Used1, Used).
@@ -557,7 +557,7 @@
insert_pragma_c_output_registers([], Used, Used).
insert_pragma_c_output_registers([Output|Outputs], Used0, Used) :-
- Output = pragma_c_output(Lval, _, _),
+ Output = pragma_c_output(Lval, _, _, _),
middle_rec__find_used_registers_lval(Lval, Used0, Used1),
insert_pragma_c_output_registers(Outputs, Used1, Used).
only in patch2:
--- foreign/compiler/mercury_to_mercury.m 9 Apr 2002 09:00:25 -0000 1.212
+++ foreign/compiler/mercury_to_mercury.m 3 May 2002 17:44:20 -0000
@@ -510,20 +510,28 @@
;
{ Pragma = foreign_type(ForeignType, _MercuryType,
MercuryTypeSymName) },
- { ForeignType = il(RefOrVal, ForeignLocStr, ForeignTypeName) },
io__write_string(":- pragma foreign_type("),
- io__write_string("il, "),
+ ( { ForeignType = il(_) },
+ io__write_string("il, ")
+ ; { ForeignType = c(_) },
+ io__write_string("c, ")
+ ),
mercury_output_sym_name(MercuryTypeSymName),
io__write_string(", "),
- ( { RefOrVal = reference },
- io__write_string("\"class [")
- ; { RefOrVal = value },
- io__write_string("\"valuetype [")
- ),
- io__write_string(ForeignLocStr),
- io__write_string("]"),
- { sym_name_to_string(ForeignTypeName, ".", ForeignTypeStr) },
+ io__write_string(", \""),
+ { ForeignType = il(il(RefOrVal,
+ ForeignLocStr, ForeignTypeName)),
+ ( RefOrVal = reference,
+ RefOrValStr = "class "
+ ; RefOrVal = value,
+ RefOrValStr = "valuetype "
+ ),
+ sym_name_to_string(ForeignTypeName, ".", NameStr),
+ ForeignTypeStr = RefOrValStr ++ "[" ++ ForeignLocStr ++
+ "]" ++ NameStr
+ ; ForeignType = c(c(ForeignTypeStr))
+ },
io__write_string(ForeignTypeStr),
io__write_string("\").\n")
;
only in patch2:
--- foreign/compiler/make_hlds.m 3 May 2002 11:25:02 -0000 1.409
+++ foreign/compiler/make_hlds.m 3 May 2002 17:44:19 -0000
@@ -409,21 +409,18 @@
{ Pragma = foreign_proc(_, _, _, _, _, _) },
{ Module = Module0 }
;
+ % Note that we check during add_item_clause that we have
+ % defined a foreign_type which is usable by the back-end
+ % we are compiling on.
{ Pragma = foreign_type(ForeignType, _MercuryType, Name) },
- { ForeignType = il(RefOrVal,
- ForeignTypeLocation, ForeignTypeName) },
-
- { RefOrVal = reference,
- IsBoxed = yes
- ; RefOrVal = value,
- IsBoxed = no
- },
-
{ varset__init(VarSet) },
{ Args = [] },
- { Body = foreign_type(IsBoxed,
- ForeignTypeName, ForeignTypeLocation) },
+ { ForeignType = il(ILForeignType),
+ Body = foreign_type(yes(ILForeignType), no)
+ ; ForeignType = c(CForeignType),
+ Body = foreign_type(no, yes(CForeignType))
+ },
{ Cond = true },
{ TypeCtor = Name - 0 },
@@ -807,6 +804,11 @@
add_pragma_type_spec(Pragma, Context, Module0, Module,
Info0, Info)
;
+ { Pragma = foreign_type(_, _, Name) }
+ ->
+ check_foreign_type(Name, Context, Module0, Module),
+ { Info = Info0 }
+ ;
% don't worry about any pragma decs but c_code, tabling,
% type_spec and fact_table here
{ Module = Module0 },
@@ -1921,9 +1923,23 @@
module_info_set_types(Module0, Types, Module)
}
;
- { Module = Module0 },
- multiple_def_error(Status, Name, Arity, "type",
- Context, OrigContext, _)
+ { merge_foreign_type_bodies(Body, Body_2, NewBody) }
+ ->
+ { hlds_data__set_type_defn(TVarSet_2, Params_2,
+ NewBody, Status, Context, T3) },
+ { map__det_update(Types0, TypeCtor, T3, Types) },
+ { module_info_set_types(Module0, Types, Module) }
+ ;
+ % otherwise issue an error message if the second
+ % definition wasn't read while reading .opt files.
+ { Status = opt_imported }
+ ->
+ { Module = Module0 }
+ ;
+ % XXX Fix this merge up.
+ { module_info_incr_errors(Module0, Module) },
+ multiple_def_error(Status, Name, Arity, "type", Context,
+ OrigContext, _)
)
;
{ map__set(Types0, TypeCtor, T, Types) },
@@ -1998,6 +2014,109 @@
[]
)
).
+
+ % check_foreign_type ensures that if we are generating code for
+ % a specific backend that the foreign type has a representation
+ % on that backend.
+:- pred check_foreign_type(sym_name::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+check_foreign_type(Name, Context, Module0, Module) -->
+ { TypeCtor = Name - 0 },
+ { module_info_types(Module0, Types) },
+ { TypeStr = error_util__describe_sym_name_and_arity(Name/0) },
+ (
+ { map__search(Types, TypeCtor, Defn) },
+ { hlds_data__get_type_defn_body(Defn, Body) },
+ { Body = foreign_type(MaybeIL, MaybeC) }
+ ->
+ { module_info_globals(Module0, Globals) },
+ generating_code(GeneratingCode),
+ ( { GeneratingCode = yes } ->
+ io_lookup_bool_option(very_verbose, VeryVerbose),
+ { VeryVerbose = yes ->
+ VerboseErrorPieces = [
+ nl,
+ words("There are representations for"),
+ words("this type on other back-ends,"),
+ words("but none for this back-end.")
+ ]
+ ;
+ VerboseErrorPieces = []
+ },
+ { globals__get_target(Globals, Target) },
+ ( { Target = c },
+ ( { MaybeC = yes(_) },
+ { Module = Module0 }
+ ; { MaybeC = no },
+ { ErrorPieces = [
+ words("Error: no C pragma"),
+ words("foreign_type declaration for"),
+ fixed(TypeStr) | VerboseErrorPieces
+ ] },
+ error_util__write_error_pieces(Context,
+ 0, ErrorPieces),
+ { module_info_incr_errors(Module0, Module) }
+ )
+ ; { Target = il },
+ ( { MaybeIL = yes(_) },
+ { Module = Module0 }
+ ; { MaybeIL = no },
+ { ErrorPieces = [
+ words("Error: no IL pragma"),
+ words("foreign_type declaration for"),
+ fixed(TypeStr) | VerboseErrorPieces
+ ] },
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces),
+ { module_info_incr_errors(Module0, Module) }
+ )
+ ; { Target = java },
+ { Module = Module0 }
+ ; { Target = asm },
+ { Module = Module0 }
+ )
+ ;
+ { Module = Module0 }
+ )
+ ;
+ { error("check_foreign_type: unable to find foreign type") }
+ ).
+
+ % Do the options imply that we will generate code for a specific
+ % back-end?
+:- pred generating_code(bool::out, io::di, io::uo) is det.
+
+generating_code(bool__not(NotGeneratingCode)) -->
+ io_lookup_bool_option(make_short_interface, MakeShortInterface),
+ io_lookup_bool_option(make_interface, MakeInterface),
+ io_lookup_bool_option(make_private_interface, MakePrivateInterface),
+ io_lookup_bool_option(make_transitive_opt_interface,
+ MakeTransOptInterface),
+ io_lookup_bool_option(generate_source_file_mapping, GenSrcFileMapping),
+ io_lookup_bool_option(generate_dependencies, GenDepends),
+ io_lookup_bool_option(convert_to_mercury, ConvertToMercury),
+ io_lookup_bool_option(typecheck_only, TypeCheckOnly),
+ io_lookup_bool_option(errorcheck_only, ErrorCheckOnly),
+ io_lookup_bool_option(output_grade_string, OutputGradeString),
+ { bool__or_list([MakeShortInterface, MakeInterface,
+ MakePrivateInterface, MakeTransOptInterface,
+ GenSrcFileMapping, GenDepends, ConvertToMercury,
+ TypeCheckOnly, ErrorCheckOnly, OutputGradeString],
+ NotGeneratingCode) }.
+
+:- pred merge_foreign_type_bodies(hlds_type_body::in,
+ hlds_type_body::in, hlds_type_body::out) is semidet.
+
+merge_foreign_type_bodies(foreign_type(MaybeILA, MaybeCA),
+ foreign_type(MaybeILB, MaybeCB),
+ foreign_type(MaybeIL, MaybeC)) :-
+ merge_maybe(MaybeILA, MaybeILB, MaybeIL),
+ merge_maybe(MaybeCA, MaybeCB, MaybeC).
+
+:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
+merge_maybe(yes(T), no, yes(T)).
+merge_maybe(no, yes(T), yes(T)).
:- pred make_status_abstract(import_status, import_status).
:- mode make_status_abstract(in, out) is det.
only in patch2:
--- foreign/compiler/magic_util.m 20 Mar 2002 12:36:36 -0000 1.20
+++ foreign/compiler/magic_util.m 3 May 2002 17:44:14 -0000
@@ -1381,7 +1381,7 @@
{ 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(_, _, _), _, _, _) -->
+magic_util__check_type_defn(foreign_type(_, _), _, _, _) -->
{ error("magic_util__check_type_defn: foreign_type") }.
:- pred magic_util__check_ctor(set(type_ctor)::in, constructor::in,
only in patch2:
--- foreign/compiler/llds_out.m 24 Apr 2002 07:37:28 -0000 1.192
+++ foreign/compiler/llds_out.m 3 May 2002 17:44:13 -0000
@@ -1966,7 +1966,7 @@
output_pragma_input_rval_decls([], DeclSet, DeclSet) --> [].
output_pragma_input_rval_decls([I | Inputs], DeclSet0, DeclSet) -->
- { I = pragma_c_input(_VarName, _Type, Rval) },
+ { I = pragma_c_input(_VarName, _Type, Rval, _) },
output_rval_decls(Rval, "\t", "\t", 0, _N, DeclSet0, DeclSet1),
output_pragma_input_rval_decls(Inputs, DeclSet1, DeclSet).
@@ -1977,7 +1977,7 @@
output_pragma_inputs([]) --> [].
output_pragma_inputs([I|Inputs]) -->
- { I = pragma_c_input(VarName, Type, Rval) },
+ { I = pragma_c_input(VarName, Type, Rval, MaybeForeignType) },
io__write_string("\t"),
io__write_string(VarName),
io__write_string(" = "),
@@ -1991,6 +1991,13 @@
->
output_rval_as_type(Rval, float)
;
+ % Note that for this cast to be correct the foreign type
+ % must be word sized.
+ ( { MaybeForeignType = yes(ForeignTypeStr) } ->
+ io__write_string("(" ++ ForeignTypeStr ++ ") ")
+ ;
+ []
+ ),
output_rval_as_type(Rval, word)
),
io__write_string(";\n"),
@@ -2003,7 +2010,7 @@
output_pragma_output_lval_decls([], DeclSet, DeclSet) --> [].
output_pragma_output_lval_decls([O | Outputs], DeclSet0, DeclSet) -->
- { O = pragma_c_output(Lval, _Type, _VarName) },
+ { O = pragma_c_output(Lval, _Type, _VarName, _) },
output_lval_decls(Lval, "\t", "\t", 0, _N, DeclSet0, DeclSet1),
output_pragma_output_lval_decls(Outputs, DeclSet1, DeclSet).
@@ -2014,7 +2021,7 @@
output_pragma_outputs([]) --> [].
output_pragma_outputs([O|Outputs]) -->
- { O = pragma_c_output(Lval, Type, VarName) },
+ { O = pragma_c_output(Lval, Type, VarName, MaybeForeignType) },
io__write_string("\t"),
output_lval_as_word(Lval),
io__write_string(" = "),
@@ -2030,6 +2037,13 @@
io__write_string(VarName),
io__write_string(")")
;
+ % Note that for this cast to be correct the foreign type
+ % must be word sized.
+ ( { MaybeForeignType = yes(_) } ->
+ output_llds_type_cast(word)
+ ;
+ []
+ ),
io__write_string(VarName)
),
io__write_string(";\n"),
only in patch2:
--- foreign/compiler/llds.m 28 Mar 2002 03:43:10 -0000 1.284
+++ foreign/compiler/llds.m 3 May 2002 17:44:11 -0000
@@ -553,15 +553,17 @@
% A pragma_c_input represents the code that initializes one
% of the input variables for a pragma_c instruction.
:- type pragma_c_input
- ---> pragma_c_input(string, type, rval).
- % variable name, type, variable value.
+ ---> pragma_c_input(string, type, rval, maybe(string)).
+ % variable name, type, variable value,
+ % maybe C type if foreign type.
% A pragma_c_output represents the code that stores one of
% of the outputs for a pragma_c instruction.
:- type pragma_c_output
- ---> pragma_c_output(lval, type, string).
+ ---> pragma_c_output(lval, type, string, maybe(string)).
% where to put the output val, type and name
% of variable containing the output val
+ % followed by maybe C type if foreign type.
% see runtime/mercury_trail.h
:- type reset_trail_reason
only in patch2:
--- foreign/compiler/livemap.m 20 Mar 2002 12:36:30 -0000 1.52
+++ foreign/compiler/livemap.m 3 May 2002 17:44:10 -0000
@@ -424,7 +424,7 @@
livemap__build_livemap_pragma_inputs([], Livevals, Livevals).
livemap__build_livemap_pragma_inputs([Input | Inputs], Livevals0, Livevals) :-
- Input = pragma_c_input(_, _, Rval),
+ Input = pragma_c_input(_, _, Rval, _),
( Rval = lval(Lval) ->
livemap__insert_proper_liveval(Lval, Livevals0, Livevals1)
;
only in patch2:
--- foreign/compiler/intermod.m 7 Apr 2002 10:22:33 -0000 1.118
+++ foreign/compiler/intermod.m 3 May 2002 17:44:10 -0000
@@ -1194,7 +1194,7 @@
{ Body = abstract_type },
{ TypeBody = abstract_type }
;
- { Body = foreign_type(_, _, _) },
+ { Body = foreign_type(_, _) },
{ TypeBody = abstract_type },
% XXX trd
% Also here we need to output the pragma
only in patch2:
--- foreign/compiler/hlds_out.m 28 Mar 2002 03:43:01 -0000 1.282
+++ foreign/compiler/hlds_out.m 3 May 2002 17:44:09 -0000
@@ -2897,7 +2897,7 @@
hlds_out__write_type_body(_Indent, _Tvarset, abstract_type) -->
io__write_string(".\n").
-hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_, _, _)) -->
+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),
only in patch2:
--- foreign/compiler/hlds_data.m 20 Mar 2002 12:36:16 -0000 1.68
+++ foreign/compiler/hlds_data.m 3 May 2002 17:44:07 -0000
@@ -300,12 +300,8 @@
)
; eqv_type(type)
; foreign_type(
- bool, % is the type already boxed
- sym_name, % structured name of foreign type
- % which represents the mercury type.
- string % Location of the definition for this
- % type (such as assembly or
- % library name)
+ il :: maybe(il_foreign_type),
+ c :: maybe(c_foreign_type)
)
; abstract_type.
only in patch2:
--- foreign/compiler/foreign.m 20 Mar 2002 12:36:11 -0000 1.13
+++ foreign/compiler/foreign.m 3 May 2002 17:44:06 -0000
@@ -71,7 +71,7 @@
:- func foreign__non_foreign_type((type)) = exported_type.
% Given an arbitary mercury type, get the exported_type representation
- % of that type.
+ % of that type on the current backend.
:- func foreign__to_exported_type(module_info, (type)) = exported_type.
% Given a representation of a type determine the string which
@@ -588,13 +588,38 @@
to_exported_type(ModuleInfo, Type) = ExportType :-
module_info_types(ModuleInfo, Types),
+ module_info_globals(ModuleInfo, Globals),
+ globals__get_target(Globals, Target),
(
type_to_ctor_and_args(Type, TypeCtor, _),
map__search(Types, TypeCtor, TypeDefn)
->
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = foreign_type(_, ForeignType, _) ->
- ExportType = foreign(ForeignType)
+ ( Body = foreign_type(MaybeIL, MaybeC) ->
+ ( Target = c,
+ ( MaybeC = yes(c(NameStr)),
+ Name = unqualified(NameStr)
+ ; MaybeC = no,
+ unexpected(this_file,
+ "to_exported_type: no C type")
+ )
+ ; Target = il,
+ ( MaybeIL = yes(il(_, _, Name))
+ ; MaybeIL = no,
+ unexpected(this_file,
+ "to_exported_type: no IL type")
+ )
+ ; Target = java,
+ sorry(this_file, "to_exported_type for java")
+ ; Target = asm,
+ ( MaybeC = yes(c(NameStr)),
+ Name = unqualified(NameStr)
+ ; MaybeC = no,
+ unexpected(this_file,
+ "to_exported_type: no C type")
+ )
+ ),
+ ExportType = foreign(Name)
;
ExportType = mercury(Type)
)
@@ -605,8 +630,12 @@
to_type_string(Lang, ModuleInfo, Type) =
to_type_string(Lang, to_exported_type(ModuleInfo, Type)).
-to_type_string(c, foreign(_ForeignType)) = _ :-
- sorry(this_file, "foreign types on a C backend").
+to_type_string(c, foreign(ForeignType)) = Result :-
+ ( ForeignType = unqualified(Result0) ->
+ Result = Result0
+ ;
+ unexpected(this_file, "to_type_string: qualified C type")
+ ).
to_type_string(csharp, foreign(ForeignType)) = Result :-
sym_name_to_string(ForeignType, ".", Result).
to_type_string(managed_cplusplus, foreign(ForeignType)) = Result ++ " *":-
only in patch2:
--- foreign/compiler/exprn_aux.m 20 Mar 2002 12:36:09 -0000 1.42
+++ foreign/compiler/exprn_aux.m 3 May 2002 17:44:06 -0000
@@ -599,20 +599,20 @@
exprn_aux__substitute_lval_in_pragma_c_input(OldLval, NewLval, Out0, Out,
N0, N) :-
- Out0 = pragma_c_input(Name, Type, Rval0),
+ Out0 = pragma_c_input(Name, Type, Rval0, MaybeForeign),
exprn_aux__substitute_lval_in_rval_count(OldLval, NewLval, Rval0, Rval,
N0, N),
- Out = pragma_c_input(Name, Type, Rval).
+ Out = pragma_c_input(Name, Type, Rval, MaybeForeign).
:- pred exprn_aux__substitute_lval_in_pragma_c_output(lval::in, lval::in,
pragma_c_output::in, pragma_c_output::out, int::in, int::out) is det.
exprn_aux__substitute_lval_in_pragma_c_output(OldLval, NewLval, Out0, Out,
N0, N) :-
- Out0 = pragma_c_output(Lval0, Type, Name),
+ Out0 = pragma_c_output(Lval0, Type, Name, MaybeForeign),
exprn_aux__substitute_lval_in_lval_count(OldLval, NewLval, Lval0, Lval,
N0, N),
- Out = pragma_c_output(Lval, Type, Name).
+ Out = pragma_c_output(Lval, Type, Name, MaybeForeign).
:- pred exprn_aux__substitute_lval_in_rval_count(lval::in, lval::in,
rval::in, rval::out, int::in, int::out) is det.
***** FULL DIFF ******
Index: foreign/compiler/exprn_aux.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/exprn_aux.m,v
retrieving revision 1.42
diff -u -r1.42 exprn_aux.m
--- foreign/compiler/exprn_aux.m 20 Mar 2002 12:36:09 -0000 1.42
+++ foreign/compiler/exprn_aux.m 3 May 2002 17:44:06 -0000
@@ -599,20 +599,20 @@
exprn_aux__substitute_lval_in_pragma_c_input(OldLval, NewLval, Out0, Out,
N0, N) :-
- Out0 = pragma_c_input(Name, Type, Rval0),
+ Out0 = pragma_c_input(Name, Type, Rval0, MaybeForeign),
exprn_aux__substitute_lval_in_rval_count(OldLval, NewLval, Rval0, Rval,
N0, N),
- Out = pragma_c_input(Name, Type, Rval).
+ Out = pragma_c_input(Name, Type, Rval, MaybeForeign).
:- pred exprn_aux__substitute_lval_in_pragma_c_output(lval::in, lval::in,
pragma_c_output::in, pragma_c_output::out, int::in, int::out) is det.
exprn_aux__substitute_lval_in_pragma_c_output(OldLval, NewLval, Out0, Out,
N0, N) :-
- Out0 = pragma_c_output(Lval0, Type, Name),
+ Out0 = pragma_c_output(Lval0, Type, Name, MaybeForeign),
exprn_aux__substitute_lval_in_lval_count(OldLval, NewLval, Lval0, Lval,
N0, N),
- Out = pragma_c_output(Lval, Type, Name).
+ Out = pragma_c_output(Lval, Type, Name, MaybeForeign).
:- pred exprn_aux__substitute_lval_in_rval_count(lval::in, lval::in,
rval::in, rval::out, int::in, int::out) is det.
Index: foreign/compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.13
diff -u -r1.13 foreign.m
--- foreign/compiler/foreign.m 20 Mar 2002 12:36:11 -0000 1.13
+++ foreign/compiler/foreign.m 3 May 2002 17:44:06 -0000
@@ -71,7 +71,7 @@
:- func foreign__non_foreign_type((type)) = exported_type.
% Given an arbitary mercury type, get the exported_type representation
- % of that type.
+ % of that type on the current backend.
:- func foreign__to_exported_type(module_info, (type)) = exported_type.
% Given a representation of a type determine the string which
@@ -588,13 +588,38 @@
to_exported_type(ModuleInfo, Type) = ExportType :-
module_info_types(ModuleInfo, Types),
+ module_info_globals(ModuleInfo, Globals),
+ globals__get_target(Globals, Target),
(
type_to_ctor_and_args(Type, TypeCtor, _),
map__search(Types, TypeCtor, TypeDefn)
->
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = foreign_type(_, ForeignType, _) ->
- ExportType = foreign(ForeignType)
+ ( Body = foreign_type(MaybeIL, MaybeC) ->
+ ( Target = c,
+ ( MaybeC = yes(c(NameStr)),
+ Name = unqualified(NameStr)
+ ; MaybeC = no,
+ unexpected(this_file,
+ "to_exported_type: no C type")
+ )
+ ; Target = il,
+ ( MaybeIL = yes(il(_, _, Name))
+ ; MaybeIL = no,
+ unexpected(this_file,
+ "to_exported_type: no IL type")
+ )
+ ; Target = java,
+ sorry(this_file, "to_exported_type for java")
+ ; Target = asm,
+ ( MaybeC = yes(c(NameStr)),
+ Name = unqualified(NameStr)
+ ; MaybeC = no,
+ unexpected(this_file,
+ "to_exported_type: no C type")
+ )
+ ),
+ ExportType = foreign(Name)
;
ExportType = mercury(Type)
)
@@ -605,8 +630,12 @@
to_type_string(Lang, ModuleInfo, Type) =
to_type_string(Lang, to_exported_type(ModuleInfo, Type)).
-to_type_string(c, foreign(_ForeignType)) = _ :-
- sorry(this_file, "foreign types on a C backend").
+to_type_string(c, foreign(ForeignType)) = Result :-
+ ( ForeignType = unqualified(Result0) ->
+ Result = Result0
+ ;
+ unexpected(this_file, "to_type_string: qualified C type")
+ ).
to_type_string(csharp, foreign(ForeignType)) = Result :-
sym_name_to_string(ForeignType, ".", Result).
to_type_string(managed_cplusplus, foreign(ForeignType)) = Result ++ " *":-
Index: foreign/compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.68
diff -u -r1.68 hlds_data.m
--- foreign/compiler/hlds_data.m 20 Mar 2002 12:36:16 -0000 1.68
+++ foreign/compiler/hlds_data.m 3 May 2002 17:44:07 -0000
@@ -300,12 +300,8 @@
)
; eqv_type(type)
; foreign_type(
- bool, % is the type already boxed
- sym_name, % structured name of foreign type
- % which represents the mercury type.
- string % Location of the definition for this
- % type (such as assembly or
- % library name)
+ il :: maybe(il_foreign_type),
+ c :: maybe(c_foreign_type)
)
; abstract_type.
Index: foreign/compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.282
diff -u -r1.282 hlds_out.m
--- foreign/compiler/hlds_out.m 28 Mar 2002 03:43:01 -0000 1.282
+++ foreign/compiler/hlds_out.m 3 May 2002 17:44:09 -0000
@@ -2897,7 +2897,7 @@
hlds_out__write_type_body(_Indent, _Tvarset, abstract_type) -->
io__write_string(".\n").
-hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_, _, _)) -->
+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),
Index: foreign/compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.118
diff -u -r1.118 intermod.m
--- foreign/compiler/intermod.m 7 Apr 2002 10:22:33 -0000 1.118
+++ foreign/compiler/intermod.m 3 May 2002 17:44:10 -0000
@@ -1194,7 +1194,7 @@
{ Body = abstract_type },
{ TypeBody = abstract_type }
;
- { Body = foreign_type(_, _, _) },
+ { Body = foreign_type(_, _) },
{ TypeBody = abstract_type },
% XXX trd
% Also here we need to output the pragma
Index: foreign/compiler/livemap.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/livemap.m,v
retrieving revision 1.52
diff -u -r1.52 livemap.m
--- foreign/compiler/livemap.m 20 Mar 2002 12:36:30 -0000 1.52
+++ foreign/compiler/livemap.m 3 May 2002 17:44:10 -0000
@@ -424,7 +424,7 @@
livemap__build_livemap_pragma_inputs([], Livevals, Livevals).
livemap__build_livemap_pragma_inputs([Input | Inputs], Livevals0, Livevals) :-
- Input = pragma_c_input(_, _, Rval),
+ Input = pragma_c_input(_, _, Rval, _),
( Rval = lval(Lval) ->
livemap__insert_proper_liveval(Lval, Livevals0, Livevals1)
;
Index: foreign/compiler/llds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds.m,v
retrieving revision 1.284
diff -u -r1.284 llds.m
--- foreign/compiler/llds.m 28 Mar 2002 03:43:10 -0000 1.284
+++ foreign/compiler/llds.m 3 May 2002 17:44:11 -0000
@@ -553,15 +553,17 @@
% A pragma_c_input represents the code that initializes one
% of the input variables for a pragma_c instruction.
:- type pragma_c_input
- ---> pragma_c_input(string, type, rval).
- % variable name, type, variable value.
+ ---> pragma_c_input(string, type, rval, maybe(string)).
+ % variable name, type, variable value,
+ % maybe C type if foreign type.
% A pragma_c_output represents the code that stores one of
% of the outputs for a pragma_c instruction.
:- type pragma_c_output
- ---> pragma_c_output(lval, type, string).
+ ---> pragma_c_output(lval, type, string, maybe(string)).
% where to put the output val, type and name
% of variable containing the output val
+ % followed by maybe C type if foreign type.
% see runtime/mercury_trail.h
:- type reset_trail_reason
Index: foreign/compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.192
diff -u -r1.192 llds_out.m
--- foreign/compiler/llds_out.m 24 Apr 2002 07:37:28 -0000 1.192
+++ foreign/compiler/llds_out.m 3 May 2002 17:44:13 -0000
@@ -1966,7 +1966,7 @@
output_pragma_input_rval_decls([], DeclSet, DeclSet) --> [].
output_pragma_input_rval_decls([I | Inputs], DeclSet0, DeclSet) -->
- { I = pragma_c_input(_VarName, _Type, Rval) },
+ { I = pragma_c_input(_VarName, _Type, Rval, _) },
output_rval_decls(Rval, "\t", "\t", 0, _N, DeclSet0, DeclSet1),
output_pragma_input_rval_decls(Inputs, DeclSet1, DeclSet).
@@ -1977,7 +1977,7 @@
output_pragma_inputs([]) --> [].
output_pragma_inputs([I|Inputs]) -->
- { I = pragma_c_input(VarName, Type, Rval) },
+ { I = pragma_c_input(VarName, Type, Rval, MaybeForeignType) },
io__write_string("\t"),
io__write_string(VarName),
io__write_string(" = "),
@@ -1991,6 +1991,13 @@
->
output_rval_as_type(Rval, float)
;
+ % Note that for this cast to be correct the foreign type
+ % must be word sized.
+ ( { MaybeForeignType = yes(ForeignTypeStr) } ->
+ io__write_string("(" ++ ForeignTypeStr ++ ") ")
+ ;
+ []
+ ),
output_rval_as_type(Rval, word)
),
io__write_string(";\n"),
@@ -2003,7 +2010,7 @@
output_pragma_output_lval_decls([], DeclSet, DeclSet) --> [].
output_pragma_output_lval_decls([O | Outputs], DeclSet0, DeclSet) -->
- { O = pragma_c_output(Lval, _Type, _VarName) },
+ { O = pragma_c_output(Lval, _Type, _VarName, _) },
output_lval_decls(Lval, "\t", "\t", 0, _N, DeclSet0, DeclSet1),
output_pragma_output_lval_decls(Outputs, DeclSet1, DeclSet).
@@ -2014,7 +2021,7 @@
output_pragma_outputs([]) --> [].
output_pragma_outputs([O|Outputs]) -->
- { O = pragma_c_output(Lval, Type, VarName) },
+ { O = pragma_c_output(Lval, Type, VarName, MaybeForeignType) },
io__write_string("\t"),
output_lval_as_word(Lval),
io__write_string(" = "),
@@ -2030,6 +2037,13 @@
io__write_string(VarName),
io__write_string(")")
;
+ % Note that for this cast to be correct the foreign type
+ % must be word sized.
+ ( { MaybeForeignType = yes(_) } ->
+ output_llds_type_cast(word)
+ ;
+ []
+ ),
io__write_string(VarName)
),
io__write_string(";\n"),
Index: foreign/compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.20
diff -u -r1.20 magic_util.m
--- foreign/compiler/magic_util.m 20 Mar 2002 12:36:36 -0000 1.20
+++ foreign/compiler/magic_util.m 3 May 2002 17:44:14 -0000
@@ -1381,7 +1381,7 @@
{ 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(_, _, _), _, _, _) -->
+magic_util__check_type_defn(foreign_type(_, _), _, _, _) -->
{ error("magic_util__check_type_defn: foreign_type") }.
:- pred magic_util__check_ctor(set(type_ctor)::in, constructor::in,
Index: foreign/compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.409
diff -u -r1.409 make_hlds.m
--- foreign/compiler/make_hlds.m 3 May 2002 11:25:02 -0000 1.409
+++ foreign/compiler/make_hlds.m 3 May 2002 17:44:19 -0000
@@ -409,21 +409,18 @@
{ Pragma = foreign_proc(_, _, _, _, _, _) },
{ Module = Module0 }
;
+ % Note that we check during add_item_clause that we have
+ % defined a foreign_type which is usable by the back-end
+ % we are compiling on.
{ Pragma = foreign_type(ForeignType, _MercuryType, Name) },
- { ForeignType = il(RefOrVal,
- ForeignTypeLocation, ForeignTypeName) },
-
- { RefOrVal = reference,
- IsBoxed = yes
- ; RefOrVal = value,
- IsBoxed = no
- },
-
{ varset__init(VarSet) },
{ Args = [] },
- { Body = foreign_type(IsBoxed,
- ForeignTypeName, ForeignTypeLocation) },
+ { ForeignType = il(ILForeignType),
+ Body = foreign_type(yes(ILForeignType), no)
+ ; ForeignType = c(CForeignType),
+ Body = foreign_type(no, yes(CForeignType))
+ },
{ Cond = true },
{ TypeCtor = Name - 0 },
@@ -807,6 +804,11 @@
add_pragma_type_spec(Pragma, Context, Module0, Module,
Info0, Info)
;
+ { Pragma = foreign_type(_, _, Name) }
+ ->
+ check_foreign_type(Name, Context, Module0, Module),
+ { Info = Info0 }
+ ;
% don't worry about any pragma decs but c_code, tabling,
% type_spec and fact_table here
{ Module = Module0 },
@@ -1921,9 +1923,23 @@
module_info_set_types(Module0, Types, Module)
}
;
- { Module = Module0 },
- multiple_def_error(Status, Name, Arity, "type",
- Context, OrigContext, _)
+ { merge_foreign_type_bodies(Body, Body_2, NewBody) }
+ ->
+ { hlds_data__set_type_defn(TVarSet_2, Params_2,
+ NewBody, Status, Context, T3) },
+ { map__det_update(Types0, TypeCtor, T3, Types) },
+ { module_info_set_types(Module0, Types, Module) }
+ ;
+ % otherwise issue an error message if the second
+ % definition wasn't read while reading .opt files.
+ { Status = opt_imported }
+ ->
+ { Module = Module0 }
+ ;
+ % XXX Fix this merge up.
+ { module_info_incr_errors(Module0, Module) },
+ multiple_def_error(Status, Name, Arity, "type", Context,
+ OrigContext, _)
)
;
{ map__set(Types0, TypeCtor, T, Types) },
@@ -1998,6 +2014,109 @@
[]
)
).
+
+ % check_foreign_type ensures that if we are generating code for
+ % a specific backend that the foreign type has a representation
+ % on that backend.
+:- pred check_foreign_type(sym_name::in, prog_context::in,
+ module_info::in, module_info::out, io::di, io::uo) is det.
+
+check_foreign_type(Name, Context, Module0, Module) -->
+ { TypeCtor = Name - 0 },
+ { module_info_types(Module0, Types) },
+ { TypeStr = error_util__describe_sym_name_and_arity(Name/0) },
+ (
+ { map__search(Types, TypeCtor, Defn) },
+ { hlds_data__get_type_defn_body(Defn, Body) },
+ { Body = foreign_type(MaybeIL, MaybeC) }
+ ->
+ { module_info_globals(Module0, Globals) },
+ generating_code(GeneratingCode),
+ ( { GeneratingCode = yes } ->
+ io_lookup_bool_option(very_verbose, VeryVerbose),
+ { VeryVerbose = yes ->
+ VerboseErrorPieces = [
+ nl,
+ words("There are representations for"),
+ words("this type on other back-ends,"),
+ words("but none for this back-end.")
+ ]
+ ;
+ VerboseErrorPieces = []
+ },
+ { globals__get_target(Globals, Target) },
+ ( { Target = c },
+ ( { MaybeC = yes(_) },
+ { Module = Module0 }
+ ; { MaybeC = no },
+ { ErrorPieces = [
+ words("Error: no C pragma"),
+ words("foreign_type declaration for"),
+ fixed(TypeStr) | VerboseErrorPieces
+ ] },
+ error_util__write_error_pieces(Context,
+ 0, ErrorPieces),
+ { module_info_incr_errors(Module0, Module) }
+ )
+ ; { Target = il },
+ ( { MaybeIL = yes(_) },
+ { Module = Module0 }
+ ; { MaybeIL = no },
+ { ErrorPieces = [
+ words("Error: no IL pragma"),
+ words("foreign_type declaration for"),
+ fixed(TypeStr) | VerboseErrorPieces
+ ] },
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces),
+ { module_info_incr_errors(Module0, Module) }
+ )
+ ; { Target = java },
+ { Module = Module0 }
+ ; { Target = asm },
+ { Module = Module0 }
+ )
+ ;
+ { Module = Module0 }
+ )
+ ;
+ { error("check_foreign_type: unable to find foreign type") }
+ ).
+
+ % Do the options imply that we will generate code for a specific
+ % back-end?
+:- pred generating_code(bool::out, io::di, io::uo) is det.
+
+generating_code(bool__not(NotGeneratingCode)) -->
+ io_lookup_bool_option(make_short_interface, MakeShortInterface),
+ io_lookup_bool_option(make_interface, MakeInterface),
+ io_lookup_bool_option(make_private_interface, MakePrivateInterface),
+ io_lookup_bool_option(make_transitive_opt_interface,
+ MakeTransOptInterface),
+ io_lookup_bool_option(generate_source_file_mapping, GenSrcFileMapping),
+ io_lookup_bool_option(generate_dependencies, GenDepends),
+ io_lookup_bool_option(convert_to_mercury, ConvertToMercury),
+ io_lookup_bool_option(typecheck_only, TypeCheckOnly),
+ io_lookup_bool_option(errorcheck_only, ErrorCheckOnly),
+ io_lookup_bool_option(output_grade_string, OutputGradeString),
+ { bool__or_list([MakeShortInterface, MakeInterface,
+ MakePrivateInterface, MakeTransOptInterface,
+ GenSrcFileMapping, GenDepends, ConvertToMercury,
+ TypeCheckOnly, ErrorCheckOnly, OutputGradeString],
+ NotGeneratingCode) }.
+
+:- pred merge_foreign_type_bodies(hlds_type_body::in,
+ hlds_type_body::in, hlds_type_body::out) is semidet.
+
+merge_foreign_type_bodies(foreign_type(MaybeILA, MaybeCA),
+ foreign_type(MaybeILB, MaybeCB),
+ foreign_type(MaybeIL, MaybeC)) :-
+ merge_maybe(MaybeILA, MaybeILB, MaybeIL),
+ merge_maybe(MaybeCA, MaybeCB, MaybeC).
+
+:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
+merge_maybe(yes(T), no, yes(T)).
+merge_maybe(no, yes(T), yes(T)).
:- pred make_status_abstract(import_status, import_status).
:- mode make_status_abstract(in, out) is det.
Index: foreign/compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.212
diff -u -r1.212 mercury_to_mercury.m
--- foreign/compiler/mercury_to_mercury.m 9 Apr 2002 09:00:25 -0000 1.212
+++ foreign/compiler/mercury_to_mercury.m 3 May 2002 17:44:20 -0000
@@ -510,20 +510,28 @@
;
{ Pragma = foreign_type(ForeignType, _MercuryType,
MercuryTypeSymName) },
- { ForeignType = il(RefOrVal, ForeignLocStr, ForeignTypeName) },
io__write_string(":- pragma foreign_type("),
- io__write_string("il, "),
+ ( { ForeignType = il(_) },
+ io__write_string("il, ")
+ ; { ForeignType = c(_) },
+ io__write_string("c, ")
+ ),
mercury_output_sym_name(MercuryTypeSymName),
io__write_string(", "),
- ( { RefOrVal = reference },
- io__write_string("\"class [")
- ; { RefOrVal = value },
- io__write_string("\"valuetype [")
- ),
- io__write_string(ForeignLocStr),
- io__write_string("]"),
- { sym_name_to_string(ForeignTypeName, ".", ForeignTypeStr) },
+ io__write_string(", \""),
+ { ForeignType = il(il(RefOrVal,
+ ForeignLocStr, ForeignTypeName)),
+ ( RefOrVal = reference,
+ RefOrValStr = "class "
+ ; RefOrVal = value,
+ RefOrValStr = "valuetype "
+ ),
+ sym_name_to_string(ForeignTypeName, ".", NameStr),
+ ForeignTypeStr = RefOrValStr ++ "[" ++ ForeignLocStr ++
+ "]" ++ NameStr
+ ; ForeignType = c(c(ForeignTypeStr))
+ },
io__write_string(ForeignTypeStr),
io__write_string("\").\n")
;
Index: foreign/compiler/middle_rec.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/middle_rec.m,v
retrieving revision 1.90
diff -u -r1.90 middle_rec.m
--- foreign/compiler/middle_rec.m 28 Mar 2002 03:43:19 -0000 1.90
+++ foreign/compiler/middle_rec.m 3 May 2002 17:44:21 -0000
@@ -547,7 +547,7 @@
insert_pragma_c_input_registers([], Used, Used).
insert_pragma_c_input_registers([Input|Inputs], Used0, Used) :-
- Input = pragma_c_input(_, _, Rval),
+ Input = pragma_c_input(_, _, Rval, _),
middle_rec__find_used_registers_rval(Rval, Used0, Used1),
insert_pragma_c_input_registers(Inputs, Used1, Used).
@@ -557,7 +557,7 @@
insert_pragma_c_output_registers([], Used, Used).
insert_pragma_c_output_registers([Output|Outputs], Used0, Used) :-
- Output = pragma_c_output(Lval, _, _),
+ Output = pragma_c_output(Lval, _, _, _),
middle_rec__find_used_registers_lval(Lval, Used0, Used1),
insert_pragma_c_output_registers(Outputs, Used1, Used).
Index: foreign/compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.113
diff -u -r1.113 ml_code_gen.m
--- foreign/compiler/ml_code_gen.m 2 Apr 2002 16:36:10 -0000 1.113
+++ foreign/compiler/ml_code_gen.m 3 May 2002 17:44:22 -0000
@@ -854,22 +854,41 @@
ml_gen_imports(ModuleInfo, MLDS_ImportList) :-
% Determine all the mercury imports.
+ module_info_globals(ModuleInfo, Globals),
+ globals__get_target(Globals, Target),
module_info_get_all_deps(ModuleInfo, AllImports),
P = (func(Name) = mercury_import(mercury_module_name_to_mlds(Name))),
% For every foreign type determine the import needed to
% find the declaration for that type.
module_info_types(ModuleInfo, Types),
- list__filter_map((pred(TypeDefn::in, Import::out) is semidet :-
- hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = foreign_type(_, _, Location),
- Name = il_assembly_name(mercury_module_name_to_mlds(
- unqualified(Location))),
- Import = foreign_import(Name)
- ), map__values(Types), ForeignTypeImports),
+ ForeignTypeImports = list__condense(list__map(
+ foreign_type_required_imports(Target),
+ map__values(Types))),
MLDS_ImportList = ForeignTypeImports ++
list__map(P, set__to_sorted_list(AllImports)).
+
+:- func foreign_type_required_imports(compilation_target, hlds_type_defn)
+ = list(mlds__import).
+
+foreign_type_required_imports(c, _) = [].
+foreign_type_required_imports(il, TypeDefn) = Imports :-
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+ ( Body = foreign_type(MaybeIL, _MaybeC) ->
+ ( MaybeIL = yes(il(_, Location, _)) ->
+ Name = il_assembly_name(mercury_module_name_to_mlds(
+ unqualified(Location))),
+ Imports = [foreign_import(Name)]
+
+ ;
+ unexpected(this_file, "no IL type")
+ )
+ ;
+ Imports = []
+ ).
+foreign_type_required_imports(java, _) = [].
+foreign_type_required_imports(asm, _) = [].
:- pred ml_gen_defns(module_info, mlds__defns, io__state, io__state).
:- mode ml_gen_defns(in, out, di, uo) is det.
Index: foreign/compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.62
diff -u -r1.62 ml_code_util.m
--- foreign/compiler/ml_code_util.m 12 Apr 2002 01:24:07 -0000 1.62
+++ foreign/compiler/ml_code_util.m 3 May 2002 17:44:24 -0000
@@ -2160,14 +2160,11 @@
ml_type_might_contain_pointers(mlds__native_float_type) = no.
ml_type_might_contain_pointers(mlds__native_bool_type) = no.
ml_type_might_contain_pointers(mlds__native_char_type) = no.
-ml_type_might_contain_pointers(mlds__foreign_type(_, _, _)) = _ :-
+ml_type_might_contain_pointers(mlds__foreign_type(_)) = _ :-
+ sorry(this_file, "--gc accurate and foreign_type").
% It might contain pointers, so it's not safe to return `no',
% but it also might not be word-sized, so it's not safe to
- % return `yes'. Currently this case should not occur, since
- % currently `foreign_type' is only used for the IL back-end,
- % where GC is handled by the target language.
- unexpected(this_file, "--gc accurate and foreign_type").
-
+ % return `yes'.
ml_type_might_contain_pointers(mlds__class_type(_, _, Category)) =
(if Category = mlds__enum then no else yes).
ml_type_might_contain_pointers(mlds__ptr_type(_)) = yes.
Index: foreign/compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.26
diff -u -r1.26 ml_type_gen.m
--- foreign/compiler/ml_type_gen.m 20 Mar 2002 12:36:47 -0000 1.26
+++ foreign/compiler/ml_type_gen.m 3 May 2002 17:44:25 -0000
@@ -127,7 +127,7 @@
Ctors, TagValues, MaybeEqualityMembers)
).
% XXX Fixme! Same issues here as for eqv_type/1.
-ml_gen_type_2(foreign_type(_, _, _), _, _, _) --> [].
+ml_gen_type_2(foreign_type(_, _), _, _, _) --> [].
%-----------------------------------------------------------------------------%
%
Index: foreign/compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.89
diff -u -r1.89 mlds.m
--- foreign/compiler/mlds.m 12 Apr 2002 01:24:08 -0000 1.89
+++ foreign/compiler/mlds.m 3 May 2002 17:44:26 -0000
@@ -630,12 +630,9 @@
; 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.
+ % This is a type of the target language.
; mlds__foreign_type(
- bool, % is type already boxed?
- sym_name, % structured name representing the type
- string % location of the type (ie assembly)
+ foreign_language_type
)
% MLDS types defined using mlds__class_defn
@@ -1616,6 +1613,7 @@
:- implementation.
:- import_module backend_libs__foreign, parse_tree__modules.
+:- import_module hlds__error_util, libs__globals.
:- import_module int, term, string, require.
%-----------------------------------------------------------------------------%
@@ -1653,10 +1651,34 @@
module_info_types(ModuleInfo, Types),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = foreign_type(IsBoxed, ForeignType, ForeignLocation)
+ Body = foreign_type(MaybeIL, MaybeC)
->
- MLDSType = mlds__foreign_type(IsBoxed,
- ForeignType, ForeignLocation)
+ module_info_globals(ModuleInfo, Globals),
+ globals__get_target(Globals, Target),
+ ( Target = c,
+ ( MaybeC = yes(CForeignType),
+ ForeignType = c(CForeignType)
+ ; MaybeC = no,
+ % This is checked by check_foreign_type
+ % in make_hlds.
+ unexpected(this_file,
+ "mercury_type_to_mlds_type: No C foreign type")
+ )
+ ; Target = il,
+ ( MaybeIL = yes(ILForeignType),
+ ForeignType = il(ILForeignType)
+ ; MaybeIL = no,
+ % This is checked by check_foreign_type
+ % in make_hlds.
+ unexpected(this_file,
+ "mercury_type_to_mlds_type: No IL foreign type")
+ )
+ ; Target = java,
+ sorry(this_file, "foreign types on the java backend")
+ ; Target = asm,
+ sorry(this_file, "foreign types on the asm backend")
+ ),
+ MLDSType = mlds__foreign_type(ForeignType)
;
classify_type(Type, ModuleInfo, Category),
ExportedType = to_exported_type(ModuleInfo, Type),
@@ -1865,5 +1887,10 @@
finality_bits(Finality) \/
constness_bits(Constness) \/
abstractness_bits(Abstractness).
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "mlds.m".
%-----------------------------------------------------------------------------%
Index: foreign/compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.127
diff -u -r1.127 mlds_to_c.m
--- foreign/compiler/mlds_to_c.m 24 Apr 2002 07:37:30 -0000 1.127
+++ foreign/compiler/mlds_to_c.m 3 May 2002 17:44:28 -0000
@@ -663,8 +663,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__foreign_type(_)) -->
+ io__write_string("MR_Box").
mlds_output_pragma_export_type(prefix, mlds__class_type(_, _, _)) -->
io__write_string("MR_Word").
mlds_output_pragma_export_type(prefix, mlds__array_type(_)) -->
@@ -1639,8 +1639,13 @@
mlds_output_type_prefix(mlds__native_bool_type) -->
io__write_string("MR_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__foreign_type(ForeignType)) -->
+ ( { ForeignType = c(c(Name)) },
+ io__write_string(Name)
+ ; { ForeignType = il(_) },
+ { unexpected(this_file,
+ "mlds_output_type_prefix: il foreign_type") }
+ ).
mlds_output_type_prefix(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
%
@@ -1809,7 +1814,8 @@
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(_, _, _), _) --> [].
+ % XXX Currently we can't output a type suffix.
+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) -->
Index: foreign/compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.70
diff -u -r1.70 mlds_to_gcc.m
--- foreign/compiler/mlds_to_gcc.m 24 Apr 2002 07:37:31 -0000 1.70
+++ foreign/compiler/mlds_to_gcc.m 3 May 2002 17:44:29 -0000
@@ -1694,8 +1694,7 @@
).
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__foreign_type(_), _, _, 'MR_Box') --> [].
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) --> [].
Index: foreign/compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.113
diff -u -r1.113 mlds_to_il.m
--- foreign/compiler/mlds_to_il.m 1 May 2002 14:16:54 -0000 1.113
+++ foreign/compiler/mlds_to_il.m 3 May 2002 17:44:32 -0000
@@ -3005,15 +3005,19 @@
mlds_type_to_ilds_type(_, mlds__native_float_type) = ilds__type([], float64).
-mlds_type_to_ilds_type(_, mlds__foreign_type(IsBoxed, ForeignType, Assembly))
+mlds_type_to_ilds_type(_, mlds__foreign_type(ForeignType))
= ilds__type([], Class) :-
- sym_name_to_class_name(ForeignType, ForeignClassName),
- ( IsBoxed = yes,
- Class = class(structured_name(assembly(Assembly),
- ForeignClassName, []))
- ; IsBoxed = no,
- Class = valuetype(structured_name(assembly(Assembly),
- ForeignClassName, []))
+ ( ForeignType = il(il(RefOrVal, Assembly, Type)),
+ sym_name_to_class_name(Type, ForeignClassName),
+ ( RefOrVal = reference,
+ Class = class(structured_name(assembly(Assembly),
+ ForeignClassName, []))
+ ; RefOrVal = value,
+ Class = valuetype(structured_name(assembly(Assembly),
+ ForeignClassName, []))
+ )
+ ; ForeignType = c(_),
+ error("mlds_to_il: c foreign type")
).
mlds_type_to_ilds_type(ILDataRep, mlds__ptr_type(MLDSType)) =
Index: foreign/compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.28
diff -u -r1.28 mlds_to_java.m
--- foreign/compiler/mlds_to_java.m 12 Apr 2002 01:24:11 -0000 1.28
+++ foreign/compiler/mlds_to_java.m 3 May 2002 17:44:34 -0000
@@ -1251,7 +1251,7 @@
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(_, _, _)) = _ :-
+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".
@@ -1619,7 +1619,7 @@
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(_, _, _)) -->
+output_type(mlds__foreign_type(_)) -->
{ unexpected(this_file, "output_type: foreign_type NYI.") }.
output_type(mlds__class_type(Name, Arity, ClassKind)) -->
( { ClassKind = mlds__enum } ->
Index: foreign/compiler/opt_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/opt_util.m,v
retrieving revision 1.114
diff -u -r1.114 opt_util.m
--- foreign/compiler/opt_util.m 20 Mar 2002 12:37:02 -0000 1.114
+++ foreign/compiler/opt_util.m 3 May 2002 17:44:35 -0000
@@ -1341,7 +1341,7 @@
pragma_c_inputs_get_rvals([], []).
pragma_c_inputs_get_rvals([I|Inputs], [R|Rvals]) :-
- I = pragma_c_input(_Name, _Type, R),
+ I = pragma_c_input(_Name, _Type, R, _),
pragma_c_inputs_get_rvals(Inputs, Rvals).
% extract the lvals from the pragma_c_output
@@ -1350,7 +1350,7 @@
pragma_c_outputs_get_lvals([], []).
pragma_c_outputs_get_lvals([O|Outputs], [L|Lvals]) :-
- O = pragma_c_output(L, _Type, _Name),
+ O = pragma_c_output(L, _Type, _Name, _),
pragma_c_outputs_get_lvals(Outputs, Lvals).
% determine all the rvals and lvals referenced by a list of instructions
Index: foreign/compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.50
diff -u -r1.50 pragma_c_gen.m
--- foreign/compiler/pragma_c_gen.m 28 Mar 2002 03:43:33 -0000 1.50
+++ foreign/compiler/pragma_c_gen.m 3 May 2002 17:44:35 -0000
@@ -42,9 +42,9 @@
:- implementation.
:- import_module hlds__hlds_module, hlds__hlds_pred, hlds__hlds_llds.
-:- import_module hlds__instmap.
-:- import_module ll_backend__llds_out, ll_backend__trace.
-:- import_module ll_backend__code_util.
+:- import_module hlds__instmap, hlds__hlds_data, hlds__error_util.
+:- import_module check_hlds__type_util.
+:- import_module ll_backend__llds_out, ll_backend__trace, ll_backend__code_util.
:- import_module backend_libs__foreign.
:- import_module libs__options, libs__globals, libs__tree.
@@ -677,8 +677,8 @@
{ 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) },
+ input_descs_from_arg_info(InArgs, InputDescs),
+ output_descs_from_arg_info(OutArgs, OutputDescs),
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
{ pred_info_module(PredInfo, ModuleName) },
@@ -1186,7 +1186,8 @@
code_info__produce_variable(Var, FirstCode, Rval),
% code_info__produce_variable_in_reg(Var, FirstCode, Lval),
% { Rval = lval(Lval) },
- { Input = pragma_c_input(Name, Type, Rval) },
+ get_maybe_foreign_type_name(Type, MaybeForeign),
+ { Input = pragma_c_input(Name, Type, Rval, MaybeForeign) },
get_pragma_input_vars(Args, Inputs1, RestCode),
{ Inputs = [Input | Inputs1] },
{ Code = tree(FirstCode, RestCode) }
@@ -1196,6 +1197,30 @@
get_pragma_input_vars(Args, Inputs, Code)
).
+:- pred get_maybe_foreign_type_name((type)::in, maybe(string)::out,
+ code_info::in, code_info::out) is det.
+
+get_maybe_foreign_type_name(Type, MaybeForeignType) -->
+ code_info__get_module_info(Module),
+ { module_info_types(Module, Types) },
+ {
+ type_to_ctor_and_args(Type, TypeId, _SubTypes),
+ map__search(Types, TypeId, Defn),
+ hlds_data__get_type_defn_body(Defn, Body),
+ Body = foreign_type(_MaybeIL, MaybeC)
+ ->
+ ( MaybeC = yes(c(Name)),
+ MaybeForeignType = yes(Name)
+ ; MaybeC = no,
+ % This is ensured by check_foreign_type in
+ % make_hlds.
+ unexpected(this_file,
+ "get_maybe_foreign_type_name: no c foreign type")
+ )
+ ;
+ MaybeForeignType = no
+ }.
+
%---------------------------------------------------------------------------%
% pragma_acquire_regs acquires a list of registers in which to place each
@@ -1226,10 +1251,12 @@
code_info__release_reg(Reg),
( code_info__variable_is_forward_live(Var) ->
code_info__set_var_location(Var, Reg),
+ get_maybe_foreign_type_name(OrigType, MaybeForeign),
{
var_is_not_singleton(MaybeName, Name)
->
- PragmaCOutput = pragma_c_output(Reg, OrigType, Name),
+ PragmaCOutput = pragma_c_output(Reg, OrigType,
+ Name, MaybeForeign),
Outputs = [PragmaCOutput | Outputs0]
;
Outputs = Outputs0
@@ -1247,22 +1274,24 @@
% input_descs_from_arg_info returns a list of pragma_c_inputs, which
% are pairs of rvals and (C) variables which receive the input value.
-:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out)
- is det.
+:- pred input_descs_from_arg_info(list(c_arg)::in, list(pragma_c_input)::out,
+ code_info::in, code_info::out) is det.
-input_descs_from_arg_info([], []).
-input_descs_from_arg_info([Arg | Args], Inputs) :-
+input_descs_from_arg_info([], [], CodeInfo, CodeInfo).
+input_descs_from_arg_info([Arg | Args], Inputs, CodeInfo0, CodeInfo) :-
Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
(
var_is_not_singleton(MaybeName, Name)
->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
- Input = pragma_c_input(Name, OrigType, lval(Reg)),
+ get_maybe_foreign_type_name(OrigType, MaybeForeign,
+ CodeInfo0, CodeInfo1),
+ Input = pragma_c_input(Name, OrigType, lval(Reg), MaybeForeign),
Inputs = [Input | Inputs1],
- input_descs_from_arg_info(Args, Inputs1)
+ input_descs_from_arg_info(Args, Inputs1, CodeInfo1, CodeInfo)
;
- input_descs_from_arg_info(Args, Inputs)
+ input_descs_from_arg_info(Args, Inputs, CodeInfo0, CodeInfo)
).
%---------------------------------------------------------------------------%
@@ -1271,22 +1300,26 @@
% are pairs of names of output registers and (C) variables which hold the
% output value.
-:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out)
- is det.
+:- pred output_descs_from_arg_info(list(c_arg)::in, list(pragma_c_output)::out,
+ code_info::in, code_info::out) is det.
-output_descs_from_arg_info([], []).
-output_descs_from_arg_info([Arg | Args], Outputs) :-
+output_descs_from_arg_info([], [], CodeInfo, CodeInfo).
+output_descs_from_arg_info([Arg | Args], Outputs, CodeInfo0, CodeInfo) :-
Arg = c_arg(_Var, MaybeName, OrigType, ArgInfo),
+ output_descs_from_arg_info(Args, Outputs0, CodeInfo0, CodeInfo1),
(
var_is_not_singleton(MaybeName, Name)
->
ArgInfo = arg_info(N, _),
Reg = reg(r, N),
- Outputs = [pragma_c_output(Reg, OrigType, Name) | Outputs0]
+ get_maybe_foreign_type_name(OrigType, MaybeForeign,
+ CodeInfo1, CodeInfo),
+ Outputs = [pragma_c_output(Reg, OrigType, Name, MaybeForeign) |
+ Outputs0]
;
- Outputs = Outputs0
- ),
- output_descs_from_arg_info(Args, Outputs0).
+ Outputs = Outputs0,
+ CodeInfo = CodeInfo1
+ ).
%---------------------------------------------------------------------------%
@@ -1299,4 +1332,10 @@
string__append_list(["mercury_save__", MangledModuleName, "__",
MangledPredName, "__", ArityStr, "_", ProcNumStr], StructName).
+%---------------------------------------------------------------------------%
+
+:- func this_file = string.
+this_file = "pragma_c_gen.m".
+
+%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
Index: foreign/compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.82
diff -u -r1.82 prog_data.m
--- foreign/compiler/prog_data.m 20 Mar 2002 12:37:10 -0000 1.82
+++ foreign/compiler/prog_data.m 3 May 2002 17:44:36 -0000
@@ -316,11 +316,12 @@
% for each of these cases.
%
-:- type ref_or_val
- ---> reference
- ; value.
-
:- type foreign_language_type
+ ---> il(il_foreign_type)
+ ; c(c_foreign_type)
+ .
+
+:- type il_foreign_type
---> il(
ref_or_val, % An indicator of whether the type is a
% reference of value type.
@@ -328,6 +329,15 @@
% assembly)
sym_name % The .NET type name
).
+
+:- type c_foreign_type
+ ---> c(
+ string % The C type name
+ ).
+
+:- type ref_or_val
+ ---> reference
+ ; value.
%
% Stuff for tabling pragmas
Index: foreign/compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.49
diff -u -r1.49 prog_io_pragma.m
--- foreign/compiler/prog_io_pragma.m 20 Mar 2002 12:37:13 -0000 1.49
+++ foreign/compiler/prog_io_pragma.m 3 May 2002 17:44:37 -0000
@@ -225,6 +225,19 @@
InputTerm)
)
;
+ Language = c
+ ->
+ (
+ InputTerm = term__functor(term__string(CTypeName),
+ [], _)
+ ->
+ Result = ok(c(c(CTypeName)))
+ ;
+ Result = error("invalid backend specification term",
+ InputTerm)
+ )
+ ;
+
Result = error("unsupported language specified, unable to parse backend type", InputTerm)
).
@@ -235,7 +248,7 @@
(
parse_special_il_type_name(String0, ForeignTypeResult)
->
- ForeignType = ok(ForeignTypeResult)
+ ForeignType = ok(il(ForeignTypeResult))
;
string__append("class [", String1, String0),
string__sub_string_search(String1, "]", Index)
@@ -243,7 +256,7 @@
string__left(String1, Index, AssemblyName),
string__split(String1, Index + 1, _, TypeNameStr),
string_to_sym_name(TypeNameStr, ".", TypeSymName),
- ForeignType = ok(il(reference, AssemblyName, TypeSymName))
+ ForeignType = ok(il(il(reference, AssemblyName, TypeSymName)))
;
string__append("valuetype [", String1, String0),
string__sub_string_search(String1, "]", Index)
@@ -251,7 +264,7 @@
string__left(String1, Index, AssemblyName),
string__split(String1, Index + 1, _, TypeNameStr),
string_to_sym_name(TypeNameStr, ".", TypeSymName),
- ForeignType = ok(il(value, AssemblyName, TypeSymName))
+ ForeignType = ok(il(il(value, AssemblyName, TypeSymName)))
;
ForeignType = error(
"invalid foreign language type description", ErrorTerm)
@@ -260,8 +273,7 @@
% Parse all the special assembler names for all the builtin types.
% See Parition I 'Built-In Types' (Section 8.2.2) for the list
% of all builtin types.
-:- pred parse_special_il_type_name(string::in,
- foreign_language_type::out) is semidet.
+:- pred parse_special_il_type_name(string::in, il_foreign_type::out) is semidet.
parse_special_il_type_name("bool", il(value, "mscorlib",
qualified(unqualified("System"), "Boolean"))).
Index: foreign/compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.1
diff -u -r1.1 recompilation.usage.m
--- foreign/compiler/recompilation.usage.m 20 Mar 2002 12:37:17 -0000 1.1
+++ foreign/compiler/recompilation.usage.m 3 May 2002 17:44:38 -0000
@@ -1045,7 +1045,7 @@
recompilation__usage__find_items_used_by_type_body(eqv_type(Type)) -->
recompilation__usage__find_items_used_by_type(Type).
recompilation__usage__find_items_used_by_type_body(abstract_type) --> [].
-recompilation__usage__find_items_used_by_type_body(foreign_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: foreign/compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.31
diff -u -r1.31 special_pred.m
--- foreign/compiler/special_pred.m 23 Apr 2002 17:49:16 -0000 1.31
+++ foreign/compiler/special_pred.m 3 May 2002 17:44:40 -0000
@@ -202,7 +202,7 @@
% polymorphism__process_generated_pred can't handle calls to
% polymorphic procedures after the initial polymorphism pass.
%
- Body \= foreign_type(_, _, _),
+ Body \= foreign_type(_, _),
% The special predicates for types with user-defined
% equality or existentially typed constructors are always
Index: foreign/compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.19
diff -u -r1.19 term_util.m
--- foreign/compiler/term_util.m 20 Mar 2002 12:37:28 -0000 1.19
+++ foreign/compiler/term_util.m 3 May 2002 17:44:40 -0000
@@ -270,7 +270,7 @@
Weights = Weights0
;
% This type does not introduce any functors
- TypeBody = foreign_type(_, _, _),
+ TypeBody = foreign_type(_, _),
Weights = Weights0
).
Index: foreign/compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.25
diff -u -r1.25 type_ctor_info.m
--- foreign/compiler/type_ctor_info.m 24 Apr 2002 07:37:33 -0000 1.25
+++ foreign/compiler/type_ctor_info.m 3 May 2002 17:44:41 -0000
@@ -254,7 +254,7 @@
TypeTables = [],
NumPtags = -1
;
- TypeBody = foreign_type(_, _, _),
+ TypeBody = foreign_type(_, _),
TypeCtorRep = unknown,
NumFunctors = -1,
FunctorsInfo = no_functors,
Index: foreign/compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.107
diff -u -r1.107 unify_proc.m
--- foreign/compiler/unify_proc.m 28 Mar 2002 03:43:45 -0000 1.107
+++ foreign/compiler/unify_proc.m 3 May 2002 17:44:49 -0000
@@ -763,7 +763,7 @@
unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
Clauses)
;
- { TypeBody = foreign_type(_, _, _) },
+ { TypeBody = foreign_type(_, _) },
unify_proc__build_call("nyi_foreign_type_unify", [H1, H2],
Context, Goal),
unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
@@ -819,7 +819,7 @@
% invoked.
{ error("trying to create index proc for eqv type") }
;
- { TypeBody = foreign_type(_, _, _) },
+ { TypeBody = foreign_type(_, _) },
{ error("trying to create index proc for a foreign type") }
;
{ TypeBody = abstract_type },
@@ -896,7 +896,7 @@
unify_proc__quantify_clauses_body([Res, H1, H2], Goal, Context,
Clauses)
;
- { TypeBody = foreign_type(_, _, _) },
+ { TypeBody = foreign_type(_, _) },
unify_proc__build_call("nyi_foreign_type_compare",
[Res, H1, H2], Context, Goal),
unify_proc__quantify_clauses_body([Res, H1, H2], Goal, Context,
Index: foreign/doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.246
diff -u -r1.246 reference_manual.texi
--- foreign/doc/reference_manual.texi 16 Mar 2002 05:37:03 -0000 1.246
+++ foreign/doc/reference_manual.texi 3 May 2002 17:45:27 -0000
@@ -5484,9 +5484,36 @@
@node Using pragma foreign_type for C
@subsubsection Using pragma foreign_type for C
-This pragma is currently not supported for C.
+The C @samp{pragma foreign_type} declaration is of the form:
-See the section on using C pointers (@pxref{Using C pointers}) for
+ at example
+:- pragma foreign_type(c, @var{MercuryTypeName}, @var{CForeignType}).
+ at end example
+
+The @var{CForeignType} can be any C type name that obeys the following
+restrictions.
+The following snippet of C code must evaluate to true
+ at code{sizeof(CForeignType) == sizeof(void *)},
+if not the result of using the foreign type is undefined.
+The type name must be such that no part of it is required after a
+variable name to be valid C.
+Function, array and incomplete types are not allowed.
+
+Currently only integer and pointer types are accepted as foreign_types,
+at a later date we plan to lift this restriction and allow enum, struct
+and float types.
+
+If the @var{MercuryTypeName} is the type of a parameter of a procedure
+defined using @samp{pragma foreign_proc},
+it will be passed to the foreign_proc's foreign language code
+as @var{CForeignType}.
+
+ at c XXX This is not currently true.
+ at c Furthermore, any Mercury procedure exported with @samp{pragma export}
+ at c will use @var{CForeignType} as the type for any
+ at c parameters whose Mercury type is @var{MercuryTypeName}.
+
+Also see the section on using C pointers (@pxref{Using C pointers}) for
information on how to use the c_pointer type with the C interface.
@c XXX we should eventually just move that section to here,
@c presenting it as an alternative to pragma foreign_type.
Index: tests/hard_coded/foreign_type.exp
===================================================================
RCS file: tests/hard_coded/foreign_type.exp
diff -N tests/hard_coded/foreign_type.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type.exp 3 May 2002 17:45:28 -0000
@@ -0,0 +1,2 @@
+X:4
+Y:5
Index: tests/hard_coded/foreign_type.m
===================================================================
RCS file: tests/hard_coded/foreign_type.m
diff -N tests/hard_coded/foreign_type.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type.m 3 May 2002 17:45:28 -0000
@@ -0,0 +1,94 @@
+:- module foreign_type.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- type coord.
+
+:- func new(int, int) = coord.
+
+:- func x(coord) = int.
+:- func y(coord) = int.
+
+main -->
+ { C = new(4, 5) },
+ io__write_string("X:"),
+ io__write_int(x(C)),
+ io__nl,
+ io__write_string("Y:"),
+ io__write_int(y(C)),
+ io__nl.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+% IL implementation
+:- pragma foreign_type(il, coord,
+ "class [foreign_type__csharp_code]coord").
+
+:- pragma foreign_decl("C#", "
+public class coord {
+ public int x;
+ public int y;
+}
+").
+
+:- pragma foreign_proc("C#", new(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure],
+"
+ C = new coord();
+ C.x = X;
+ C.y = Y;
+").
+
+:- pragma foreign_proc("C#", x(C::in) = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = C.x;
+").
+
+:- pragma foreign_proc("C#", y(C::in) = (Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ Y = C.y;
+").
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+% C implementation
+:- pragma foreign_type(c, coord, "coord *").
+
+:- pragma foreign_decl(c, "
+typedef struct {
+ int x, y;
+} coord;
+").
+
+:- pragma foreign_proc(c, new(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure],
+"
+ C = GC_NEW(coord);
+ C->x = X;
+ C->y = Y;
+").
+
+:- pragma foreign_proc(c, x(C::in) = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = C->x;
+").
+
+:- pragma foreign_proc(c, y(C::in) = (Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ Y = C->y;
+").
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.108
diff -u -r1.108 Mmakefile
--- tests/invalid/Mmakefile 25 Mar 2002 21:13:29 -0000 1.108
+++ tests/invalid/Mmakefile 3 May 2002 17:45:28 -0000
@@ -52,6 +52,7 @@
ext_type_bug.m \
exported_mode.m \
field_syntax_error.m \
+ foreign_type.m \
func_errors.m \
funcs_as_preds.m \
ho_default_func_1.m \
Index: tests/invalid/foreign_type.err_exp
===================================================================
RCS file: tests/invalid/foreign_type.err_exp
diff -N tests/invalid/foreign_type.err_exp
Index: tests/invalid/foreign_type.m
===================================================================
RCS file: tests/invalid/foreign_type.m
diff -N tests/invalid/foreign_type.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_type.m 3 May 2002 17:45:28 -0000
@@ -0,0 +1,56 @@
+:- module foreign_type.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+main -->
+ { _C = new(1, 2) },
+ { _E = north },
+ { _Pi = pi },
+ io__write_string("Success.\n").
+
+:- pragma foreign_decl(c, "
+typedef enum {
+ north,
+ east,
+ west,
+ south,
+} dirs;
+
+typedef struct {
+ int x, y;
+} coord;
+").
+
+:- type dir.
+:- pragma foreign_type(c, dir, "dirs").
+
+:- type coord.
+:- pragma foreign_type(c, coord, "coord").
+
+:- type double.
+:- pragma foreign_type(c, double, "double").
+
+:- func north = dir.
+:- pragma foreign_proc(c, north = (E::out),
+ [will_not_call_mercury, promise_pure], "
+ E = north;
+").
+
+:- func new(int, int) = coord.
+:- pragma foreign_proc(c, new(X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure], "
+ C.x = X;
+ C.y = Y;
+").
+
+:- func pi = double.
+:- pragma foreign_proc(c, pi = (Pi::out),
+ [will_not_call_mercury, promise_pure], "
+ Pi = 3.14;
+").
--------------------------------------------------------------------------
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