[m-rev.] for review: merge foreign_type pragma on to the main branch

Peter Ross peter.ross at miscrit.be
Wed Oct 24 21:14:17 AEST 2001


Ok, here is the interdiff.

--- zzlog.foreign_type	Wed Oct 24 12:14:14 2001
+++ zzlog.foreign_type3	Wed Oct 24 13:05:43 2001
@@ -1,16 +1,16 @@
 
-
-Estimated hours taken: 8
+Estimated hours taken: 10
 Branches: main
 
 Merge the foreign_type pragma changes from the dotnet branch to the main
-branch.
+branch, plus do some more development work to generalise the change.
 
 compiler/prog_data.m:
     Add a type to hold the data from parsing a pragma foreign_type decl.
 
 compiler/prog_io_pragma.m:
-    Parse the pragma foreign_type.
+    Parse the pragma foreign_type.  This code is currently commented
+    out, while we decide on the syntax.
 
 compiler/hlds_data.m:
     Add a new alternative to hlds_type_body where the body of the type
@@ -19,40 +19,48 @@
 compiler/make_hlds.m:
     Place the foreign_type pragmas into the HLDS.
 
+compiler/foreign.m:
+    Implement to_type_string which replaces export__type_to_type_string,
+    unlike export__type_to_type_string foreign__to_type_string takes an
+    argument specifying which language the representation is meant to be
+    in.  to_type_string also needs to take a module_info to handle
+    foreign_types correctly.  To avoid the need for the module_info to
+    be passed around the MLDS backend we provide a new type
+    exported_type which provides enough information for an alternate
+    version of to_type_string to be called.
+
 compiler/export.m:
-    Change export__type_to_type_string so that we return the
-    foreign type representation if it exists.
+    Delete export__type_to_type_string.
 
 compiler/llds.m:
-    Since export__type_to_type_string needs a module_info, we add a new
+    Since foreign__to_type_string needs a module_info, we add a new
     field to pragma_c_arg_decl which is the result of calling
-    export__type_to_type_string.  This avoids threading the module_info
+    foreign__to_type_string.  This avoids threading the module_info
     around various llds passes.
 
 compiler/mlds.m:
-    Table the result of export__type_to_type_string so as to avoid
+    Record with in the mercury_type the exported_type, this avoids
     passing the module_info around the MLDS backend.
     Also add the foreign_type alternative to mlds__type.
-    Update mercury_type_to_mlds_type so that handles types which are
+    Update mercury_type_to_mlds_type so that it handles types which are
     foreign types.
     
 compiler/mlds_to_il.m:
-    Convert a mlds__foreign_type into an ilds__type.  Note that the
-    basic types aren't allowed to appear in the assembler in their
-    System.* form so we detect all these cases and convert to the basic
-    type instead.
+    Convert a mlds__foreign_type into an ilds__type.
 
 compiler/ilds.m:
     The CLR spec requires that System.Object and System.String be
-    treated specially in the IL assembly (you have to use the name
-    object and string instead of the System.* names), so add them as
-    base types.
+    treated specially in the IL assembly so add them as simple types.
 
 compiler/ilasm.m:
-    Changes to handle the additions to the simple ilds types.
+    Before outputting a class name into the IL assembly check whether it
+    it can be simplified to a builtin type, and if so output that name
+    instead as required by the ECMA spec.
+    Changes for the addition of string and object as simple types.
 
 doc/reference_manual.texi:
-    Document the new pragma.
+    Document the new pragma, this is currently commented out because it
+    refers to syntax that has not yet been finalised.
 
 compiler/fact_table.m:
 compiler/llds_out.m:
@@ -68,7 +76,7 @@
 compiler/mlds_to_mcpp.m:
 compiler/pragma_c_gen.m:
 compiler/rtti_to_mlds.m:
-    Changes to handle the tabling of calls to export__type_to_string.
+    Changes to handle using foreign__to_type_string.
 
 compiler/hlds_out.m:
 compiler/intermod.m:
@@ -79,7 +87,7 @@
 compiler/term_util.m:
 compiler/type_ctor_info.m:
 compiler/unify_proc.m:
-    Changes to hanlde the new hlds_type_body.
+    Changes to handle the new hlds_type_body.
 
 compiler/mercury_to_mercury.m:
     Output the pragma foreign_type declaration.
@@ -89,5 +97,3 @@
 
 compiler/modules.m:
     Pragma foreign_type is allowed in the interface.
