Bugfix: types in cases and lets are adjusted according to the specified type.

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@33 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

3 files changed, 83 insertions, 106 deletions

diff --git a/frontend/type.icl b/frontend/type.icl
index 7d4eb4d..8168176 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -1312,8 +1312,8 @@ where
 					= cleanUpSymbolType exp_fun_type type_contexts case_and_let_exprs coercion_env 
 										attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_expr_heap ts.ts_error
 				| ts_error.ea_ok
-					# (ts_fun_env, attr_var_env, ts_type_heaps, ts_error)
-			  			= check_function_type fun_type tmp_fun_type clean_fun_type defs ts.ts_fun_env attr_var_env ts_type_heaps ts_error
+					# (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error)
+			  			= check_function_type fun_type tmp_fun_type clean_fun_type case_and_let_exprs defs ts.ts_fun_env attr_var_env ts_type_heaps ts_expr_heap ts_error
 					-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
 					-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_error = ts_error })
 		  	UncheckedType exp_fun_type
@@ -1323,13 +1323,15 @@ where
 				  ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type }
 				-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
 
-	check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars} defs fun_env attr_var_env type_heaps error
+	check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars} case_and_let_exprs
+				defs fun_env attr_var_env type_heaps expr_heap error
 		# (equi, attr_var_env, type_heaps) = equivalent clean_fun_type tmp_fun_type defs attr_var_env type_heaps
 		| equi
 			# type_with_lifted_arg_types = addLiftedArgumentsToSymbolType fun_type tst_lifted st_args st_vars st_attr_vars
-			= ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, error)
+			  (type_heaps, expr_heap) = updateExpressionTypes clean_fun_type fun_type case_and_let_exprs type_heaps expr_heap
+			= ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, expr_heap, error)
 //					---> ("check_function_type", clean_fun_type, fun_type, type_with_lifted_arg_types)
-			= (fun_env, attr_var_env, type_heaps, specification_error clean_fun_type error)
+			= (fun_env, attr_var_env, type_heaps, expr_heap, specification_error clean_fun_type error)
 	where
 		add_lifted_arg_types arity_diff args1 args2
 			| arity_diff > 0
diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl
index b3f01ef..3a098c0 100644
--- a/frontend/typesupport.dcl
+++ b/frontend/typesupport.dcl
@@ -4,8 +4,6 @@ import checksupport, StdCompare
 
 from unitype import Coercions, CoercionTree, AttributePartition
 
-do_fusion :== False
-// MW: this switch is used to en(dis)able the fusion algorithm which currently isn't ready
 
 errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin
 
@@ -51,13 +49,9 @@ equivalent :: !SymbolType  !TempSymbolType !{# CommonDefs} !*AttributeEnv !*Type
 	,	tst_attr_env	:: ![AttrCoercion]
 	}
 
-class bind_and_unify_types a :: a a !*TypeVarHeap -> *TypeVarHeap
+updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap)
 
-instance bind_and_unify_types AType, Type, [a] | bind_and_unify_types a
-
-class substitute a :: !a !u:TypeHeaps -> (!a, !u:TypeHeaps)
+class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
 
 instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a
 instance <<< TempSymbolType
-
-is_non_variable_type :: !Type -> Bool
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index 972b76d..c4f4707 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -3,8 +3,8 @@ implementation module typesupport
 import StdEnv, StdCompare
 import syntax, parse, check, unitype, utilities, RWSDebug
 
-do_fusion :== False
-// MW: this switch is used to en(dis)able the fusion algorithm which currently isn't ready
+
+SwitchFusion x y = y
 
 ::	Store	:== Int
 
@@ -331,94 +331,70 @@ where
 		  (ct_cons_types, cus) = clean_up cui ct_cons_types cus
 		= ({ctype & ct_pattern_type = ct_pattern_type, ct_cons_types = ct_cons_types, ct_result_type = ct_result_type}, cus)
 
