[m-rev.] diff: deconstruct with exist. vars on .NET backend

[Tyson Dowd]

Hi,

Now you can 
	io__write(Foo),
and
	io__write(univ(Foo)).


===================================================================


Estimated hours taken: 8
Branches: main

library/rtti_implementation.m:
	Handle the deconstruction of values containing existentially
	qualified type variables.




Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.5
diff -u -r1.5 rtti_implementation.m
--- library/rtti_implementation.m	24 Sep 2001 16:35:35 -0000	1.5
+++ library/rtti_implementation.m	25 Sep 2001 09:37:15 -0000
@@ -751,22 +751,25 @@
 get_arg(Term, Index, SecTagLocn, FunctorDesc, TypeInfo) = (Arg) :-
 	ArgTypes = FunctorDesc ^ functor_arg_types,
 	PseudoTypeInfo = get_pti_from_arg_types(ArgTypes, Index),
+	get_type_and_extra_args(TypeInfo, PseudoTypeInfo, Term,
+		FunctorDesc, ExtraArgs, ArgTypeInfo),
 	( SecTagLocn = none ->
-		TagOffset = 0
+		TagOffset = ExtraArgs
 	;
-		TagOffset = 1
+		TagOffset = ExtraArgs + 1
 	),
-	ArgTypeInfo = get_type(TypeInfo, PseudoTypeInfo, Term, FunctorDesc),
 	Arg = get_subterm(ArgTypeInfo, Term, Index, TagOffset).
 
-:- func get_type(type_info, P, T, du_functor_descriptor) = type_info.
+:- pred get_type_and_extra_args(type_info::in, P::in, T::in,
+	du_functor_descriptor::in, int::out, type_info::out) is det.
 
-get_type(TypeInfoParams, PseudoTypeInfo, Term, FunctorDesc) = (ArgTypeInfo) :-
+get_type_and_extra_args(TypeInfoParams, PseudoTypeInfo, Term,
+		FunctorDesc, ExtraArgs, ArgTypeInfo) :-
 	( 
 		typeinfo_is_variable(PseudoTypeInfo, VarNum)
 	->
-		ExpandedTypeInfo = get_type_info_for_var(TypeInfoParams,
-			VarNum, Term, FunctorDesc),
+		get_type_info_for_var(TypeInfoParams,
+			VarNum, Term, FunctorDesc, ExtraArgs, ExpandedTypeInfo),
 		( typeinfo_is_variable(ExpandedTypeInfo, _) ->
 			error("unbound type variable")
 		;
@@ -792,10 +795,9 @@
 			(pred(I::in, TI0::in, TI::out) is det :-
 
 				PTI = get_pti_from_type_info(CastTypeInfo, I),
-				ETypeInfo = get_type(
-					TypeInfoParams, PTI, Term, FunctorDesc),
-						% this comparison is not
-						% right...???
+				get_type_and_extra_args(TypeInfoParams, PTI,
+					Term, FunctorDesc, _ExtraArgs,
+					ETypeInfo),
 				( 
 					same_pointer_value_untyped(
 						ETypeInfo, PTI)
@@ -819,7 +821,8 @@
 			ArgTypeInfo = ArgTypeInfo1
 		;
 			ArgTypeInfo = CastTypeInfo
-		)
+		),
+		ExtraArgs = 0
 	).
 
 
@@ -876,16 +879,34 @@
 	%
 	% XXX existentially quantified vars are not yet handled.
 	
-:- func get_type_info_for_var(
-		type_info, int, T, du_functor_descriptor) = type_info.
+:- pred get_type_info_for_var(
+		type_info::in, int::in, T::in, du_functor_descriptor::in,
+		int::out, type_info::out) is det.
 
-get_type_info_for_var(TypeInfo, VarNum, _Term, _FunctorDesc) = ArgTypeInfo :-
+get_type_info_for_var(TypeInfo, VarNum, Term, FunctorDesc,
+			ExtraArgs, ArgTypeInfo) :-
 	(
 		type_variable_is_univ_quant(VarNum) 
 	->
-		ArgTypeInfo = TypeInfo ^ type_info_index(VarNum)
+		ArgTypeInfo = TypeInfo ^ type_info_index(VarNum),
+		ExtraArgs = 0
 	;
-		error("get_type_info_for_var for exist quant vars")
+		ExistInfo = FunctorDesc ^ functor_exist_info,
+		ExtraArgs = (ExistInfo ^ exist_info_typeinfos_plain) + 
+			(ExistInfo ^ exist_info_tcis),
+
+		ExistVarNum = VarNum - pseudotypeinfo_exist_var_base - 1,
+		ExistLocn = ExistInfo ^ typeinfo_locns_index(ExistVarNum),
+		Slot = ExistLocn ^ exist_arg_num,
+		Offset = ExistLocn ^ exist_offset_in_tci,
+		
+		SlotMaybeTypeInfo = get_typeinfo_from_term(Term, Slot),
+		( Offset < 0 ->
+			ArgTypeInfo = SlotMaybeTypeInfo
+		;
+			ArgTypeInfo = typeclass_info_type_info(
+				SlotMaybeTypeInfo, Offset)
+		)
 	).
 
 
@@ -991,7 +1012,20 @@
 		du_functor_secondary	= 5,
 		du_functor_ordinal	= 6,
 		du_functor_arg_types	= 7,
-		du_functor_exist_info	= 8
+		du_functor_arg_names	= 8,
+		du_functor_exist_info	= 9
+	}
+
+	enum exist_info_field_nums {
+		typeinfos_plain		= 0,
+		typeinfos_in_tci	= 1,
+		tcis			= 2,
+		typeinfo_locns		= 3
+	}
+
+	enum exist_locn_field_nums {
+		exist_arg_num			= 0,
+		exist_offset_in_tci		= 1
 	}
 
 ").