-
-

diff -u compiler/export.m compiler/export.m
--- compiler/export.m
+++ compiler/export.m
@@ -48,11 +48,6 @@
 % Utilities for generating C code which interfaces with Mercury.  
 % The {MLDS,LLDS}->C backends and fact tables use this code.
 
-	% Convert the type to a string corresponding to its C type.
-	% (Defaults to MR_Word).
-:- pred export__type_to_type_string(module_info, type, string).
-:- mode export__type_to_type_string(in, in, out) is det.
-
 	% Generate C code to convert an rval (represented as a string), from
 	% a C type to a mercury C type (ie. convert strings and floats to
 	% words) and return the resulting C code as a string.
@@ -70,8 +65,9 @@
 
 :- implementation.
 
+:- import_module foreign.
 :- import_module modules.
-:- import_module hlds_data, hlds_pred, type_util.
+:- import_module hlds_pred, type_util.
 :- import_module code_model.
 :- import_module code_gen, code_util, llds_out.
 :- import_module globals, options.
@@ -336,7 +332,7 @@
 			RetArgMode = top_out,
 			\+ type_util__is_dummy_argument_type(RetType)
 		->
-			export__type_to_type_string(Module, RetType, C_RetType),
+			C_RetType = to_type_string(c, Module, RetType),
 			argloc_to_string(RetArgLoc, RetArgString0),
 			convert_type_from_mercury(RetArgString0, RetType,
 				RetArgString),
@@ -436,7 +432,7 @@
 	;
 		ArgName = ""
 	),
-	export__type_to_type_string(Module, Type, TypeString0),
+	TypeString0 = to_type_string(c, Module, Type),
 	(
 		Mode = top_out
 	->
@@ -629,42 +625,5 @@
 		{ error("export__produce_header_file_2: foreign languages other than C unimplemented") }
 	),
 	export__produce_header_file_2(ExportedProcs).
-
-	% Convert a term representation of a variable type to a string which
-	% represents the C type of the variable
-	% Apart from special cases, local variables become MR_Words
-export__type_to_type_string(ModuleInfo, Type, Result) :-
-	( Type = term__functor(term__atom("int"), [], _) ->
-		Result = "MR_Integer"
-	; Type = term__functor(term__atom("float"), [], _) ->
-		Result = "MR_Float"
-	; Type = term__functor(term__atom("string"), [], _) ->
-		Result = "MR_String"
-	; Type = term__functor(term__atom("character"), [], _) ->
-		Result = "MR_Char"
-	;
-		module_info_types(ModuleInfo, Types),
-		(
-			type_to_type_id(Type, TypeId, _),
-			map__search(Types, TypeId, TypeDefn)
-		->
-				% XXX how we output the type depends on
-				% which foreign language we are using.
-			hlds_data__get_type_defn_body(TypeDefn, Body),
-			( Body = foreign_type(ForeignType, _) ->
-				Result = sym_name_to_string(ForeignType) ++ " *"
-			;
-				Result = "MR_Word"
-			)
-		;
-			Result = "MR_Word"
-		)
-	).
-
-:- func sym_name_to_string(sym_name) = string.
-
-sym_name_to_string(unqualified(Name)) = Name.
-sym_name_to_string(qualified(ModuleSpec, Name)) 
-	= sym_name_to_string(ModuleSpec) ++ ("::" ++ Name).
 
 %-----------------------------------------------------------------------------%
diff -u compiler/fact_table.m compiler/fact_table.m
--- compiler/fact_table.m
+++ compiler/fact_table.m
@@ -96,7 +96,7 @@
 % HLDS modules
 :- import_module hlds_out, hlds_data, mode_util, inst_match.
 % LLDS back-end modules
-:- import_module arg_info, llds, llds_out, code_util, export.
+:- import_module arg_info, llds, llds_out, code_util, export, foreign.
 % Modules shared between different back-ends.
 :- import_module passes_aux, code_model.
 % Misc
@@ -3251,7 +3251,7 @@
 		string::out) is det.
 
 generate_arg_decl_code(Name, Type, Module, DeclCode) :-