+/*
+	In 'bindInstances t1 t2' type variables of t1 are bound to the corresponding subtypes of t2, provided that
+	t2 is a substitution instance of t1. Binding is done by setting the 'tv_info_ptr' of the variables of t1
+	to 'TVI_Type t' were t is the subtype to which the type variable is matched.
+	Be careful with calling 'bindInstances': all the 'tv_info_ptr'-info's should be cleaned first, unless one 
+	is sure that t1 does not contain any 'tv_info_ptr' with value  'TVI_Type ...'.
 	
-class bind_and_unify_types a :: a a !*TypeVarHeap -> *TypeVarHeap
 
-instance bind_and_unify_types Type
+	instance bindInstances AType, Type, [a] | bindInstances a
+*/ 
+
+updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap)
+updateExpressionTypes {st_args,st_vars,st_result,st_attr_vars} st_copy case_and_let_exprs heaps=:{th_vars,th_attrs} expr_heap
+	# th_vars = foldSt (\{tv_info_ptr} var_heap -> var_heap <:= (tv_info_ptr, TVI_Empty)) st_vars th_vars
+	  th_attrs = foldSt (\{av_info_ptr} attr_heap -> attr_heap <:= (av_info_ptr, AVI_Empty)) st_attr_vars th_attrs
+	  th_vars = bindInstances st_args st_copy.st_args th_vars
+	  th_vars = bindInstances st_result st_copy.st_result th_vars
+	= foldSt update_expression_type case_and_let_exprs ({heaps & th_vars = th_vars, th_attrs = th_attrs}, expr_heap)
+where
+	update_expression_type expr_ptr (type_heaps, expr_heap)
+		# (info, expr_heap) = readPtr expr_ptr expr_heap
+		= case info of
+			EI_CaseType case_type
+				# (case_type, type_heaps) = substitute case_type type_heaps
+				-> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type))
+			EI_LetType let_type
+				# (let_type, type_heaps) = substitute let_type type_heaps
+				-> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type))
+
+
+class bindInstances a :: !a !a !*TypeVarHeap -> *TypeVarHeap
+
+instance bindInstances Type
   where
-	bind_and_unify_types (TV tv_1) (TV tv_2) type_var_heap
-		# (root_1, type_var_heap) = get_root tv_1 type_var_heap
-		  (root_2, type_var_heap) = get_root tv_2 type_var_heap
-		  maybe_root_tv_1 = only_tv root_1
-		  maybe_root_tv_2 = only_tv root_2
-		= case (maybe_root_tv_1, maybe_root_tv_2) of
-			(Yes root_tv_1, No)
-				-> bind_root_variable_to_type root_tv_1 root_2 type_var_heap
-			(No, Yes root_tv_2)
-				-> bind_root_variable_to_type root_tv_2 root_1 type_var_heap
-			(Yes root_tv_1, Yes root_tv_2)
-				| root_tv_1.tv_info_ptr==root_tv_2.tv_info_ptr
-					-> type_var_heap
-				-> bind_roots_together root_tv_1 root_2 type_var_heap
-			(No, No)
+	bindInstances (TV {tv_info_ptr}) type type_var_heap
+		# (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap
+		= case tv_info of
+			TVI_Type ind_type
 				-> type_var_heap
-	  where
-		bind_roots_together :: TypeVar Type *(Heap TypeVarInfo) -> .Heap TypeVarInfo;
-		bind_roots_together root_tv_1 root_type_2 type_var_heap
-			= type_var_heap <:= (root_tv_1.tv_info_ptr, TVI_Type root_type_2)
-
-	bind_and_unify_types (TV tv_1) type type_var_heap
-		| not (is_non_variable_type type)
-			= abort "compiler error in typesupport.icl: assertion failed (1)"
-		= bind_variable_to_type tv_1 type type_var_heap 
-	bind_and_unify_types type (TV tv_1) type_var_heap
-		| not (is_non_variable_type type)
-			= abort "compiler error in typesupport.icl: assertion failed (2)"
-		= bind_variable_to_type tv_1 type type_var_heap
-	bind_and_unify_types (TA _ arg_types1) (TA _ arg_types2) type_var_heap
-		= bind_and_unify_types arg_types1 arg_types2 type_var_heap
-	bind_and_unify_types (l1 --> r1) (l2 --> r2) type_var_heap
-		= bind_and_unify_types r1 r2 (bind_and_unify_types l1 l2 type_var_heap)
-	bind_and_unify_types (TB _) (TB _) type_var_heap
+			_
+				-> type_var_heap <:= (tv_info_ptr, TVI_Type type)
+	bindInstances (TA _ arg_types1) (TA _ arg_types2) type_var_heap
+		= bindInstances arg_types1 arg_types2 type_var_heap
+	bindInstances (l1 --> r1) (l2 --> r2) type_var_heap
+		= bindInstances r1 r2 (bindInstances l1 l2 type_var_heap)
+	bindInstances (TB _) (TB _) type_var_heap
 		= type_var_heap
-	bind_and_unify_types ((CV l1) :@: r1) ((CV l2) :@: r2) type_var_heap
-		= bind_and_unify_types r1 r2 (bind_and_unify_types (TV l1) (TV l2) type_var_heap)
+	bindInstances ((CV l1) :@: r1) ((CV l2) :@: r2) type_var_heap
+		= bindInstances r1 r2 (bindInstances (TV l1) (TV l2) type_var_heap)
 
-instance bind_and_unify_types [a] | bind_and_unify_types a
+instance bindInstances [a] | bindInstances a
   where
-	bind_and_unify_types [] [] type_var_heap
+	bindInstances [] [] type_var_heap
 		= type_var_heap