@@ -1066,6 +1100,10 @@
 
 :- type arg_types ---> arg_types(c_pointer).
 
+:- type exist_info ---> exist_info(c_pointer).
+
+:- type typeinfo_locn ---> typeinfo_locn(c_pointer).
+
 :- func ptag_index(int, type_layout) = ptag_entry.
 
 	% This is an "unimplemented" definition in Mercury, which will be
@@ -1140,6 +1178,106 @@
 			du_functor_field_nums.du_functor_arg_types];
 		
 ").
+
+:- func functor_exist_info(du_functor_descriptor) = exist_info.
+
+functor_exist_info(X::in) = (unsafe_cast(X)::out) :- 
+	det_unimplemented("functor_exist_info").
+
+:- pragma foreign_proc("C#",
+	functor_exist_info(FunctorDescriptor::in) = (ExistInfo::out), [], "
+	ExistInfo = (object[])
+		FunctorDescriptor[(int)
+			du_functor_field_nums.du_functor_exist_info];
+		
+").
+
+
+:- func typeinfo_locns_index(int, exist_info) = typeinfo_locn.
+
+typeinfo_locns_index(X::in, _::in) = (unsafe_cast(X)::out) :- 
+	det_unimplemented("typeinfo_locns_index").
+
+:- pragma foreign_proc("C#",
+	typeinfo_locns_index(X::in, ExistInfo::in) = (TypeInfoLocn::out), [], "
+
+	TypeInfoLocn = (object[]) ((object[]) ExistInfo[(int)
+			exist_info_field_nums.typeinfo_locns])[X];
+		
+").
+
+
+:- func exist_info_typeinfos_plain(exist_info) = int.
+
+exist_info_typeinfos_plain(X::in) = (unsafe_cast(X)::out) :- 
+	det_unimplemented("exist_info_typeinfos_plain").
+
+:- pragma foreign_proc("C#",
+	exist_info_typeinfos_plain(ExistInfo::in) = (TypeInfosPlain::out), [], "
+	TypeInfosPlain = (int)
+		ExistInfo[(int)
+			exist_info_field_nums.typeinfos_plain];
+").
+
+:- func exist_info_tcis(exist_info) = int.
+
+exist_info_tcis(X::in) = (unsafe_cast(X)::out) :- 
+	det_unimplemented("exist_info_tcis").
+
+:- pragma foreign_proc("C#",
+	exist_info_tcis(ExistInfo::in) = (TCIs::out), [], "
+	TCIs = (int) ExistInfo[(int)
+			exist_info_field_nums.tcis];
+").
+
+
+
+
+
+:- func exist_arg_num(typeinfo_locn) = int.
+
+exist_arg_num(X::in) = (unsafe_cast(X)::out) :- 
+	det_unimplemented("exist_arg_num").
+
+:- pragma foreign_proc("C#",
+	exist_arg_num(TypeInfoLocn::in) = (ArgNum::out), [], "
+	ArgNum = (int) TypeInfoLocn[(int) exist_locn_field_nums.exist_arg_num];
+		
+").
+
+:- func exist_offset_in_tci(typeinfo_locn) = int.
+
+exist_offset_in_tci(X::in) = (unsafe_cast(X)::out) :- 
+	det_unimplemented("exist_arg_num").
+
+:- pragma foreign_proc("C#",
+	exist_offset_in_tci(TypeInfoLocn::in) = (ArgNum::out), [], "
+	ArgNum = (int)
+		TypeInfoLocn[(int) exist_locn_field_nums.exist_offset_in_tci];
+		
+").
+
+:- func get_typeinfo_from_term(U, int) = type_info.
+
+get_typeinfo_from_term(_::in, X::in) = (unsafe_cast(X)::out) :- 
+	det_unimplemented("get_typeinfo_from_term").
+
+:- pragma foreign_proc("C#",
+	get_typeinfo_from_term(Term::in, Index::in) = (TypeInfo::out), [], "
+	TypeInfo = (object[]) ((object[]) Term)[Index];
+").
+
+:- func typeclass_info_type_info(type_info, int) = type_info.
+
+typeclass_info_type_info(TypeClassInfo, Index) = unsafe_cast(TypeInfo) :-
+	private_builtin__type_info_from_typeclass_info(
+		unsafe_cast(TypeClassInfo)
+			`with_type` private_builtin__typeclass_info(int),
+		Index, TypeInfo
+			`with_type` private_builtin__type_info(int)).
+
+
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%
 
@@ -1295,8 +1433,6 @@
 "
 	VarOut = VarIn;
 ").
-
-
 
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%

--------------------------------------------------------------------------
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
--------------------------------------------------------------------------