-	export__type_to_type_string(Module, Type, C_Type),
+	C_Type = to_type_string(c, Module, Type),
 	string__format("\t\t%s %s;\n", [s(C_Type), s(Name)], DeclCode).
 
 :- pred generate_arg_input_code(string::in, (type)::in, int::in, int::in,
diff -u compiler/hlds_data.m compiler/hlds_data.m
--- compiler/hlds_data.m
+++ compiler/hlds_data.m
@@ -294,8 +294,9 @@
 	;	foreign_type(
 			sym_name,	% structured name of foreign type
 					% which represents the mercury type.
-			string		% String which represents where I can
-					% find a definition for this type.
+			string		% Location of the definition for this
+					% type (such as assembly or
+					% library name)
 		)
 	;	abstract_type.
 
diff -u compiler/ilasm.m compiler/ilasm.m
--- compiler/ilasm.m
+++ compiler/ilasm.m
@@ -701,8 +701,57 @@
 output_simple_type(string, I, I) --> io__write_string("string").
 output_simple_type(refany, I, I) --> io__write_string("refany").
 output_simple_type(class(Name), Info0, Info) --> 
-	io__write_string("class "),
-	output_structured_name(Name, Info0, Info).
+	{ Name = structured_name(AssemblyName, QualifiedName, _) },
+		% Parition II section 'Built-in Types' (7.2 in Beta2) states
+		% that all builtin types *must* be rereferenced by their
+		% special encoding.  See Parition I 'Built-In Types' 
+		% (8.2.2 in Beta2) for the list of all builtin types.
+	( 
+		{ AssemblyName = assembly("mscorlib") },
+		{ QualifiedName = ["System", TypeName] }
+	->
+		( { TypeName = "Boolean" } ->
+			output_simple_type(bool, Info0, Info)
+		; { TypeName = "Char" } ->
+			output_simple_type(char, Info0, Info)
+		; { TypeName = "Object" } ->
+			output_simple_type(object, Info0, Info)
+		; { TypeName = "String" } ->
+			output_simple_type(string, Info0, Info)
+		; { TypeName = "Single" } ->
+			output_simple_type(float32, Info0, Info)
+		; { TypeName = "Double" } ->
+			output_simple_type(float64, Info0, Info)
+		; { TypeName = "SByte" } ->
+			output_simple_type(int8, Info0, Info)
+		; { TypeName = "Int16" } ->
+			output_simple_type(int16, Info0, Info)
+		; { TypeName = "Int32" } ->
+			output_simple_type(int32, Info0, Info)
+		; { TypeName = "Int64" } ->
+			output_simple_type(int64, Info0, Info)
+		; { TypeName = "IntPtr" } ->
+			output_simple_type(native_int, Info0, Info)
+		; { TypeName = "UIntPtr" } ->
+			output_simple_type(native_uint, Info0, Info)
+		; { TypeName = "TypedReference" } ->
+			output_simple_type(refany, Info0, Info)
+		; { TypeName = "Byte" } ->
+			output_simple_type(uint8, Info0, Info)
+		; { TypeName = "UInt16" } ->
+			output_simple_type(uint16, Info0, Info)
+		; { TypeName = "UInt32" } ->
+			output_simple_type(uint32, Info0, Info)
+		; { TypeName = "UInt64" } ->
+			output_simple_type(uint64, Info0, Info)
+		;
+			io__write_string("class "),
+			output_structured_name(Name, Info0, Info)
+		)
+	;
+		io__write_string("class "),
+		output_structured_name(Name, Info0, Info)
+	).
 output_simple_type(value_class(Name), Info0, Info) --> 
 	io__write_string("valuetype "),
 	output_structured_name(Name, Info0, Info).
diff -u compiler/intermod.m compiler/intermod.m
--- compiler/intermod.m
+++ compiler/intermod.m
@@ -1177,7 +1177,13 @@
 		{ TypeBody = abstract_type }
 	;
 		{ Body = foreign_type(_, _) },
-		{ error("foreign types not implemented") }
+		{ TypeBody = abstract_type },
+			% XXX trd
+			% Also here we need to output the pragma
+			% for the type body, we output a abstract type for
+			% the type definition which is fine.
+		{ error("foreign_type not yet implemented") }
+
 	),
 	mercury_output_item(type_defn(VarSet, Name, Args, TypeBody, true),
 		Context).
diff -u compiler/ml_code_gen.m compiler/ml_code_gen.m
--- compiler/ml_code_gen.m
+++ compiler/ml_code_gen.m
@@ -2773,8 +2773,7 @@
 		MaybeNameAndMode = yes(ArgName - _Mode),
 		\+ var_is_singleton(ArgName)
 	->