-	bind_and_unify_types [x:xs] [y:ys] type_var_heap
-		= bind_and_unify_types xs ys (bind_and_unify_types x y type_var_heap)
+	bindInstances [x:xs] [y:ys] type_var_heap
+		= bindInstances xs ys (bindInstances x y type_var_heap)
 	
-instance bind_and_unify_types AType
+instance bindInstances AType
   where
-	bind_and_unify_types {at_type=t1} {at_type=t2} type_var_heap
-			= bind_and_unify_types t1 t2 type_var_heap
+	bindInstances {at_type=t1} {at_type=t2} type_var_heap
+			= bindInstances t1 t2 type_var_heap
 
-only_tv :: u:Type -> Optional u:TypeVar;
-only_tv (TV tv) = Yes tv
-only_tv _ = No
-	
-is_non_variable_type :: !Type -> Bool
-is_non_variable_type (TA _ _)	= True
-is_non_variable_type (_ --> _)	= True
-is_non_variable_type (_ :@: _)	= True
-is_non_variable_type (TB _)		= True
-is_non_variable_type _			= False
-	
-bind_variable_to_type tv type type_var_heap
-	# (root, type_var_heap) = get_root tv type_var_heap
-	= case (only_tv root) of
-		(Yes tv)	-> bind_root_variable_to_type tv type type_var_heap
-		No 			-> type_var_heap
-	
-bind_root_variable_to_type {tv_info_ptr} type type_var_heap
-	= type_var_heap <:= (tv_info_ptr, TVI_Type type)
-	
-get_root :: TypeVar *(Heap TypeVarInfo) -> (Type,.Heap TypeVarInfo);
-get_root this_tv type_var_heap
-	# (tv_info, type_var_heap) = readPtr this_tv.tv_info_ptr type_var_heap
-	= case tv_info of
-		TVI_Empty
-			-> (TV this_tv, type_var_heap)
-		(TVI_Type type)
-			| is_non_variable_type type
-				 -> (type, type_var_heap)
-			-> case type of
-				(TV next_tv) -> get_root next_tv type_var_heap
 
-class substitute a :: !a !u:TypeHeaps -> (!a, !u:TypeHeaps)
+class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
 
 instance substitute AType
 where
@@ -429,18 +405,18 @@ where
 instance substitute TypeAttribute
 where
 	substitute (TA_Var {av_name, av_info_ptr}) heaps=:{th_attrs}
-/* MW: was:
-		#! av_info = sreadPtr av_info_ptr th_attrs
-		# (AVI_Attr attr) = av_info
-		= (attr, heaps)
+/* 
+	This alternative's code can be replaced with the original again, when the fusion algorithm becomes able to
+    infer correct type attributes
 */
-// XXX this alternative's code can be replaced with the original again, when the fusion algorithm becomes able to
-// infer correct type attributes
 		#! av_info = sreadPtr av_info_ptr th_attrs
 		= case av_info of
-			 (AVI_Attr attr)	-> (attr, heaps)
-			 _ | do_fusion		-> (TA_Multi, heaps)
-								-> abort "compiler bug nr 7689 in module typesupport"
+			AVI_Attr attr
+				-> (attr, heaps)
+			_
+				-> SwitchFusion
+						(TA_Multi, heaps)
+						(abort "compiler bug nr 7689 in module typesupport")
 	substitute TA_None heaps
 		= (TA_Multi, heaps)
 	substitute attr heaps
@@ -469,13 +445,15 @@ where
 		# (tc_types, heaps) = substitute tc_types heaps
 		= ({ tc & tc_types = tc_types }, heaps)
 
-substituteTypeVariable {tv_name,tv_info_ptr} heaps=:{th_vars}
-	#! tv_info = sreadPtr tv_info_ptr th_vars
+substituteTypeVariable tv=:{tv_name,tv_info_ptr} heaps=:{th_vars}
+	# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
+	  heaps = { heaps & th_vars = th_vars }
 	= case tv_info of
 		TVI_Type type
 			-> (type, heaps)
 		_
-			-> abort ("Error in substitute (Type)" ---> (tv_info, tv_name))
+			-> (TV tv, heaps)
+//			-> abort ("Error in substitute (Type)" ---> (tv_info, tv_name))
 
 instance substitute Type
 where
@@ -496,10 +474,13 @@ where
 
 instance substitute AttributeVar
 where
-	substitute {av_info_ptr} heaps=:{th_attrs}
+	substitute av=:{av_info_ptr} heaps=:{th_attrs}
 		#! av_info = sreadPtr av_info_ptr th_attrs
-		# (AVI_Attr (TA_Var attr_var)) = av_info
-		= (attr_var, heaps)
+		= case av_info of
+			AVI_Attr (TA_Var attr_var)
+				-> (attr_var, heaps)
+			_
+				-> (av, heaps)
 
 instance substitute AttrInequality
 where