diff options
| -rw-r--r-- | frontend/comparedefimp.icl | 17 | ||||
| -rw-r--r-- | frontend/type.icl | 13 |
2 files changed, 30 insertions, 0 deletions
diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 6b918c1..2bc1140 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -231,6 +231,23 @@ where = compare dclDef iclDef comp_st compare (TV dclVar) (TV iclVar) comp_st = compare dclVar iclVar comp_st + compare (TFA dclvars dcltype) (TFA iclvars icltype) comp_st=:{comp_type_var_heap} + # comp_type_var_heap = initialyseATypeVars dclvars iclvars comp_type_var_heap + (ok, comp_st) = compare dcltype icltype { comp_st & comp_type_var_heap = comp_type_var_heap } + type_heaps = foldSt clear_type_var dclvars (comp_st.comp_type_var_heap, comp_st.comp_attr_var_heap) + (comp_type_var_heap, comp_attr_var_heap) = foldSt clear_type_var iclvars type_heaps + = (ok, { comp_st & comp_type_var_heap = comp_type_var_heap, comp_attr_var_heap = comp_attr_var_heap }) + where + clear_type_var {atv_variable={tv_info_ptr}, atv_attribute} (type_var_heap,attr_var_heap) + = (type_var_heap <:= (tv_info_ptr, TVI_Empty), clear_attr_var atv_attribute attr_var_heap) + + clear_attr_var (TA_Var {av_info_ptr}) attr_var_heap + = attr_var_heap <:= (av_info_ptr, AVI_Empty) + clear_attr_var (TA_RootVar {av_info_ptr}) attr_var_heap + = attr_var_heap <:= (av_info_ptr, AVI_Empty) + clear_attr_var attr attr_var_heap + = attr_var_heap + compare _ _ comp_st = (False, comp_st) diff --git a/frontend/type.icl b/frontend/type.icl index 6542eb4..3355444 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -805,6 +805,7 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con ts_cons_variables = cons_variables ++ ts_cons_variables, ts_exis_variables = ts_exis_variables }) //---> ("freshSymbolType", st, tst_args, tst_result, tst_context) where + fresh_type_variables :: [TypeVar] !(!*TypeVarHeap, !Int) -> (!*TypeVarHeap, !Int) fresh_type_variables type_variables state = foldSt fresh_type_variable type_variables state @@ -1168,6 +1169,7 @@ standardRhsConstructorType pos index mod arity {ti_common_defs} ts cons_type = { ct & st_vars = st_vars, st_attr_vars = st_attr_vars } (fresh_type, ts) = freshSymbolType (Yes pos) cWithFreshContextVars cons_type ti_common_defs ts = currySymbolType fresh_type arity ts +// ---> ("standardRhsConstructorType", fresh_type) where add_vars_and_attr {atv_variable, atv_attribute} (type_variables, attr_variables) = ([ atv_variable : type_variables ], add_attr_var atv_attribute attr_variables) @@ -1280,7 +1282,9 @@ where VI_FAType vars type _ # ts = foldSt bind_var_and_attr vars ts (fresh_type, ts_type_heaps) = freshCopy type ts.ts_type_heaps + ts_type_heaps = foldSt clear_var_and_attr vars ts_type_heaps -> (fresh_type, Yes var_expr_ptr, (reqs, { ts & ts_type_heaps = ts_type_heaps })) + ---> ("requirements [BoundVar]", fresh_type) _ -> abort "requirements BoundVar " // ---> (var_ident <<- var_info)) where @@ -1294,6 +1298,15 @@ where = (inc attr_store, attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store))) bind_attr attr attr_heap = attr_heap + + clear_var_and_attr {atv_attribute, atv_variable = {tv_info_ptr}} th=:{th_vars,th_attrs} + # th_attrs = clear_attr atv_attribute th_attrs + = { th & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = th_attrs } + where + clear_attr (TA_Var {av_info_ptr}) attr_heap + = attr_heap <:= (av_info_ptr, AVI_Empty) + clear_attr attr attr_heap + = attr_heap instance requirements App where |