-		TypeString = foreign_type_to_type_string(ModuleInfo,
-				Lang, Type),
+		TypeString = to_type_string(Lang, ModuleInfo, Type),
 		string__format("\t%s %s;\n", [s(TypeString), s(ArgName)],
 			DeclString)
 	;
@@ -2784,18 +2783,6 @@
 	},
 	{ Decl = raw_target_code(DeclString, []) }.
 
-:- func foreign_type_to_type_string(module_info,
-		foreign_language, prog_data__type) = string.
-foreign_type_to_type_string(ModuleInfo, Lang, Type) = TypeString :-
-	( 
-		type_util__var(Type, _),
-		Lang = managed_cplusplus
-	->
-		TypeString = "MR_Box"
-	;
-		export__type_to_type_string(ModuleInfo, Type, TypeString)
-	).
-
 %-----------------------------------------------------------------------------%
 
 % var_is_singleton determines whether or not a given pragma_c variable
@@ -2863,8 +2850,7 @@
 			% --high-level-data, so we always use a cast here.
 			% (Strictly speaking the cast is not needed for
 			% a few cases like `int', but it doesn't do any harm.)
-			TypeString = foreign_type_to_type_string(ModuleInfo,
-					Lang, OrigType),
+			TypeString = to_type_string(Lang, ModuleInfo, OrigType),
 			string__format("(%s)", [s(TypeString)], Cast)
 		;
 			% For --no-high-level-data, we only need to use
@@ -2950,8 +2936,7 @@
 			% Note that we can't easily obtain the type string
 			% for the RHS of the assignment, so instead we
 			% cast the LHS.
-			TypeString = foreign_type_to_type_string(ModuleInfo,
-					Lang, OrigType),
+			TypeString = to_type_string(Lang, ModuleInfo, OrigType),
 			string__format("*(%s *)&", [s(TypeString)], LHS_Cast),
 			RHS_Cast = ""
 		;
diff -u compiler/ml_code_util.m compiler/ml_code_util.m
--- compiler/ml_code_util.m
+++ compiler/ml_code_util.m
@@ -699,6 +699,7 @@
 :- implementation.
 
 :- import_module ml_call_gen.
+:- import_module foreign.
 :- import_module prog_util, type_util, mode_util, special_pred, error_util.
 :- import_module code_util. % XXX for `code_util__compiler_generated'.
 :- import_module globals, options.
@@ -956,7 +957,8 @@
 ml_gen_array_elem_type(elem_type_int) = mlds__native_int_type.
 ml_gen_array_elem_type(elem_type_generic) = mlds__generic_type.
 
-ml_string_type = mercury_type(string_type, str_type, "MR_String").
+ml_string_type = mercury_type(string_type, str_type,
+				non_foreign_type(string_type)).
 
 %-----------------------------------------------------------------------------%
 %
diff -u compiler/ml_switch_gen.m compiler/ml_switch_gen.m
--- compiler/ml_switch_gen.m
+++ compiler/ml_switch_gen.m
@@ -99,7 +99,7 @@
 :- import_module ml_tag_switch, ml_string_switch.
 :- import_module ml_code_gen, ml_unify_gen, ml_code_util, ml_simplify_switch.
 :- import_module switch_util, type_util.
-:- import_module export, options.
+:- import_module foreign, options.
 
 :- import_module bool, int, string, map, tree, std_util, require.
 
@@ -396,8 +396,8 @@
 	=(MLGenInfo),
 	{
 		ml_gen_info_get_module_info(MLGenInfo, ModuleInfo),
-		export__type_to_type_string(ModuleInfo, Type, TypeString),
-		MLDS_Type = mercury_type(Type, TypeCategory, TypeString),
+		ExportedType = to_exported_type(ModuleInfo, Type),
+		MLDS_Type = mercury_type(Type, TypeCategory, ExportedType),
 		switch_util__type_range(TypeCategory, Type, ModuleInfo,
 			MinRange, MaxRange)
 	->
diff -u compiler/mlds.m compiler/mlds.m
--- compiler/mlds.m
+++ compiler/mlds.m
@@ -280,7 +280,7 @@
 
 :- import_module hlds_module, hlds_pred, hlds_data.
 :- import_module prog_data, builtin_ops, rtti, code_model.
-:- import_module type_util.
+:- import_module foreign, type_util.
 
 % To avoid duplication, we use a few things from the LLDS
 % (specifically stuff for the C interface).
@@ -537,8 +537,11 @@
 			prog_data__type,	% the exact Mercury type
 			builtin_type,		% what kind of type it is:
 						% enum, float, etc.
-			string			% the result of 
-						% export__type_to_type_string
+			exported_type		% a representation of the type
+						% which can be used to
+						% determine the foreign
+						% language representation of
+						% the type.
 		)
 
 	 	% The Mercury array type is treated specially, some backends
@@ -1508,7 +1511,7 @@
 %-----------------------------------------------------------------------------%
 
 :- implementation.
-:- import_module export, modules.
+:- import_module foreign, modules.
 :- import_module int, term, string, require.
 
 %-----------------------------------------------------------------------------%
@@ -1551,8 +1554,8 @@
 		MLDSType = mlds__foreign_type(ForeignType, ForeignLocation)
 	;
 		classify_type(Type, ModuleInfo, Category),
-		export__type_to_type_string(ModuleInfo, Type, TypeString),
-		MLDSType = mercury_type(Type, Category, TypeString)
+		ExportedType = to_exported_type(ModuleInfo, Type),
+		MLDSType = mercury_type(Type, Category, ExportedType)
 	).
 
 %-----------------------------------------------------------------------------%
