diff options
| -rw-r--r-- | frontend/typesupport.icl | 86 |
1 files changed, 63 insertions, 23 deletions
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index acf4822..e074357 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -39,6 +39,7 @@ simplifyTypeApplication (TB _) _ :: CleanUpState = { cus_var_env :: !.VarEnv , cus_attr_env :: !.AttributeEnv + , cus_appears_in_lifted_part :: !.LargeBitvect , cus_heaps :: !.TypeHeaps , cus_var_store :: !Int , cus_attr_store :: !Int @@ -49,6 +50,7 @@ simplifyTypeApplication (TB _) _ { cui_coercions :: !{! CoercionTree} , cui_attr_part :: !AttributePartition , cui_top_level :: !Bool + , cui_is_lifted_part :: !Bool } class clean_up a :: !CleanUpInput !a !*CleanUpState -> (!a, !*CleanUpState) @@ -69,7 +71,7 @@ where = (TA_Unique, cus) clean_up cui TA_Multi cus = (TA_Multi, cus) - clean_up cui tv=:(TA_TempVar av_number) cus=:{cus_attr_env,cus_heaps,cus_attr_store,cus_error} + clean_up cui tv=:(TA_TempVar av_number) cus=:{cus_attr_env,cus_appears_in_lifted_part,cus_heaps,cus_attr_store,cus_error} | cui.cui_top_level # av_group_nr = cui.cui_attr_part.[av_number] coercion_tree = cui.cui_coercions.[av_group_nr] @@ -78,12 +80,30 @@ where | isUnique coercion_tree = (TA_Unique, cus) #! attr = cus_attr_env.[av_group_nr] + # (cus_appears_in_lifted_part, cus_error) + = case cui.cui_is_lifted_part of + True + -> (cus_appears_in_lifted_part, cus_error) + _ + | bitvectSelect av_group_nr cus_appears_in_lifted_part + -> ( bitvectResetAll cus_appears_in_lifted_part // to prevent repetition of error message + , checkError "attribute variable of lifted argument appears in the specified type" "" cus_error) + -> (cus_appears_in_lifted_part, cus_error) | attrIsUndefined attr # (av_info_ptr, th_attrs) = newPtr AVI_Empty cus_heaps.th_attrs new_attr_var = TA_Var { av_name = NewAttrVarId cus_attr_store, av_info_ptr = av_info_ptr } + cus_appears_in_lifted_part + = case cui.cui_is_lifted_part of + False + -> cus_appears_in_lifted_part + _ + -> bitvectSet av_group_nr cus_appears_in_lifted_part = (new_attr_var, { cus & cus_attr_env = { cus_attr_env & [av_group_nr] = new_attr_var}, - cus_heaps = { cus_heaps & th_attrs = th_attrs }, cus_attr_store = inc cus_attr_store}) - = (attr, cus) + cus_appears_in_lifted_part = cus_appears_in_lifted_part, + cus_heaps = { cus_heaps & th_attrs = th_attrs }, cus_attr_store = inc cus_attr_store, + cus_error = cus_error}) + = (attr, { cus & cus_appears_in_lifted_part = cus_appears_in_lifted_part, + cus_error = cus_error }) = (TA_Multi, cus) clean_up cui TA_TempExVar cus = PA_BUG (TA_Multi, cus) (abort "clean_up cui (TA_TempExVar)") @@ -266,18 +286,22 @@ cleanUpSymbolType is_start_rule spec_type tst=:{tst_arity,tst_args,tst_result,ts coercions attr_part var_env attr_var_env heaps var_heap expr_heap error #! nr_of_temp_vars = size var_env #! max_attr_nr = size attr_var_env - # cus = { cus_var_env = var_env, cus_attr_env = attr_var_env, cus_heaps = heaps, - cus_var_store = 0, cus_attr_store = 0, cus_error = error } - cui = { cui_coercions = coercions, cui_attr_part = attr_part, cui_top_level = True } + # cus = { cus_var_env = var_env, cus_attr_env = attr_var_env, cus_appears_in_lifted_part = bitvectCreate max_attr_nr, + cus_heaps = heaps, cus_var_store = 0, cus_attr_store = 0, cus_error = error } + cui = { cui_coercions = coercions, cui_attr_part = attr_part, cui_top_level = True, cui_is_lifted_part = True } (lifted_args, cus=:{cus_var_env}) = clean_up cui (take tst_lifted tst_args) cus + cui = { cui & cui_is_lifted_part = False } (lifted_vars, cus_var_env) = determine_type_vars nr_of_temp_vars [] cus_var_env (st_args, cus) = clean_up cui (drop tst_lifted tst_args) { cus & cus_var_env = cus_var_env } (st_result, cus) = clean_up cui tst_result cus (st_context, cus_var_env, var_heap, cus_error) = clean_up_type_contexts spec_type tst_context derived_context cus.cus_var_env var_heap cus.cus_error (st_vars, cus_var_env) = determine_type_vars nr_of_temp_vars lifted_vars cus_var_env - (cus_attr_env, st_attr_vars, st_attr_env) = build_attribute_environment 0 max_attr_nr coercions cus.cus_attr_env [] [] + (cus_attr_env, st_attr_vars, st_attr_env, cus_error) + = build_attribute_environment cus.cus_appears_in_lifted_part 0 max_attr_nr coercions cus.cus_attr_env [] [] cus_error (expr_heap, {cus_var_env,cus_attr_env,cus_heaps,cus_error}) = update_expression_types { cui & cui_top_level = False } case_and_let_exprs - expr_heap { cus & cus_var_env = cus_var_env, cus_attr_env = cus_attr_env, cus_error = cus_error } + expr_heap { cus & cus_var_env = cus_var_env, cus_attr_env = cus_attr_env, + cus_appears_in_lifted_part = {el\\el<-:cus.cus_appears_in_lifted_part}, + cus_error = cus_error } st = { st_arity = tst_arity, st_vars = st_vars , st_args = lifted_args ++ st_args, st_result = st_result, st_context = st_context, st_attr_env = st_attr_env, st_attr_vars = st_attr_vars } cus_error = check_type_of_start_rule is_start_rule st cus_error @@ -339,32 +363,48 @@ where | otherwise = (collected_contexts, env, error) - build_attribute_environment :: !Index !Index !{! CoercionTree} !*AttributeEnv ![AttributeVar] ![AttrInequality] - -> (!*AttributeEnv, ![AttributeVar], ![AttrInequality]) - build_attribute_environment attr_group_index max_attr_nr coercions attr_env attr_vars inequalities + build_attribute_environment :: !LargeBitvect !Index !Index !{! CoercionTree} !*AttributeEnv ![AttributeVar] ![AttrInequality] !*ErrorAdmin + -> (!*AttributeEnv, ![AttributeVar], ![AttrInequality], !*ErrorAdmin) + build_attribute_environment appears_in_lifted_part attr_group_index max_attr_nr coercions attr_env attr_vars inequalities error | attr_group_index == max_attr_nr - = (attr_env, attr_vars, inequalities) + = (attr_env, attr_vars, inequalities, error) #! attr = attr_env.[attr_group_index] = case attr of TA_Var attr_var - # (attr_env, inequalities) = build_inequalities attr_var coercions.[attr_group_index] coercions attr_env inequalities - -> build_attribute_environment (inc attr_group_index) max_attr_nr coercions attr_env [attr_var : attr_vars] inequalities + # (ok, attr_env, inequalities) + = build_inequalities appears_in_lifted_part (bitvectSelect attr_group_index appears_in_lifted_part) + attr_var coercions.[attr_group_index] coercions attr_env inequalities + error + = case ok of + True + -> error + _ + -> checkError "attribute variable of lifted argument appears in derived attribute inequality" + "" error + -> build_attribute_environment appears_in_lifted_part (inc attr_group_index) max_attr_nr coercions attr_env [attr_var : attr_vars] inequalities error TA_None - -> build_attribute_environment (inc attr_group_index) max_attr_nr coercions attr_env attr_vars inequalities + -> build_attribute_environment appears_in_lifted_part (inc attr_group_index) max_attr_nr coercions attr_env attr_vars inequalities error - build_inequalities off_var (CT_Node dem_attr left right) coercions attr_env inequalities - # (attr_env, inequalities) = build_inequalities off_var left coercions attr_env inequalities - (attr_env, inequalities) = build_inequalities off_var right coercions attr_env inequalities + build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var (CT_Node dem_attr left right) + coercions attr_env inequalities + # (ok1, attr_env, inequalities) + = build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var left coercions attr_env inequalities + (ok2, attr_env, inequalities) + = build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var right coercions attr_env inequalities #! attr = attr_env.[dem_attr] = case attr of TA_Var attr_var | is_new_inequality attr_var off_var inequalities - -> (attr_env, [{ ai_demanded = attr_var, ai_offered = off_var } : inequalities]) - -> (attr_env, inequalities) + # ok3 = off_appears_in_lifted_part == bitvectSelect dem_attr appears_in_lifted_part + -> (ok1 && ok2 && ok3, attr_env, [{ ai_demanded = attr_var, ai_offered = off_var } : inequalities]) + -> (ok1 && ok2, attr_env, inequalities) TA_None - -> build_inequalities off_var coercions.[dem_attr] coercions attr_env inequalities - build_inequalities off_var tree coercions attr_env inequalities - = (attr_env, inequalities) + # (ok3, attr_env, inequalities) + = build_inequalities appears_in_lifted_part off_appears_in_lifted_part + off_var coercions.[dem_attr] coercions attr_env inequalities + -> (ok1 && ok2 && ok3, attr_env, inequalities) + build_inequalities _ _ off_var tree coercions attr_env inequalities + = (True, attr_env, inequalities) is_new_inequality dem_var off_var [] = True |