add type constraints in constructors and function arguments with universal quantifier (from iTask branch)

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

1 files changed, 32 insertions, 0 deletions

diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl
index cb0120e..9f9bd10 100644
--- a/frontend/convertcases.icl
+++ b/frontend/convertcases.icl
@@ -259,6 +259,8 @@ where
 		= rs
 	weightedRefCount rci (NoBind ptr) rs
 		= rs
+	weightedRefCount rci (DictionariesFunction _ expr _) rs
+		= weightedRefCount rci expr rs
 	weightedRefCount rci (FailExpr _) rs
 		= rs
 	weightedRefCount rci expr rs
@@ -582,6 +584,9 @@ where
 		= (NoBind ptr, ds)
 	distributeLets _ (FailExpr id) ds
 		= (FailExpr id, ds)
+	distributeLets di (DictionariesFunction dictionaries expr expr_type) ds
+		# (expr,ds) = distributeLets di expr ds
+		= (DictionariesFunction dictionaries expr expr_type,ds)
 
 instance distributeLets Case
 where
@@ -1641,6 +1646,33 @@ where
 		# (failExpr, cs)
 			=	convertNonRootFail ci ident cs
 		= (failExpr, cs)
+	convertCases ci (DictionariesFunction dictionaries expr expr_type) cs
+		# (expr,cs) = convertRootCases {ci & ci_case_level=CaseLevelRoot,ci_bound_vars=dictionaries++ci.ci_bound_vars} expr cs
+	      (old_fv_info_ptr_values,var_heap) = store_VI_FreeVar_in_dictionary_vars_and_save_old_values dictionaries [] cs.cs_var_heap
+	      (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values ci.ci_bound_vars old_fv_info_ptr_values var_heap
+		  (expr, {cp_free_vars,cp_var_heap,cp_local_vars}) = copy expr {cp_free_vars=[], cp_var_heap=var_heap, cp_local_vars=[]}
+		  (bound_vars, free_typed_vars, var_heap) = retrieve_variables cp_free_vars cp_var_heap
+		  (free_typed_dictinary_vars, var_heap) = retrieve_dictionary_variables dictionaries var_heap
+		  cs = {cs & cs_var_heap = var_heap}
+		  (fun_ident,cs) = new_case_function No expr_type expr (free_typed_vars++free_typed_dictinary_vars) cp_local_vars ci.ci_group_index cs
+		  cs_var_heap = restore_old_fv_info_ptr_values old_fv_info_ptr_values (dictionaries++ci.ci_bound_vars) cs.cs_var_heap
+		= (App {app_symb=fun_ident, app_args=bound_vars, app_info_ptr=nilPtr}, {cs & cs_var_heap=cs_var_heap})
+	where
+		store_VI_FreeVar_in_dictionary_vars_and_save_old_values [({fv_info_ptr,fv_ident},type):bound_vars] old_fv_info_ptr_values var_heap
+			# (old_fv_info_ptr_value,var_heap) = readPtr fv_info_ptr var_heap
+			  (new_info_ptr,var_heap) = newPtr (VI_Labelled_Empty "convertCases [FreeVar]") var_heap
+			  var_heap = writePtr fv_info_ptr (VI_FreeVar fv_ident new_info_ptr 0 type) var_heap
+			  (old_fv_info_ptr_values,var_heap) = store_VI_FreeVar_in_dictionary_vars_and_save_old_values bound_vars old_fv_info_ptr_values var_heap
+			= ([old_fv_info_ptr_value:old_fv_info_ptr_values],var_heap)
+		store_VI_FreeVar_in_dictionary_vars_and_save_old_values [] old_fv_info_ptr_values var_heap
+			= (old_fv_info_ptr_values,var_heap)
+
+		retrieve_dictionary_variables cp_free_vars cp_var_heap
+			= foldSt retrieve_dictionary_variable cp_free_vars ([], cp_var_heap)
+		where
+			retrieve_dictionary_variable ({fv_info_ptr}, type) (free_typed_vars, var_heap)
+				# (VI_FreeVar name new_ptr count type, var_heap) = readPtr fv_info_ptr var_heap
+				= ([({fv_def_level = NotALevel, fv_ident = name, fv_info_ptr = new_ptr, fv_count = count}, type) : free_typed_vars], var_heap)
 	convertCases ci expr cs
 		= (expr, cs)