diff -u compiler/mlds_to_c.m compiler/mlds_to_c.m
--- compiler/mlds_to_c.m
+++ compiler/mlds_to_c.m
@@ -60,7 +60,7 @@
 :- import_module ml_code_util.	% for ml_gen_public_field_decl_flags, which is
 				% used by the code that handles derived classes
 :- import_module ml_type_gen.	% for ml_gen_type_name
-:- import_module export.	% for export__type_to_type_string
+:- import_module foreign.
 :- import_module globals, options, passes_aux.
 :- import_module builtin_ops, c_util, modules.
 :- import_module prog_data, prog_out, type_util, error_util, code_model.
@@ -622,8 +622,8 @@
 		% Array types are exported as MR_Word
 mlds_output_pragma_export_type(prefix, mercury_array_type(_ElemType)) -->
 	io__write_string("MR_Word").
-mlds_output_pragma_export_type(prefix, mercury_type(_, _, TypeString)) -->
-	io__write_string(TypeString).
+mlds_output_pragma_export_type(prefix, mercury_type(_, _, ExportedType)) -->
+	io__write_string(to_type_string(c, ExportedType)).
 mlds_output_pragma_export_type(prefix, mlds__cont_type(_)) -->
 	io__write_string("MR_Word").
 mlds_output_pragma_export_type(prefix, mlds__commit_type) -->
diff -u compiler/mlds_to_il.m compiler/mlds_to_il.m
--- compiler/mlds_to_il.m
+++ compiler/mlds_to_il.m
@@ -143,6 +143,7 @@
 :- import_module ilasm, il_peephole.
 :- import_module ml_util, ml_code_util, error_util.
 :- import_module ml_type_gen.
+:- import_module foreign.
 :- use_module llds. /* for user_foreign_code */
 
 :- import_module bool, int, map, string, set, list, assoc_list, term.
@@ -1017,7 +1018,7 @@
 		{ UnivMercuryType = term__functor(term__atom("univ"), [], 
 			context("", 0)) },
 		{ UnivMLDSType = mercury_type(UnivMercuryType,
-				user_type, "XXX") },
+				user_type, non_foreign_type(UnivMercuryType)) },
 		{ UnivType = mlds_type_to_ilds_type(DataRep, UnivMLDSType) },
 
 		{ RenameNode = (func(N) = list__map(RenameRets, N)) },
@@ -2903,45 +2904,9 @@
 
 mlds_type_to_ilds_type(_, mlds__foreign_type(ForeignType, Assembly))
 	= ilds__type([], Class) :-
