From d4e397a35be100674c23b2c863210136d5b5d35c Mon Sep 17 00:00:00 2001
From: johnvg
Date: Tue, 2 Apr 2013 15:26:26 +0000
Subject: 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
---
frontend/convertcases.icl | 32 ++++++++++++++++++++++++++++++++
1 file changed, 32 insertions(+)
(limited to 'frontend/convertcases.icl')
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)
--
cgit v1.2.3