-	( ForeignType = qualified(unqualified("System"), "Boolean") ->
-		Class = bool
-	; ForeignType = qualified(unqualified("System"), "Char") ->
-		Class = char
-	; ForeignType = qualified(unqualified("System"), "Object") ->
-		Class = object
-	; ForeignType = qualified(unqualified("System"), "String") ->
-		Class = string
-	; ForeignType = qualified(unqualified("System"), "Single") ->
-		Class = float32
-	; ForeignType = qualified(unqualified("System"), "Double") ->
-		Class = float64
-	; ForeignType = qualified(unqualified("System"), "SByte") ->
-		Class = int8
-	; ForeignType = qualified(unqualified("System"), "Int16") ->
-		Class = int16
-	; ForeignType = qualified(unqualified("System"), "Int32") ->
-		Class = int32
-	; ForeignType = qualified(unqualified("System"), "Int64") ->
-		Class = int64
-	; ForeignType = qualified(unqualified("System"), "IntPtr") ->
-		Class = native_int
-	; ForeignType = qualified(unqualified("System"), "UIntPtr") ->
-		Class = native_uint
-	; ForeignType = qualified(unqualified("System"), "TypedReference") ->
-		Class = refany
-	; ForeignType = qualified(unqualified("System"), "Byte") ->
-		Class = uint8
-	; ForeignType = qualified(unqualified("System"), "UInt16") ->
-		Class = uint16
-	; ForeignType = qualified(unqualified("System"), "UInt32") ->
-		Class = uint32
-	; ForeignType = qualified(unqualified("System"), "UInt64") ->
-		Class = uint64
-	;
-		sym_name_to_class_name(ForeignType, ForeignClassName),
-		Class = class(structured_name(assembly(Assembly),
-				ForeignClassName, []))
-	).
+	sym_name_to_class_name(ForeignType, ForeignClassName),
+	Class = class(structured_name(assembly(Assembly),
+			ForeignClassName, [])).
 
 mlds_type_to_ilds_type(ILDataRep, mlds__ptr_type(MLDSType)) =
 	ilds__type([], '&'(mlds_type_to_ilds_type(ILDataRep, MLDSType))).
@@ -3466,21 +3431,19 @@
 rval_const_to_type(code_addr_const(_)) = mlds__func_type(
 		mlds__func_params([], [])).
 rval_const_to_type(int_const(_)) 
-	= mercury_type(term__functor(term__atom("int"), [], context("", 0)),
-			int_type, "MR_Integer").
-rval_const_to_type(float_const(_))
-	= mercury_type(term__functor(term__atom("float"), [], context("", 0)),
-		float_type, "MR_Float").
+	= mercury_type(IntType, int_type, non_foreign_type(IntType)) :-
+	IntType = term__functor(term__atom("int"), [], context("", 0)).
+rval_const_to_type(float_const(_)) 
+	= mercury_type(FloatType, float_type, non_foreign_type(FloatType)) :-
+	FloatType = term__functor(term__atom("float"), [], context("", 0)).
 rval_const_to_type(false) = mlds__native_bool_type.
 rval_const_to_type(true) = mlds__native_bool_type.
-rval_const_to_type(string_const(_))
-	= mercury_type(
-		term__functor(term__atom("string"), [], context("", 0)),
-			str_type, "MR_String").
-rval_const_to_type(multi_string_const(_, _))
-	= mercury_type(term__functor(term__atom("string"), [], context("", 0)),
-			% XXX Should this be MR_Word instead?
-			str_type, "MR_String").
+rval_const_to_type(string_const(_)) 
+	= mercury_type(StrType, str_type, non_foreign_type(StrType)) :-
+	StrType = term__functor(term__atom("string"), [], context("", 0)).
+rval_const_to_type(multi_string_const(_, _)) 
+	= mercury_type(StrType, str_type, non_foreign_type(StrType)) :-
+	StrType = term__functor(term__atom("string"), [], context("", 0)).
 rval_const_to_type(null(MldsType)) = MldsType.
 
 %-----------------------------------------------------------------------------%
diff -u compiler/pragma_c_gen.m compiler/pragma_c_gen.m
--- compiler/pragma_c_gen.m
+++ compiler/pragma_c_gen.m
@@ -42,7 +42,7 @@
 :- implementation.
 
 :- import_module hlds_module, hlds_pred, llds_out, trace, tree.
-:- import_module code_util, export.
+:- import_module code_util, foreign.
 :- import_module options, globals.
 
 :- import_module bool, string, int, assoc_list, set, map, require, term.
@@ -1136,7 +1136,7 @@
 	(
 		var_is_not_singleton(ArgName, Name)
 	->
-		export__type_to_type_string(Module, OrigType, OrigTypeString),
+		OrigTypeString = to_type_string(c, Module, OrigType),
 		Decl = pragma_c_arg_decl(OrigType, OrigTypeString, Name),
 		make_pragma_decls(Args, Module, Decls1),
 		Decls = [Decl | Decls1]
diff -u compiler/prog_io_pragma.m compiler/prog_io_pragma.m
--- compiler/prog_io_pragma.m
+++ compiler/prog_io_pragma.m
@@ -70,6 +70,7 @@
 			ErrorTerm)
 	).
 
+/*
 parse_pragma_type(ModuleName, "foreign_type", PragmaTerms,
             ErrorTerm, _VarSet, Result) :-
     ( PragmaTerms = [MercuryName, ForeignName, Target] ->
@@ -114,6 +115,7 @@
     "wrong number of arguments in `:- pragma foreign_type' declaration",
             ErrorTerm)
     ).
+*/
 
 parse_pragma_type(ModuleName, "foreign_decl", PragmaTerms,
 			ErrorTerm, VarSet, Result) :-
diff -u compiler/rtti_to_mlds.m compiler/rtti_to_mlds.m
--- compiler/rtti_to_mlds.m
+++ compiler/rtti_to_mlds.m
@@ -30,7 +30,7 @@
 :- func mlds_rtti_type_name(rtti_name) = string.
 
 :- implementation.
-:- import_module prog_data.
+:- import_module foreign, prog_data.
 :- import_module pseudo_type_info, prog_util, prog_out, type_util.
 :- import_module ml_code_util, ml_unify_gen.
 :- import_module bool, list, std_util, string, term, require.
@@ -133,10 +133,12 @@
 	]).
 gen_init_rtti_data_defn(field_names(_RttiTypeId, _Ordinal, MaybeNames), _, _,
 		Init, []) :-
+	StrType = term__functor(term__atom("string"), [], context("", 0)),
 	Init = gen_init_array(gen_init_maybe(
-			mercury_type(functor(atom("string"), [],
-				context("", 0)), str_type, "MR_String"),
+			mercury_type(StrType, str_type,
+				non_foreign_type(StrType)),
 			gen_init_string), MaybeNames).
+	
 gen_init_rtti_data_defn(field_types(_RttiTypeId, _Ordinal, Types),
 		ModuleName, _, Init, []) :-
 	Init = gen_init_array(
diff -u doc/reference_manual.texi doc/reference_manual.texi
--- doc/reference_manual.texi
+++ doc/reference_manual.texi
@@ -6656,8 +6656,6 @@
                                 @samp{#@var{line}} directives provide support
                                 for preprocessors and other tools that
                                 generate Mercury code.
-* Interfacing::                 Pragmas can be used to ease interfacing
-                                with other languages.
 @end menu
 
 @node Inlining
@@ -6835,31 +6833,34 @@
 generated file for the automatically generated text, as in the above
 example.
 
- at node Interfacing
- at section Interfacing
+ at c * Interfacing::                 Pragmas can be used to ease interfacing
+ at c                                 with other languages.
 
-A declaration of the form
-
- at example
-:- pragma foreign_type(xmldoc, 'System__Xml__XmlDocument', il("System.Xml")).
- at end example
-
-ensures that on the IL backend the mercury type @samp{xmldoc} is
-represented by the backend as a @samp{System.Xml.XmlDocument}.  This
-avoids the need to marshall values when interfacing with libraries
-written in other languages.  The following example shows how to do this
-interfacing.
-
- at example
-:- pred loadxml(string::in, xmldoc::di, xmldoc::uo) is det.
-
-:- pragma foreign_proc("C#", load(String::in, XML0::di, XML::uo),
-        [will_not_call_mercury],
-"
-    XML0.LoadXml(String);
-    XML = XML0;
-").
- at end example
+ at c @node Interfacing
+ at c @section Interfacing
+ at c 
+ at c A declaration of the form
+ at c 
+ at c @example
+ at c :- pragma foreign_type(xmldoc, 'System__Xml__XmlDocument', il("System.Xml")).
+ at c @end example
+ at c 
+ at c ensures that on the IL backend the mercury type @samp{xmldoc} is
+ at c represented by the backend as a @samp{System.Xml.XmlDocument}.  This
+ at c avoids the need to marshall values when interfacing with libraries
+ at c written in other languages.  The following example shows how to do this
+ at c interfacing.
+ at c 
+ at c @example
+ at c :- pred loadxml(string::in, xmldoc::di, xmldoc::uo) is det.
+ at c 
+ at c :- pragma foreign_proc("C#", load(String::in, XML0::di, XML::uo),
+ at c         [will_not_call_mercury],
+ at c "
+ at c     XML0.LoadXml(String);
+ at c     XML = XML0;
+ at c ").
+ at c @end example
 
 @node Implementation-dependent extensions
 @chapter Implementation-dependent extensions
only in patch2:
--- compiler/foreign.m	23 Jul 2001 12:22:04 -0000	1.7
+++ compiler/foreign.m	24 Oct 2001 11:00:14 -0000
@@ -22,7 +22,23 @@
 :- import_module hlds_module, hlds_pred.
 :- import_module llds.
 
-:- import_module list, bool.
+:- import_module bool, list, string.
+	% A type which is used to determine the string representation of a
+	% mercury type for various foreign languages.
+:- type exported_type.
+
+	% Given a type which is not defined as a foreign type, get the
+	% exported_type representation of that type.
+:- func foreign__non_foreign_type((type)) = exported_type.
+
+	% Given an arbitary mercury type, get the exported_type representation
+	% of that type.
+:- func foreign__to_exported_type(module_info, (type)) = exported_type.
+
+	% Given a representation of a type determine the string which
+	% corresponds to that type in the specified foreign language.
+:- func foreign__to_type_string(foreign_language, exported_type) = string.
+:- func foreign__to_type_string(foreign_language, module_info, (type)) = string.
 
 	% Filter the decls for the given foreign language. 
 	% The first return value is the list of matches, the second is
@@ -107,10 +123,11 @@
 
 :- implementation.
 
-:- import_module list, map, assoc_list, std_util, string, varset, int.
+:- import_module list, map, assoc_list, std_util, string, varset, int, term.
 :- import_module require.
 
 :- import_module hlds_pred, hlds_module, type_util, mode_util, error_util.
+:- import_module hlds_data, prog_out.
 :- import_module code_model, globals.
 
 	% Currently we don't use the globals to compare foreign language
@@ -496,9 +513,74 @@
 		FM = qualified(Module, Name ++ Ending)
 	).
 
+%-----------------------------------------------------------------------------%
 
+:- type exported_type
+	--->	foreign(sym_name)	% A type defined by a
+					% pragma foreign_type.
+	;	mercury((type)).	% Any other mercury type.
+
+non_foreign_type(Type) = mercury(Type).
+
+to_exported_type(ModuleInfo, Type) = ExportType :-
+	module_info_types(ModuleInfo, Types),
+	(
+		type_to_type_id(Type, TypeId, _),
+		map__search(Types, TypeId, TypeDefn)
+	->
+		hlds_data__get_type_defn_body(TypeDefn, Body),
+		( Body = foreign_type(ForeignType, _) ->
+			ExportType = foreign(ForeignType)
+		;
+			ExportType = mercury(Type)
+		)
+	;
+		ExportType = mercury(Type)
+	).
 
+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(csharp, foreign(ForeignType)) = Result :-
+	sym_name_to_string(ForeignType, ".", Result).
+to_type_string(managed_cplusplus, foreign(ForeignType)) = Result ++ " *":-
+	sym_name_to_string(ForeignType, "::", Result).
+to_type_string(il, foreign(ForeignType)) = Result :-
+	sym_name_to_string(ForeignType, ".", Result).
+
+	% XXX does this do the right thing for high level data?
+to_type_string(c, mercury(Type)) = Result :-
+	( Type = term__functor(term__atom("int"), [], _) ->
+		Result = "MR_Integer"
+	; Type = term__functor(term__atom("float"), [], _) ->
+		Result = "MR_Float"
+	; Type = term__functor(term__atom("string"), [], _) ->
+		Result = "MR_String"
+	; Type = term__functor(term__atom("character"), [], _) ->
+		Result = "MR_Char"
+	;
+		Result = "MR_Word"
+	).
+to_type_string(csharp, mercury(_Type)) = _ :-
+	sorry(this_file, "to_type_string for csharp").
+to_type_string(managed_cplusplus, mercury(Type)) = TypeString :-
+	( 
+		type_util__var(Type, _)
+	->
+		TypeString = "MR_Box"
+	;
+		TypeString = to_type_string(c, mercury(Type))
+	).
+to_type_string(il, mercury(_Type)) = _ :-
+	sorry(this_file, "to_type_string for il").
+	
+%-----------------------------------------------------------------------------%
 
 :- func this_file = string.
+
 this_file = "foreign.m".
 
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
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