diff options
| -rw-r--r-- | frontend/check.icl | 1 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 9 | ||||
| -rw-r--r-- | frontend/generics.icl | 4 | ||||
| -rw-r--r-- | frontend/overloading.icl | 9 | ||||
| -rw-r--r-- | frontend/refmark.icl | 18 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 4 | ||||
| -rw-r--r-- | frontend/syntax.icl | 6 | ||||
| -rw-r--r-- | frontend/trans.icl | 15 | ||||
| -rw-r--r-- | frontend/type.dcl | 5 | ||||
| -rw-r--r-- | frontend/type.icl | 785 | ||||
| -rw-r--r-- | frontend/type_io.dcl | 2 | ||||
| -rw-r--r-- | frontend/type_io.icl | 14 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 5 | ||||
| -rw-r--r-- | frontend/unitype.dcl | 6 | ||||
| -rw-r--r-- | frontend/unitype.icl | 583 |
15 files changed, 557 insertions, 909 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 3709f49..d482f23 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -1635,6 +1635,7 @@ remove_function_conversion_table main_dcl_module_n dcl_modules # dcl_modules = {dcl_modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table} -> (function_conversions,dcl_modules) +// add_function_conversion_table :: {#Int} Int *(a DclModule) -> *(a DclModule) | Array a DclModule add_function_conversion_table dcl_to_icl_function_conversions main_dcl_module_n dcl_modules # (dcl_mod,dcl_modules) = dcl_modules![main_dcl_module_n] = case dcl_mod.dcl_conversions of diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 2000dee..8688713 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -867,7 +867,8 @@ where check_context_types tc_class [] cs=:{cs_error} = { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error} check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error} - = { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error} + = cs +// = { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error} check_context_types tc_class [TV _ : types] cs = cs check_context_types tc_class [type : types] cs @@ -1141,11 +1142,11 @@ where addExistentionalTypeVariablesToSymbolTable :: !TypeAttribute ![ATypeVar] !*TypeHeaps !*CheckState -> (![ATypeVar], !(!*TypeHeaps, !*CheckState)) addExistentionalTypeVariablesToSymbolTable root_attr type_vars heaps cs - = mapSt (add_type_variable_to_symbol_table root_attr) type_vars (heaps, cs) + = mapSt (add_exi_variable_to_symbol_table root_attr) type_vars (heaps, cs) where - add_type_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState) + add_exi_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState) -> (!ATypeVar, !(!*TypeHeaps, !*CheckState)) - add_type_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} + add_exi_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} (heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error /* TD ... */, cs_x={x_type_var_position} /* ... TD */}) # tv_info = tv_name.id_info (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table diff --git a/frontend/generics.icl b/frontend/generics.icl index 9c3933c..5160b84 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -903,7 +903,7 @@ where = ([fi:fis], [fd:fds], gs) build_cons_info {ds_index,ds_arity} cons_num type_info_def_sym group_index common_defs gs - # {cons_symb, cons_arity, cons_pos} = common_defs.com_cons_defs.[ds_index] + # {cons_symb, cons_pos} = common_defs.com_cons_defs.[ds_index] # (fun_index, gs) = newFunIndex gs # def_sym = { ds_ident = makeIdent ("cons_info_" +++ cons_symb.id_name) @@ -3154,7 +3154,7 @@ copyExpr expr heaps=:{hp_var_heap, hp_expression_heap} = (expr, {heaps & hp_var_heap = us_var_heap, hp_expression_heap = us_symbol_heap}) //---> ("copy Expr") -mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st) +//mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st) mapExprSt f (App app=:{app_args}) st # (app_args, st) = mapSt (mapExprSt f) app_args st = f (App { app & app_args = app_args }) st diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 9359529..868d40d 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -506,9 +506,13 @@ where match defs (TA cons_id1 cons_args1) (TA cons_id2 cons_args2) type_heaps | cons_id1 == cons_id2 = match defs cons_args1 cons_args2 type_heaps -// # (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps + # (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps # (succ2, type2, type_heaps) = tryToExpandTypeSyn defs cons_id2 cons_args2 type_heaps + | succ1 || succ2 + = match defs type1 type2 type_heaps +/* | succ2 + = case type2 of TA cons_id2 cons_args2 | cons_id1 == cons_id2 @@ -516,6 +520,8 @@ where -> (False, type_heaps) _ -> (False, type_heaps) + +*/ = (False, type_heaps) match defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) type_heaps = match defs (arg_type1,res_type1) (arg_type2,res_type2) type_heaps @@ -928,6 +934,7 @@ where {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb,fun_pos} = fun_def (rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap) +// ---> ("determine_class_argument", st_context) error = setErrorAdmin (newPosition fun_symb fun_pos) error (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) = convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ rev_variables diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 275c915..6911fc2 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -74,7 +74,7 @@ where refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr var_expr_ptr var_heap # occ_ref_count = adjustRefCount sel var_occ.occ_ref_count var_expr_ptr - = case var_occ.occ_bind of // ---> (var_name,var_expr_ptr,occ_ref_count,var_occ.occ_ref_count) of + = case var_occ.occ_bind of // ---> ("refMarkOfVariable", var_name,occ_ref_count,var_occ.occ_ref_count) of OB_OpenLet let_expr # var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr }) -> refMark free_vars sel let_expr var_heap @@ -100,7 +100,6 @@ where = refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap) refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap | isEmpty let_lazy_binds -// MW0 # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ] : free_vars] # new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ] : free_vars] # (observing, var_heap) = binds_are_observing let_strict_binds var_heap | observing @@ -110,7 +109,6 @@ where var_heap = refMark new_free_vars sel let_expr var_heap = let_combine free_vars var_heap = refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap) -// MW0 # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars] # new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars] var_heap = foldSt bind_variable let_strict_binds var_heap var_heap = foldSt bind_variable let_lazy_binds var_heap @@ -120,7 +118,6 @@ where binds_are_observing binds var_heap = foldr bind_is_observing (True, var_heap) binds where -// MW0 bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) bind_is_observing {lb_dst={fv_info_ptr}} (observe, var_heap) # (VI_Occurrence {occ_observing}, var_heap) = readPtr fv_info_ptr var_heap = (occ_observing && observe, var_heap) @@ -134,11 +131,8 @@ where comb_ref_count = parCombineRefCount (seqCombineRefCount occ_ref_count prev_ref_count) pre_pref_recount = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count, occ_previous = occ_previouses }) -// MW0 bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap bind_variable {lb_src,lb_dst={fv_info_ptr}} var_heap # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap -// = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src }) -// MW0 = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet bind_src }) = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src }) refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap @@ -151,7 +145,9 @@ where field_number _ = NotASelector refMark free_vars sel (Update expr1 selectors expr2) var_heap - = refMark free_vars NotASelector expr2 (refMark free_vars NotASelector expr1 var_heap) + # var_heap = refMark free_vars NotASelector expr1 var_heap + var_heap = refMark free_vars NotASelector selectors var_heap + = refMark free_vars NotASelector expr2 var_heap refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap = ref_mark_of_record_expression free_vars expression expressions var_heap where @@ -203,6 +199,8 @@ instance refMark Selection where refMark free_vars _ (ArraySelection _ _ index_expr) var_heap = refMark free_vars NotASelector index_expr var_heap + refMark free_vars _ _ var_heap + = var_heap collectUsedFreeVariables free_vars var_heap = foldSt collectUsedVariables free_vars ([], var_heap) @@ -497,7 +495,6 @@ where # variables = tb_args ++ fi_local_vars (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap var_heap = refMark [tb_args] NotASelector tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap - //tb_rhs var_heap // position = newPosition fun_symb fun_pos (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap (setErrorAdmin position error) @@ -517,6 +514,7 @@ where -> (subst, type_def_infos, var_heap <:= (fv_info_ptr, VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap) +// ---> ("initial_occurrence",fv_name, fv_info_ptr, is_oberving) _ -> (subst, type_def_infos, var_heap <:= (fv_info_ptr, VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], @@ -549,7 +547,7 @@ where EI_Attribute sa_attr_nr # (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env | succ -// ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr) +// ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr, sa_attr_nr) -> (coercion_env, expr_heap, error) -> (coercion_env, expr_heap, uniquenessError (CP_Expression (FreeVar free_var)) " demanded attribute cannot be offered by shared object" error) _ diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index fcc788e..9bbdb19 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -512,7 +512,7 @@ cIsALocalVar :== False :: AP_Kind = APK_Constructor !Index | APK_Macro -:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_Occurrence !Occurrence | VI_UsedVar !Ident | +:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType | VI_Occurrence !Occurrence | VI_UsedVar !Ident | VI_Expression !Expression | VI_Variable !Ident !VarInfoPtr | VI_LiftedVariable !VarInfoPtr | VI_Count !Int /* the reference count of a variable */ !Bool /* true if the variable is global, false otherwise */ | VI_AccVar !ConsClass !ArgumentPosition /* used during fusion to determine accumulating parameters of functions */ | @@ -818,7 +818,7 @@ cNonRecursiveAppl :== False | (:@:) infixl 9 !ConsVariable ![AType] | TB !BasicType -// | TFA [ATypeVar] Type + | TFA [ATypeVar] Type /* Universally quantified types */ | GTV !TypeVar | TV !TypeVar diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 51d3bad..9bb74d3 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -497,7 +497,7 @@ cIsALocalVar :== False :: AP_Kind = APK_Constructor !Index | APK_Macro -:: VarInfo = VI_Empty |VI_Type !AType !(Optional CoercionPosition) | VI_Occurrence !Occurrence | VI_UsedVar !Ident | +:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType | VI_Occurrence !Occurrence | VI_UsedVar !Ident | VI_Expression !Expression | VI_Variable !Ident !VarInfoPtr | VI_LiftedVariable !VarInfoPtr | VI_Count !Int /* the reference count of a variable */ !Bool /* true if the variable is global, false otherwise */ | VI_AccVar !ConsClass !ArgumentPosition /* used during fusion to determine accumulating parameters of functions */ | @@ -789,7 +789,7 @@ cNotVarNumber :== -1 | (:@:) infixl 9 !ConsVariable ![AType] | TB !BasicType -// | TFA [ATypeVar] Type + | TFA [ATypeVar] Type | GTV !TypeVar | TV !TypeVar @@ -1408,7 +1408,7 @@ where instance <<< BoundVar where (<<<) file {var_name,var_info_ptr,var_expr_ptr} - = file <<< var_name <<< '<' <<< ptrToInt var_info_ptr <<< '>' + = file <<< var_name <<< "<I" <<< ptrToInt var_info_ptr <<< ", E" <<< ptrToInt var_expr_ptr <<< '>' instance <<< (Bind a b) | <<< a & <<< b where diff --git a/frontend/trans.icl b/frontend/trans.icl index 6640d02..166339c 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -1352,7 +1352,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi (_, (st_args,st_result), ti_type_heaps) = substitute (st_args,st_result) ti_type_heaps (new_fun_args, new_arg_types_array, next_attr_nr, - new_linear_bits, new_cons_args, uniqueness_requirements, subst, ti_type_heaps=:{th_vars, th_attrs}, + new_linear_bits, new_cons_args, uniqueness_requirements, subst, ti_type_heaps=:{th_vars}, ti_symbol_heap, ti_fun_defs, ti_fun_heap, ti_var_heap) = determine_args cc_linear_bits cc_args 0 prods opt_sound_function_producer_types tb_args (st_args_array st_args) @@ -1364,8 +1364,8 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi (createArray (inc (BITINDEX nr_of_all_type_vars)) 0, th_vars) // | False--->("subst before", [el\\el<-:subst], "cons_vars", [el\\el<-:cons_vars]) // = undef - # (subst, next_attr_nr, th_vars, ti_type_def_infos) - = liftSubstitution subst ro.ro_common_defs cons_vars next_attr_nr th_vars ti_type_def_infos + # (subst, next_attr_nr, ti_type_heaps=:{th_attrs}, ti_type_def_infos) + = liftSubstitution subst ro.ro_common_defs cons_vars next_attr_nr { ti_type_heaps & th_vars = th_vars } ti_type_def_infos // | False--->("subst after lifting", [el\\el<-:subst]) // = undef # coer_demanded @@ -1385,7 +1385,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi uniqueness_requirements coercions (subst, coercions, ti_type_def_infos, ti_type_heaps) = foldSt (coerce_types ro.ro_common_defs cons_vars) uniqueness_requirements - (subst, coercions, ti_type_def_infos, { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs }) + (subst, coercions, ti_type_def_infos, { ti_type_heaps & th_attrs = th_attrs }) // | False--->("cons_vars", [el\\el<-:cons_vars]) // = undef // expansion_state @@ -1883,11 +1883,14 @@ where expand_type ro_common_defs cons_vars atype (coercions, subst, ti_type_heaps, ti_type_def_infos) | is_dictionary atype ti_type_def_infos - # (atype, subst) = arraySubst atype subst +///* Sjaak */ # (atype, subst) = arraySubst atype subst + # (_, atype, subst) = arraySubst atype subst = (atype, (coercions, subst, ti_type_heaps, ti_type_def_infos)) # es = { es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos } - (btype, (subst, es)) +/* Sjaak */ + (_, btype, (subst, es)) +// (btype, (subst, es)) = expandType ro_common_defs cons_vars atype (subst, es) { es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos } = es diff --git a/frontend/type.dcl b/frontend/type.dcl index e28ff04..28d8252 100644 --- a/frontend/type.dcl +++ b/frontend/type.dcl @@ -10,6 +10,8 @@ typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !Common addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState); +tryToExpand :: !Type !TypeAttribute !{# CommonDefs} !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) + :: PropState = { prop_type_heaps :: !.TypeHeaps , prop_td_infos :: !.TypeDefInfos @@ -28,6 +30,7 @@ instance unify AType , ti_main_dcl_module_n :: !Int } -class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type}) +class arraySubst type :: !type !u:{!Type} -> (!Bool,!type, !u:{! Type}) +//class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type}) instance arraySubst AType diff --git a/frontend/type.icl b/frontend/type.icl index 8d974d5..232b2a5 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1,12 +1,10 @@ implementation module type import StdEnv -import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor +import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor // , RWSDebug import cheat, compilerSwitches import generics // AA -//import RWSDebug - :: TypeInput = { ti_common_defs :: !{# CommonDefs } , ti_functions :: !{# {# FunType }} @@ -55,351 +53,130 @@ instance toString BoundVar where toString varid = varid.var_name.id_name -class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type}) -/* -instance arraySubst AType -where - arraySubst atype=:{at_type} subst - # (at_type, subst) = arraySubst at_type subst - = ({ atype & at_type = at_type }, subst) - -instance arraySubst Type -where - arraySubst tv=:(TempV tv_number) subst - #! type = subst.[tv_number] - = case type of - TE -> (tv, subst) - _ -> arraySubst type subst - arraySubst (arg_type --> res_type) subst - # (arg_type, subst) = arraySubst arg_type subst - (res_type, subst) = arraySubst res_type subst - = (arg_type --> res_type, subst) - arraySubst (TA cons_id cons_args) subst - # (cons_args, subst) = arraySubst cons_args subst - = (TA cons_id cons_args, subst) - arraySubst (TempCV tv_number :@: types) subst - #! type = subst.[tv_number] - = case type of - TE - # (types, subst) = arraySubst types subst - -> (TempCV tv_number :@: types, subst) - _ - # (type, subst) = arraySubst type subst - (types, subst) = arraySubst types subst - -> (simplify_type_appl type types, subst) - where - simplify_type_appl :: !Type ![AType] -> Type - simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args - = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) - simplify_type_appl (cons_var :@: types) type_args - = cons_var :@: (types ++ type_args) - simplify_type_appl (TempV tv_number) type_args - = TempCV tv_number :@: type_args - simplify_type_appl (TempQV tv_number) type_args - = TempQCV tv_number :@: type_args - arraySubst type subst - = (type, subst) - -instance arraySubst [a] | arraySubst a -where - arraySubst l subst - = mapSt arraySubst l subst - -instance arraySubst TempSymbolType -where - arraySubst tst=:{tst_args,tst_result,tst_context} subst - # (tst_args, subst) = arraySubst tst_args subst - (tst_result, subst) = arraySubst tst_result subst - (tst_context, subst) = arraySubst tst_context subst - = ({tst & tst_args = tst_args,tst_result = tst_result,tst_context = tst_context}, subst) - -instance arraySubst TypeContext -where - arraySubst tc=:{tc_types} subst - # (tc_types, subst) = arraySubst tc_types subst - = ({ tc & tc_types = tc_types}, subst) - - /* - instance arraySubst OverloadedCall - where - arraySubst oc=:{oc_context} subst - # (oc_context, subst) = arraySubst oc_context subst - = ({ oc & oc_context = oc_context }, subst) - */ - -instance arraySubst CaseType -where - arraySubst ct=:{ct_pattern_type,ct_result_type,ct_cons_types} subst - # (ct_pattern_type, subst) = arraySubst ct_pattern_type subst - (ct_result_type, subst) = arraySubst ct_result_type subst - (ct_cons_types, subst) = arraySubst ct_cons_types subst - = ({ ct & ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) - -*/ +class arraySubst type :: !type !u:{!Type} -> (!Bool,!type, !u:{! Type}) instance arraySubst AType where arraySubst atype=:{at_type} subst - # (changed,at_type, subst) = arraySubst2 at_type subst + # (changed, at_type, subst) = arraySubst at_type subst | changed - = ({ atype & at_type = at_type }, subst) - = (atype, subst) + = (True, { atype & at_type = at_type }, subst) + = (False, atype, subst) instance arraySubst Type where arraySubst tv=:(TempV tv_number) subst #! type = subst.[tv_number] = case type of - TE -> (tv, subst) - _ -> arraySubst type subst - arraySubst type=:(arg_type0 --> res_type0) subst - # (changed,arg_type, subst) = arraySubst2 arg_type0 subst + TE -> (False,tv, subst) + _ + # (_, type, subst) = arraySubst type subst + -> (True, type, subst) + arraySubst type=:(arg_type --> res_type) subst + # (changed, (arg_type, res_type), subst) = arraySubst (arg_type, res_type) subst | changed - # (changed,res_type, subst) = arraySubst2 res_type0 subst - | changed - = (arg_type --> res_type, subst) - = (arg_type --> res_type0, subst) - # (changed,res_type, subst) = arraySubst2 res_type0 subst - | changed - = (arg_type0 --> res_type, subst) - = (type, subst) + = (changed, arg_type --> res_type, subst) + = (False, type, subst) arraySubst type=:(TA cons_id cons_args) subst - # (changed,cons_args, subst) = arraySubst2 cons_args subst + # (changed, cons_args, subst) = arraySubst cons_args subst | changed - = (TA cons_id cons_args, subst) - = (type, subst) + = (True, TA cons_id cons_args, subst) + = (False,type, subst) arraySubst tcv=:(TempCV tv_number :@: types) subst #! type = subst.[tv_number] = case type of TE - # (changed,types, subst) = arraySubst2 types subst + # (changed,types, subst) = arraySubst types subst | changed - -> (TempCV tv_number :@: types, subst) - -> (tcv, subst) + -> (True, TempCV tv_number :@: types, subst) + -> (False, tcv, subst) _ - # (type, subst) = arraySubst type subst - (types, subst) = arraySubst types subst - -> (simplify_type_appl type types, subst) - where - simplify_type_appl :: !Type ![AType] -> Type - simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args - = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) - simplify_type_appl (cons_var :@: types) type_args - = cons_var :@: (types ++ type_args) - simplify_type_appl (TempV tv_number) type_args - = TempCV tv_number :@: type_args - simplify_type_appl (TempQV tv_number) type_args - = TempQCV tv_number :@: type_args + # (_, (type, types), subst) = arraySubst (type, types) subst + (ok, simplified_type) = simplifyTypeApplication type types + | ok + -> (True, simplified_type, subst) + -> (False, tcv, subst) arraySubst type subst - = (type, subst) + = (False, type, subst) -instance arraySubst [a] | arraySubst2 a +instance arraySubst (a,b) | arraySubst a & arraySubst b +where + arraySubst (x,y) subst + # (changed_x, x, subst) = arraySubst x subst + (changed_y, y, subst) = arraySubst y subst + = (changed_x || changed_y, (x,y), subst) + +instance arraySubst [a] | arraySubst a where arraySubst [] subst - = ([],subst) - arraySubst t=:[type0:types0] subst - # (changed,types,subst) = arraySubst2 types0 subst + = (False, [], subst) + arraySubst t=:[type : types ] subst + # (changed, (type, types), subst) = arraySubst (type, types) subst | changed - # (changed,type,subst) = arraySubst2 type0 subst - | changed - = ([type:types],subst) - = ([type0:types],subst) - # (changed,type,subst) = arraySubst2 type0 subst - | changed - = ([type:types0],subst) - = (t,subst) + = (True, [type : types ], subst) + = (False, t, subst) instance arraySubst TempSymbolType where arraySubst tst=:{tst_args,tst_result,tst_context} subst - # (changed,tst_args, subst) = arraySubst2 tst_args subst + # (changed, (tst_args, (tst_result, tst_context)), subst) = arraySubst (tst_args, (tst_result, tst_context)) subst | changed - # (changed,tst_result, subst) = arraySubst2 tst_result subst - # (changed,tst_context, subst) = arraySubst2 tst_context subst - = ({tst & tst_args = tst_args,tst_result = tst_result,tst_context = tst_context}, subst) - # (changed,tst_result, subst) = arraySubst2 tst_result subst - | changed - # (changed,tst_context, subst) = arraySubst2 tst_context subst - = ({tst & tst_result = tst_result,tst_context = tst_context}, subst) - # (changed,tst_context, subst) = arraySubst2 tst_context subst - | changed - = ({tst & tst_context = tst_context}, subst) - = (tst, subst) + = (True, {tst & tst_args = tst_args, tst_result = tst_result, tst_context = tst_context}, subst) + = (False, tst, subst) instance arraySubst TypeContext where arraySubst tc=:{tc_types} subst - # (changed,tc_types, subst) = arraySubst2 tc_types subst - | changed - = ({ tc & tc_types = tc_types}, subst) - = ( tc, subst) - -instance arraySubst CaseType -where - arraySubst ct=:{ct_pattern_type,ct_result_type,ct_cons_types} subst - # (changed,ct_pattern_type, subst) = arraySubst2 ct_pattern_type subst - | changed - # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst - # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst - = ({ ct & ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) - # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst - | changed - # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst - = ({ ct & ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) - # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst - | changed - = ({ ct & ct_cons_types = ct_cons_types }, subst) - = (ct, subst) - -class arraySubst2 type :: !type !u:{!Type} -> (!Bool,!type, !u:{! Type}) - -instance arraySubst2 AType -where - arraySubst2 atype=:{at_type} subst - # (changed,at_type, subst) = arraySubst2 at_type subst - | changed - = (True,{ atype & at_type = at_type }, subst) - = (False,atype, subst) - -instance arraySubst2 Type -where - arraySubst2 tv=:(TempV tv_number) subst - #! type = subst.[tv_number] - = case type of - TE -> (False,tv, subst) - _ - # (t,s) = arraySubst type subst - -> (True,t,s) - arraySubst2 type=:(arg_type0 --> res_type0) subst - # (changed,arg_type, subst) = arraySubst2 arg_type0 subst - | changed - # (changed,res_type, subst) = arraySubst2 res_type0 subst - | changed - = (True,arg_type --> res_type, subst) - = (True,arg_type --> res_type0, subst) - # (changed,res_type, subst) = arraySubst2 res_type0 subst - | changed - = (True,arg_type0 --> res_type, subst) - = (False,type, subst) - arraySubst2 type=:(TA cons_id cons_args) subst - # (changed,cons_args, subst) = arraySubst2 cons_args subst - | changed - = (True,TA cons_id cons_args, subst) - = (False,type, subst) - arraySubst2 tcv=:(TempCV tv_number :@: types) subst - #! type = subst.[tv_number] - = case type of - TE - # (changed,types, subst) = arraySubst2 types subst - | changed - -> (True,TempCV tv_number :@: types, subst) - -> (False,tcv, subst) - _ - # (type, subst) = arraySubst type subst - (types, subst) = arraySubst types subst - -> (True,simplify_type_appl type types, subst) - where - simplify_type_appl :: !Type ![AType] -> Type - simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args - = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) - simplify_type_appl (cons_var :@: types) type_args - = cons_var :@: (types ++ type_args) - simplify_type_appl (TempV tv_number) type_args - = TempCV tv_number :@: type_args - simplify_type_appl (TempQV tv_number) type_args - = TempQCV tv_number :@: type_args - arraySubst2 type subst - = (False,type, subst) - -instance arraySubst2 [a] | arraySubst2 a -where - arraySubst2 [] subst - = (False,[],subst) - arraySubst2 t=:[type0:types0] subst - # (changed,types,subst) = arraySubst2 types0 subst - | changed - # (changed,type,subst) = arraySubst2 type0 subst - | changed - = (True,[type:types],subst) - = (True,[type0:types],subst) - # (changed,type,subst) = arraySubst2 type0 subst - | changed - = (True,[type:types0],subst) - = (False,t,subst) - -instance arraySubst2 TempSymbolType -where - arraySubst2 tst=:{tst_args,tst_result,tst_context} subst - # (changed,tst_args, subst) = arraySubst2 tst_args subst - | changed - # (changed,tst_result, subst) = arraySubst2 tst_result subst - # (changed,tst_context, subst) = arraySubst2 tst_context subst - = (True,{tst & tst_args = tst_args,tst_result = tst_result,tst_context = tst_context}, subst) - # (changed,tst_result, subst) = arraySubst2 tst_result subst - | changed - # (changed,tst_context, subst) = arraySubst2 tst_context subst - = (True,{tst & tst_result = tst_result,tst_context = tst_context}, subst) - # (changed,tst_context, subst) = arraySubst2 tst_context subst - | changed - = (True,{tst & tst_context = tst_context}, subst) - = (False,tst, subst) - -instance arraySubst2 TypeContext -where - arraySubst2 tc=:{tc_types} subst - # (changed,tc_types, subst) = arraySubst2 tc_types subst + # (changed, tc_types, subst) = arraySubst tc_types subst | changed = (True,{ tc & tc_types = tc_types}, subst) = (False, tc, subst) -instance arraySubst2 CaseType +instance arraySubst CaseType where - arraySubst2 ct=:{ct_pattern_type,ct_result_type,ct_cons_types} subst - # (changed,ct_pattern_type, subst) = arraySubst2 ct_pattern_type subst + arraySubst ct=:{ct_pattern_type, ct_result_type, ct_cons_types} subst + # (changed, (ct_pattern_type, (ct_result_type, ct_cons_types)), subst) = arraySubst (ct_pattern_type, (ct_result_type, ct_cons_types)) subst | changed - # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst - # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst = (True,{ ct & ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) - # (changed,ct_result_type, subst) = arraySubst2 ct_result_type subst - | changed - # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst - = (True,{ ct & ct_result_type = ct_result_type, ct_cons_types = ct_cons_types }, subst) - # (changed,ct_cons_types, subst) = arraySubst2 ct_cons_types subst - | changed - = (True,{ ct & ct_cons_types = ct_cons_types }, subst) - = (False,ct, subst) + = (False, ct, subst) -class contains_var a :: !Int !a -> Bool +class containsTypeVariable a :: !Int !a !{!Type} -> Bool -instance contains_var [a] | contains_var a +instance containsTypeVariable [a] | containsTypeVariable a where - contains_var var_id [elem:list] - = contains_var var_id elem || contains_var var_id list - contains_var var_id [] + containsTypeVariable var_id [elem:list] subst + = containsTypeVariable var_id elem subst || containsTypeVariable var_id list subst + containsTypeVariable var_id [] _ = False -instance contains_var AType +instance containsTypeVariable AType where - contains_var var_id {at_type} = contains_var var_id at_type + containsTypeVariable var_id {at_type} subst = containsTypeVariable var_id at_type subst -instance contains_var Type +instance containsTypeVariable Type where - contains_var var_id (TempV tv_number) - = var_id == tv_number - contains_var var_id (arg_type --> res_type) - = contains_var var_id arg_type || contains_var var_id res_type - contains_var var_id (TA cons_id cons_args) - = contains_var var_id cons_args - contains_var var_id (type :@: types) - = contains_var var_id type || contains_var var_id types - contains_var _ _ + containsTypeVariable var_id (TempV tv_number) subst + # type = subst.[tv_number] + | isIndirection type + = containsTypeVariable var_id type subst + = tv_number == var_id + containsTypeVariable var_id (arg_type --> res_type) subst + = containsTypeVariable var_id arg_type subst || containsTypeVariable var_id res_type subst + containsTypeVariable var_id (TA cons_id cons_args) subst + = containsTypeVariable var_id cons_args subst + containsTypeVariable var_id (type :@: types) subst + = containsTypeVariable var_id type subst || containsTypeVariable var_id types subst + containsTypeVariable _ _ _ = False -instance contains_var ConsVariable +instance containsTypeVariable ConsVariable where - contains_var var_id (TempCV tv_number) - = var_id == tv_number - contains_var var_id _ + containsTypeVariable var_id (TempCV tv_number) subst + # type = subst.[tv_number] + | isIndirection type + = containsTypeVariable var_id type subst + = tv_number == var_id + containsTypeVariable var_id _ _ = False type_error =: "Type error" @@ -447,20 +224,20 @@ tryToOptimizePosition (fun @ _) tryToOptimizePosition _ = No +isIndirection TE = False +isIndirection type = True + class unify a :: !a !a !TypeInput !*{! Type} !*TypeHeaps -> (!Bool, !*{! Type}, !*TypeHeaps) -instance unify (a, b) | unify, arraySubst a & unify, arraySubst b +instance unify (a, b) | unify a & unify b where unify (t1x, t1y) (t2x, t2y) modules subst heaps # (succ, subst, heaps) = unify t1y t2y modules subst heaps | succ - # (t1x, subst) = arraySubst t1x subst - (t2x, subst) = arraySubst t2x subst = unify t1x t2x modules subst heaps = (False, subst, heaps) -//instance unify [a] | unify, arraySubst a -instance unify [a] | unify, arraySubst, arraySubst2 a +instance unify [a] | unify a where unify [t1 : ts1] [t2 : ts2] modules subst heaps = unify (t1,ts1) (t2,ts2) modules subst heaps @@ -473,14 +250,25 @@ instance unify AType where unify t1 t2 modules subst heaps = unifyTypes t1.at_type t1.at_attribute t2.at_type t2.at_attribute modules subst heaps - unifyTypes :: !Type !TypeAttribute !Type !TypeAttribute !TypeInput !*{! Type} !*TypeHeaps -> (!Bool, !*{! Type}, !*TypeHeaps) -unifyTypes (TempV tv_number1) attr1 tv=:(TempV tv_number2) attr2 modules subst heaps - = unifyTempVarIds tv_number1 tv_number2 subst heaps -unifyTypes tv=:(TempV tv_number) attr1 type attr2 modules subst heaps - | contains_var tv_number type - = (False, subst, heaps) - = (True, { subst & [tv_number] = type}, heaps) +unifyTypes tv=:(TempV tv_number) attr1 type2 attr2 modules subst heaps + # (type1, subst) = subst![tv_number] + | isIndirection type1 + = unifyTypes type1 attr1 type2 attr2 modules subst heaps + # (succ, subst) = unify_variable_with_type tv_number type2 subst + = (succ, subst, heaps) + where + unify_variable_with_type tv_number1 tv=:(TempV tv_number2) subst + # (type2, subst) = subst![tv_number2] + | isIndirection type2 + = unify_variable_with_type tv_number type2 subst + | tv_number1 == tv_number2 + = (True, subst) + = (True, { subst & [tv_number1] = tv}) + unify_variable_with_type tv_number type subst + | containsTypeVariable tv_number type subst + = (False, subst) + = (True, { subst & [tv_number] = type}) unifyTypes type attr1 tv=:(TempV _) attr2 modules subst heaps = unifyTypes tv attr2 type attr1 modules subst heaps unifyTypes t1=:(TB tb1) attr1 t2=:(TB tb2) attr2 modules subst heaps @@ -492,17 +280,17 @@ unifyTypes (arg_type1 --> res_type1) attr1 (arg_type2 --> res_type2) attr2 modul unifyTypes t1=:(TA cons_id1 cons_args1) attr1 t2=:(TA cons_id2 cons_args2) attr2 modules subst heaps | cons_id1 == cons_id2 = unify cons_args1 cons_args2 modules subst heaps - # (succ1, t1, heaps) = tryToExpand t1 attr1 modules heaps - (succ2, t2, heaps) = tryToExpand t2 attr2 modules heaps + # (succ1, t1, heaps) = tryToExpand t1 attr1 modules.ti_common_defs heaps + (succ2, t2, heaps) = tryToExpand t2 attr2 modules.ti_common_defs heaps | succ1 || succ2 = unifyTypes t1 attr1 t2 attr2 modules subst heaps = (False, subst, heaps) unifyTypes (cons_var :@: types) attr1 type2 attr2 modules subst heaps - # (_, type2, heaps) = tryToExpand type2 attr2 modules heaps - = unifyTypeApplications cons_var types type2 modules subst heaps + # (_, type2, heaps) = tryToExpand type2 attr2 modules.ti_common_defs heaps + = unifyTypeApplications cons_var attr1 types type2 attr2 modules subst heaps unifyTypes type1 attr1 (cons_var :@: types) attr2 modules subst heaps - # (_, type1, heaps) = tryToExpand type1 attr1 modules heaps - = unifyTypeApplications cons_var types type1 modules subst heaps + # (_, type1, heaps) = tryToExpand type1 attr1 modules.ti_common_defs heaps + = unifyTypeApplications cons_var attr2 types type1 attr1 modules subst heaps unifyTypes t1=:(TempQV qv_number1) attr1 t2=:(TempQV qv_number2) attr2 modules subst heaps = (qv_number1 == qv_number2, subst, heaps) unifyTypes (TempQV qv_number) attr1 type attr2 modules subst heaps @@ -510,13 +298,14 @@ unifyTypes (TempQV qv_number) attr1 type attr2 modules subst heaps unifyTypes type attr1 (TempQV qv_number1) attr2 modules subst heaps = (False, subst, heaps) unifyTypes type1 attr1 type2 attr2 modules subst heaps - # (succ1, type1, heaps) = tryToExpand type1 attr1 modules heaps - (succ2, type2, heaps) = tryToExpand type2 attr2 modules heaps + # (succ1, type1, heaps) = tryToExpand type1 attr1 modules.ti_common_defs heaps + (succ2, type2, heaps) = tryToExpand type2 attr2 modules.ti_common_defs heaps | succ1 || succ2 = unifyTypes type1 attr1 type2 attr2 modules subst heaps = (False, subst, heaps) -tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_attr {ti_common_defs} type_heaps +tryToExpand :: !Type !TypeAttribute !{# CommonDefs} !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps) +tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_attr ti_common_defs type_heaps #! type_def = ti_common_defs.[glob_module].com_type_defs.[glob_object] = case type_def.td_rhs of SynType {at_type} @@ -527,67 +316,95 @@ tryToExpand type=:(TA {type_index={glob_object,glob_module}} type_args) type_att tryToExpand type type_attr modules type_heaps = (False, type, type_heaps) -unifyConsVariables (TempCV tv_number1) (TempCV tv_number2) subst heaps - = unifyTempVarIds tv_number1 tv_number2 subst heaps -unifyConsVariables (TempCV tv_number1) (TempQCV tv_number2) subst heaps - = (True, { subst & [tv_number1] = TempQV tv_number2}, heaps) -unifyConsVariables (TempQCV tv_number1) (TempCV tv_number2) subst heaps - = (True, { subst & [tv_number2] = TempQV tv_number1}, heaps) -unifyConsVariables (TempQCV tv_number1) (TempQCV tv_number2) subst heaps - = (tv_number1 == tv_number2, subst, heaps) - -unifyTempVarIds tv_number1 tv_number2 subst heaps - | tv_number1 == tv_number2 - = (True, subst, heaps) - = (True, { subst & [tv_number1] = TempV tv_number2}, heaps) - -constructorVariableToTypeVariable (TempCV temp_var_id) - = TempV temp_var_id -constructorVariableToTypeVariable (TempQCV temp_var_id) - = TempQV temp_var_id - -unifyTypeApplications cons_var type_args type=:(TA type_cons cons_args) modules subst heaps +toTV is_exist temp_var_id + | is_exist + = TempQV temp_var_id + = TempV temp_var_id + +toCV is_exist temp_var_id + | is_exist + = TempQCV temp_var_id + = TempCV temp_var_id + +simplifyTypeApplication :: !Type ![AType] -> (!Bool, !Type) +simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args + = (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args)) +simplifyTypeApplication (cons_var :@: types) type_args + = (True, cons_var :@: (types ++ type_args)) +simplifyTypeApplication (TempV tv_number) type_args + = (True, TempCV tv_number :@: type_args) +simplifyTypeApplication (TempQV tv_number) type_args + = (True, TempQCV tv_number :@: type_args) +simplifyTypeApplication type type_args + = (False, type) + +unifyTypeApplications (TempCV tv_number) attr1 type_args type2 attr2 modules subst heaps + # (type1, subst) = subst![tv_number] + | isIndirection type1 + # (ok, simplified_type) = simplifyTypeApplication type1 type_args + | ok + = unifyTypes simplified_type attr1 type2 attr2 modules subst heaps + = (False, subst, heaps) + = unifyCVwithType False tv_number type_args type2 modules subst heaps +unifyTypeApplications (TempQCV tv_number) attr1 type_args type2 attr2 modules subst heaps + = unifyCVwithType True tv_number type_args type2 modules subst heaps + +unifyCVwithType is_exist tv_number1 type_args1 type=:(cv :@: type_args2) modules subst heaps + = case cv of + TempCV tv_number2 + # (type2, subst) = subst![tv_number2] + | isIndirection type2 + # (ok, simplified_type) = simplifyTypeApplication type2 type_args2 + | ok + -> unifyCVwithType is_exist tv_number1 type_args1 simplified_type modules subst heaps + -> (False, subst, heaps) + -> unifyCVApplicationwithCVApplication is_exist tv_number1 type_args1 False tv_number2 type_args2 modules subst heaps + TempQCV tv_number2 + -> unifyCVApplicationwithCVApplication is_exist tv_number1 type_args1 True tv_number2 type_args2 modules subst heaps + +unifyCVwithType is_exist tv_number type_args type=:(TA type_cons cons_args) modules subst heaps # diff = type_cons.type_arity - length type_args | diff >= 0 # (succ, subst, heaps) = unify type_args (drop diff cons_args) modules subst heaps | succ - # (rest_args, subst) = arraySubst (take diff cons_args) subst - = unifyTypes (constructorVariableToTypeVariable cons_var) TA_Multi (TA { type_cons & type_arity = diff } rest_args) TA_Multi modules subst heaps + = unifyTypes (toTV is_exist tv_number) TA_Multi (TA { type_cons & type_arity = diff } (take diff cons_args)) TA_Multi modules subst heaps = (False, subst, heaps) = (False, subst, heaps) -unifyTypeApplications cons_var1 type_args type=:(cons_var2 :@: types) modules subst heaps - # arity1 = length type_args - arity2 = length types +unifyCVwithType is_exist tv_number type_args type modules subst heaps + = (False, subst, heaps) + +unifyCVApplicationwithCVApplication is_exist1 tv_number1 type_args1 is_exist2 tv_number2 type_args2 modules subst heaps + # arity1 = length type_args1 + arity2 = length type_args2 diff = arity1 - arity2 | diff == 0 - # (succ, subst, heaps) = unifyConsVariables cons_var1 cons_var2 subst heaps + # (succ, subst) = unify_cv_with_cv is_exist1 tv_number1 is_exist2 tv_number2 subst | succ - # (type_args, subst) = arraySubst type_args subst - (types, subst) = arraySubst types subst - = unify type_args types modules subst heaps + = unify type_args1 type_args2 modules subst heaps = (False, subst, heaps) | diff < 0 # diff = 0 - diff - (succ, subst, heaps) = unifyTypes (constructorVariableToTypeVariable cons_var1) TA_Multi (cons_var2 :@: take diff types) TA_Multi modules subst heaps + (succ, subst, heaps) = unifyTypes (toTV is_exist1 tv_number1) TA_Multi (toCV is_exist2 tv_number2 :@: take diff type_args2) TA_Multi modules subst heaps | succ - # (type_args, subst) = arraySubst type_args subst - (types, subst) = arraySubst (drop diff types) subst - = unify type_args types modules subst heaps + = unify type_args1 (drop diff type_args2) modules subst heaps = (False, subst, heaps) // | otherwise - # (succ, subst, heaps) = unifyTypes (cons_var1 :@: take diff type_args) TA_Multi (constructorVariableToTypeVariable cons_var2) TA_Multi modules subst heaps + # (succ, subst, heaps) = unifyTypes (toCV is_exist1 tv_number1 :@: take diff type_args1) TA_Multi (toTV is_exist2 tv_number2) TA_Multi modules subst heaps | succ - # (type_args, subst) = arraySubst (drop diff type_args) subst - (types, subst) = arraySubst types subst - = unify type_args types modules subst heaps + = unify (drop diff type_args1) type_args2 modules subst heaps = (False, subst, heaps) -unifyTypeApplications cons_var type_args type modules subst heaps - = (False, subst, heaps) - - -:: CopyState = - { copy_heaps :: !.TypeHeaps - } + where + unify_cv_with_cv is_exist1 tv_number1 is_exist2 tv_number2 subst + | tv_number1 == tv_number2 + = (True, subst) + | is_exist1 + | is_exist2 + = (False, subst) + = (True, { subst & [tv_number2] = TempQV tv_number1}) + | is_exist2 + = (True, { subst & [tv_number1] = TempQV tv_number2}) + = (True, { subst & [tv_number1] = TempV tv_number2}) + instance fromInt TypeAttribute where @@ -595,25 +412,12 @@ where fromInt AttrMulti = TA_Multi fromInt av_number = TA_TempVar av_number -class freshCopy a :: !a !*CopyState -> (!a, !*CopyState) +class freshCopy a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) instance freshCopy [a] | freshCopy a where freshCopy l ls = mapSt freshCopy l ls -/* -cDoExtendAttrEnv :== True -cDontExtendAttrEnv :== False - -freshCopies :: !Bool ![a] !{# CommonDefs } !*CopyState -> (![a], !*CopyState) | freshCopy a -freshCopies extend_env [] modules cs - = ([], [], cs) -freshCopies extend_env [t:ts] modules cs - # (t, prop, cs) = freshCopy extend_env t modules cs - (ts, props, cs) = freshCopies extend_env ts modules cs - = ([t:ts], [prop:props], cs) -*/ - freshCopyOfAttributeVar {av_name,av_info_ptr} attr_var_heap # (av_info, attr_var_heap) = readPtr av_info_ptr attr_var_heap = case av_info of @@ -642,10 +446,9 @@ freshCopyOfTypeAttribute attr attr_var_heap cIsExistential :== True cIsNotExistential :== False -freshCopyOfTypeVariable {tv_name,tv_info_ptr} cs=:{copy_heaps} - # (TVI_Type fresh_var, th_vars) = readPtr tv_info_ptr copy_heaps.th_vars -// = (fresh_var, { cs & copy_heaps.th_vars = th_vars } ) // 2.0 - = (fresh_var, { cs & copy_heaps = { copy_heaps & th_vars = th_vars }}) +freshCopyOfTypeVariable {tv_name,tv_info_ptr} type_heaps=:{th_vars} + # (TVI_Type fresh_var, th_vars) = readPtr tv_info_ptr th_vars + = (fresh_var, { type_heaps & th_vars = th_vars }) freshConsVariable {tv_info_ptr} type_var_heap # (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap @@ -658,29 +461,41 @@ freshConsVariable {tv_info_ptr} type_var_heap instance freshCopy AType where - freshCopy type=:{at_type = CV tv :@: types, at_attribute} cs=:{copy_heaps} - # (fresh_cons_var, th_vars) = freshConsVariable tv copy_heaps.th_vars - (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute copy_heaps.th_attrs - (types, cs) = freshCopy types { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars }} - = ({type & at_type = fresh_cons_var :@: types, at_attribute = fresh_attribute }, cs) - freshCopy type=:{at_type, at_attribute} cs=:{copy_heaps} - # (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute copy_heaps.th_attrs - (fresh_type, cs) = freshCopy at_type { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs }} - = ({ type & at_type = fresh_type, at_attribute = fresh_attribute }, cs) + freshCopy type=:{at_type = CV tv :@: types, at_attribute} type_heaps=:{th_vars,th_attrs} + # (fresh_cons_var, th_vars) = freshConsVariable tv th_vars + (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute th_attrs + (types, type_heaps) = freshCopy types { type_heaps & th_attrs = th_attrs, th_vars = th_vars } + = ({type & at_type = fresh_cons_var :@: types, at_attribute = fresh_attribute }, type_heaps) + freshCopy type=:{at_type, at_attribute} type_heaps=:{th_attrs} + # (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute th_attrs + (fresh_type, type_heaps) = freshCopy at_type { type_heaps & th_attrs = th_attrs } + = ({ type & at_type = fresh_type, at_attribute = fresh_attribute }, type_heaps) instance freshCopy Type where - freshCopy (TV tv) cs=:{copy_heaps} - = freshCopyOfTypeVariable tv cs - freshCopy (TA cons_id=:{type_index={glob_object,glob_module}} cons_args) cs - # (cons_args, cs) = freshCopy cons_args cs - = (TA cons_id cons_args, cs) - freshCopy (arg_type --> res_type) cs - # (arg_type, cs) = freshCopy arg_type cs - (res_type, cs) = freshCopy res_type cs - = (arg_type --> res_type, cs) - freshCopy type cs - = (type, cs) + freshCopy (TV tv) type_heaps + = freshCopyOfTypeVariable tv type_heaps + freshCopy (TA cons_id=:{type_index={glob_object,glob_module}} cons_args) type_heaps + # (cons_args, type_heaps) = freshCopy cons_args type_heaps + = (TA cons_id cons_args, type_heaps) + freshCopy (arg_type --> res_type) type_heaps + # (arg_type, type_heaps) = freshCopy arg_type type_heaps + (res_type, type_heaps) = freshCopy res_type type_heaps + = (arg_type --> res_type, type_heaps) + freshCopy (TFA vars type) type_heaps + # type_heaps = foldSt bind_var_and_attr vars type_heaps + (type, type_heaps) = freshCopy type type_heaps + = (TFA vars type, type_heaps) + where + bind_var_and_attr {atv_attribute, atv_variable = tv=:{tv_info_ptr}} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV tv)), th_attrs = bind_attr atv_attribute th_attrs } + where + bind_attr var=:(TA_Var {av_info_ptr}) attr_heap + = attr_heap <:= (av_info_ptr, AVI_Attr var) + bind_attr attr attr_heap + = attr_heap + freshCopy type type_heaps + = (type, type_heaps) freshExistentialVariables type_variables state = foldSt fresh_existential_variable type_variables state @@ -688,32 +503,38 @@ where fresh_existential_variable {atv_variable={tv_info_ptr}} (var_heap, var_store) = (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store) +freshUniversalVariables type_variables state + = foldSt fresh_universal_variable type_variables state +where + fresh_universal_variable {atv_variable={tv_info_ptr}} (var_heap, var_store) + = (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store) + freshAlgebraicType :: !(Global Int) ![AlgebraicPattern] !{#CommonDefs} !*TypeState -> (![[AType]],!AType,![AttrCoercion],!*TypeState) freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos} # {td_rhs,td_args,td_attrs,td_name,td_attribute} = common_defs.[glob_module].com_type_defs.[glob_object] # (th_vars, ts_var_store) = fresh_type_variables td_args (ts_type_heaps.th_vars, ts_var_store) (th_attrs, ts_attr_store) = fresh_attributes td_attrs (ts_type_heaps.th_attrs, ts_attr_store) - copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs } - (cons_types, alg_type, ts_var_store, attr_env, copy_heaps) - = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store copy_heaps - = (cons_types, alg_type, attr_env, { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = copy_heaps }) + type_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs } + (cons_types, alg_type, ts_var_store, attr_env, type_heaps) + = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store type_heaps + = (cons_types, alg_type, attr_env, { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = type_heaps }) // ---> ("freshAlgebraicType", alg_type, cons_types) where - fresh_symbol_types [{ap_symbol={glob_object}}] cons_defs var_store copy_heaps + fresh_symbol_types [{ap_symbol={glob_object}}] cons_defs var_store type_heaps # {cons_type = {st_args,st_attr_env,st_result}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] - (th_vars, var_store) = freshExistentialVariables cons_exi_vars (copy_heaps.th_vars, var_store) - (attr_env, th_attrs) = fresh_environment st_attr_env ([], copy_heaps.th_attrs) - (result_type, cs) = freshCopy st_result { copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars } } - (fresh_args, cs) = freshCopy st_args cs - = ([fresh_args], result_type, var_store, attr_env, cs.copy_heaps) - fresh_symbol_types [{ap_symbol={glob_object}} : patterns] cons_defs var_store copy_heaps - # (cons_types, result_type, var_store, attr_env, copy_heaps) - = fresh_symbol_types patterns cons_defs var_store copy_heaps + (th_vars, var_store) = freshExistentialVariables cons_exi_vars (type_heaps.th_vars, var_store) + (attr_env, th_attrs) = fresh_environment st_attr_env ([], type_heaps.th_attrs) + (result_type, type_heaps) = freshCopy st_result { type_heaps & th_attrs = th_attrs, th_vars = th_vars } + (fresh_args, type_heaps) = freshCopy st_args type_heaps + = ([fresh_args], result_type, var_store, attr_env, type_heaps) + fresh_symbol_types [{ap_symbol={glob_object}} : patterns] cons_defs var_store type_heaps + # (cons_types, result_type, var_store, attr_env, type_heaps) + = fresh_symbol_types patterns cons_defs var_store type_heaps {cons_type = {st_args,st_attr_env}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] - (th_vars, var_store) = freshExistentialVariables cons_exi_vars (copy_heaps.th_vars, var_store) - (attr_env, th_attrs) = fresh_environment st_attr_env (attr_env, copy_heaps.th_attrs) - (fresh_args, cs) = freshCopy st_args { copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars }} - = ([fresh_args : cons_types], result_type, var_store, attr_env, cs.copy_heaps) + (th_vars, var_store) = freshExistentialVariables cons_exi_vars (type_heaps.th_vars, var_store) + (attr_env, th_attrs) = fresh_environment st_attr_env (attr_env, type_heaps.th_attrs) + (fresh_args, type_heaps) = freshCopy st_args { type_heaps & th_attrs = th_attrs, th_vars = th_vars } + = ([fresh_args : cons_types], result_type, var_store, attr_env, type_heaps) fresh_type_variables type_variables state @@ -751,16 +572,16 @@ cWithoutFreshContextVars :== False freshSymbolType :: !Bool !SymbolType {#u:CommonDefs} !*TypeState -> (!TempSymbolType,![Int],!*TypeState) freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_env,st_arity} common_defs ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos,ts_var_heap} - # (th_vars, ts_var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store) + # (th_vars, ts_var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store) (th_attrs, ts_attr_store) = fresh_attributes st_attr_vars (ts_type_heaps.th_attrs, ts_attr_store) (attr_env, th_attrs) = freshEnvironment st_attr_env th_attrs - cs = { copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }} - (tst_args, cs) = freshCopy st_args cs - (tst_result, cs) = freshCopy st_result cs - (tst_context, ({copy_heaps}, ts_var_heap)) = freshTypeContexts fresh_context_vars st_context (cs, ts_var_heap) + type_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs } + (tst_args, type_heaps) = freshCopy st_args type_heaps + (tst_result, type_heaps) = freshCopy st_result type_heaps + (tst_context, (type_heaps, ts_var_heap)) = freshTypeContexts fresh_context_vars st_context (type_heaps, ts_var_heap) cons_variables = foldSt (collect_cons_variables_in_tc common_defs) tst_context [] = ({ tst_args = tst_args, tst_result = tst_result, tst_context = tst_context, tst_attr_env = attr_env, tst_arity = st_arity, tst_lifted = 0 }, cons_variables, - { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = copy_heaps, ts_var_heap = ts_var_heap}) + { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = type_heaps, ts_var_heap = ts_var_heap}) //---> ("freshSymbolType", st, tst_args, tst_result, tst_context) where fresh_type_variables :: .[TypeVar] *(*Heap TypeVarInfo,.Int) -> (!.Heap TypeVarInfo,!Int); @@ -815,19 +636,19 @@ freshEnvironment [] attr_heap freshTypeContexts fresh_context_vars tcs cs_and_var_heap = mapSt (fresh_type_context fresh_context_vars) tcs cs_and_var_heap where - fresh_type_context fresh_context_vars tc=:{tc_types} (cs, var_heap) - # (tc_types, cs) = mapSt fresh_context_type tc_types cs + fresh_type_context fresh_context_vars tc=:{tc_types} (type_heaps, var_heap) + # (tc_types, type_heaps) = mapSt fresh_context_type tc_types type_heaps | fresh_context_vars # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap - = ({ tc & tc_types = tc_types, tc_var = new_info_ptr }, (cs, var_heap)) - = ({ tc & tc_types = tc_types}, (cs, var_heap)) + = ({ tc & tc_types = tc_types, tc_var = new_info_ptr }, (type_heaps, var_heap)) + = ({ tc & tc_types = tc_types}, (type_heaps, var_heap)) - fresh_context_type (CV tv :@: types) cs=:{copy_heaps} - # (fresh_cons_var, th_vars) = freshConsVariable tv copy_heaps.th_vars - (types, cs) = freshCopy types { cs & copy_heaps = { copy_heaps & th_vars = th_vars }} - = (fresh_cons_var :@: types, cs) - fresh_context_type type cs - = freshCopy type cs + fresh_context_type (CV tv :@: types) type_heaps=:{th_vars} + # (fresh_cons_var, th_vars) = freshConsVariable tv th_vars + (types, type_heaps) = freshCopy types { type_heaps & th_vars = th_vars } + = (fresh_cons_var :@: types, type_heaps) + fresh_context_type type type_heaps + = freshCopy type type_heaps freshAttributedVariable :: !u:TypeState -> (!AType, !u:TypeState) freshAttributedVariable ts=:{ts_var_store,ts_attr_store} @@ -1125,12 +946,25 @@ where requirements ti {var_name,var_info_ptr,var_expr_ptr} (reqs, ts) # (var_info, ts_var_heap) = readPtr var_info_ptr ts.ts_var_heap ts = { ts & ts_var_heap = ts_var_heap } - = (case var_info of + = case var_info of VI_Type type _ - -> type - _ + -> (type, Yes var_expr_ptr, (reqs, ts)) + VI_FAType vars type + # ts = foldSt bind_var_and_attr vars ts + (type, ts_type_heaps) = freshCopy type ts.ts_type_heaps + -> (type, Yes var_expr_ptr, (reqs, { ts & ts_type_heaps = ts_type_heaps })) + _ -> abort "requirements BoundVar " // ---> (var_name <<- var_info)) - , Yes var_expr_ptr, (reqs, ts)) + where + bind_var_and_attr {atv_attribute, atv_variable = {tv_info_ptr}} ts=:{ts_var_store, ts_type_heaps} + = { ts & ts_var_store = inc ts_var_store, ts_type_heaps = + { ts_type_heaps & th_vars = ts_type_heaps.th_vars <:= (tv_info_ptr, TVI_Type (TempQV ts_var_store)), + th_attrs = bind_attr atv_attribute ts_type_heaps.th_attrs }} + where + bind_attr (TA_Var {av_info_ptr}) attr_heap + = attr_heap <:= (av_info_ptr, AVI_Attr TA_TempExVar) + bind_attr attr attr_heap + = attr_heap instance requirements App where @@ -1388,7 +1222,7 @@ where = case result_type_symb of Yes {glob_object={ds_ident,ds_index,ds_arity}, glob_module} # (var, ts) = freshAttributedVariable ts - (_,result_type, (reqs, ts)) = requirementsOfSelectors ti No expr selectors False var expr (reqs, ts) + (_, result_type, (reqs, ts)) = requirementsOfSelectors ti No expr selectors False var expr (reqs, ts) tuple_type = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity non_unique_type_var = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts.ts_var_store } req_type_coercions @@ -1399,7 +1233,7 @@ where -> (result_type, No, ({ reqs & req_type_coercions = req_type_coercions }, {ts & ts_var_store = inc ts.ts_var_store, ts_expr_heap = storeAttribute opt_expr_ptr TA_Multi ts.ts_expr_heap})) _ - # (_,result_type, reqs_ts) = requirementsOfSelectors ti No expr selectors True expr_type expr (reqs, ts) + # (_, result_type, reqs_ts) = requirementsOfSelectors ti No expr selectors True expr_type expr (reqs, ts) -> (result_type, opt_expr_ptr, reqs_ts) requirements ti (Update composite_expr selectors elem_expr) reqs_ts # (composite_expr_type, opt_composite_expr_ptr, reqs_ts) = requirements ti composite_expr reqs_ts @@ -1473,6 +1307,7 @@ where requirements _ expr reqs_ts = (abort ("Error in requirements\n" ---> expr), No, reqs_ts) + requirementsOfSelectors ti opt_expr expr [selector] tc_coercible sel_expr_type sel_expr reqs_ts = requirementsOfSelector ti opt_expr expr selector tc_coercible sel_expr_type sel_expr reqs_ts requirementsOfSelectors ti opt_expr expr [selector : selectors] tc_coercible sel_expr_type sel_expr reqs_ts @@ -1535,25 +1370,28 @@ possibly_accumulate_reqs_in_new_group position state_transition reqs_ts makeBase _ _ [] [] ts_var_heap = ts_var_heap -makeBase fun_or_cons_ident arg_nr [{fv_name, fv_info_ptr}:vars] [type:types] ts_var_heap - # optional_position = if (is_rare_name fv_name) (Yes (CP_FunArg fun_or_cons_ident arg_nr)) No - ts_var_heap = ts_var_heap <:= (fv_info_ptr, VI_Type type optional_position) - = makeBase fun_or_cons_ident (arg_nr+1) vars types ts_var_heap - +makeBase fun_or_cons_ident arg_nr [{fv_name, fv_info_ptr} : vars] [type : types] ts_var_heap + | is_rare_name fv_name + = makeBase fun_or_cons_ident (arg_nr+1) vars types (bind_type fv_info_ptr type (Yes (CP_FunArg fun_or_cons_ident arg_nr)) ts_var_heap) + = makeBase fun_or_cons_ident (arg_nr+1) vars types (bind_type fv_info_ptr type No ts_var_heap) + where + bind_type info_ptr atype=:{at_type = TFA atvs type} _ ts_var_heap + = ts_var_heap <:= (info_ptr, VI_FAType atvs { atype & at_type = type}) + bind_type info_ptr type optional_position ts_var_heap + = ts_var_heap <:= (info_ptr, VI_Type type optional_position) + attributedBasicType (BT_String string_type) ts=:{ts_attr_store} = ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = string_type}, {ts & ts_attr_store = inc ts_attr_store}) attributedBasicType bas_type ts=:{ts_attr_store} = ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = TB bas_type}, {ts & ts_attr_store = inc ts_attr_store}) unify_coercions [{tc_demanded,tc_offered,tc_position}:coercions] modules subst heaps err - # (subst, heaps, err) = unify_coercions coercions modules subst heaps err - (subst_demanded, subst) = arraySubst tc_demanded subst - (subst_offered, subst) = arraySubst tc_offered subst - (succ, subst, heaps) = unify subst_demanded subst_offered modules subst heaps + # (succ, subst, heaps) = unify tc_demanded tc_offered modules subst heaps | succ - = (subst, heaps, err) - = (subst, heaps, cannotUnify subst_demanded subst_offered tc_position err) - + = unify_coercions coercions modules subst heaps err + # (_, subst_demanded, subst) = arraySubst tc_demanded subst + (_, subst_offered, subst) = arraySubst tc_offered subst + = (subst, heaps, cannotUnify subst_demanded subst_offered tc_position err) unify_coercions [] modules subst heaps err = (subst, heaps, err) @@ -1633,12 +1471,12 @@ where # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap = case dyn_info of EI_Dynamic opt_dyn_type=:(Yes {dt_uni_vars,dt_type,dt_global_vars}) _ - # (th_vars, var_store) = fresh_existential_attributed_variables dt_uni_vars (type_heaps.th_vars, var_store) - (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store) - (tdt_type, {copy_heaps}) = freshCopy dt_type { copy_heaps = { type_heaps & th_vars = th_vars }} + # (th_vars, var_store) = fresh_existential_attributed_variables dt_uni_vars (type_heaps.th_vars, var_store) + (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store) + (tdt_type, type_heaps) = freshCopy dt_type { type_heaps & th_vars = th_vars } (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols)) - = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, copy_heaps.th_vars, predef_symbols) - -> (var_store, { copy_heaps & th_vars = type_var_heap }, var_heap, + = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, type_heaps.th_vars, predef_symbols) + -> (var_store, { type_heaps & th_vars = type_var_heap }, var_heap, expr_heap <:= (dyn_ptr, EI_TempDynamicType opt_dyn_type tdt_type contexts expr_ptr type_code_symbol), predef_symbols) EI_Dynamic No _ # fresh_var = TempV var_store @@ -1657,10 +1495,10 @@ where EI_DynamicTypeWithVars loc_type_vars dt=:{dt_type,dt_global_vars} loc_dynamics # (fresh_vars, (th_vars, var_store)) = fresh_existential_variables loc_type_vars (type_heaps.th_vars, var_store) (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store) - (tdt_type, {copy_heaps}) = freshCopy dt_type { copy_heaps = { type_heaps & th_vars = th_vars }} + (tdt_type, type_heaps) = freshCopy dt_type { type_heaps & th_vars = th_vars } (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols)) - = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, copy_heaps.th_vars, predef_symbols) - -> fresh_local_dynamics loc_dynamics (var_store, { copy_heaps & th_vars = type_var_heap }, var_heap, + = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, type_heaps.th_vars, predef_symbols) + -> fresh_local_dynamics loc_dynamics (var_store, { type_heaps & th_vars = type_var_heap }, var_heap, expr_heap <:= (dyn_ptr, EI_TempDynamicPattern loc_type_vars dt loc_dynamics fresh_vars tdt_type contexts expr_ptr type_code_symbol), predef_symbols) fresh_local_dynamics loc_dynamics state @@ -1856,9 +1694,6 @@ typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !Common -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers td_infos heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out dcl_modules -//typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule} -// -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !.TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File) -//typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out dcl_modules #! fun_env_size = size fun_defs # ts_error = {ea_file = file, ea_loc = [], ea_ok = True } @@ -2007,7 +1842,7 @@ where { ts & ts_type_heaps = ts_type_heaps, ts_error = { ts_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar}) # {ts_attr_store,ts_var_heap,ts_var_store,ts_expr_heap,ts_td_infos} = ts (cons_var_vects, subst) = determine_cons_variables cons_variables (createArray (inc (BITINDEX nr_of_type_variables)) 0, subst) - (subst, nr_of_attr_vars, th_vars, ts_td_infos) = liftSubstitution subst ti_common_defs cons_var_vects ts_attr_store ts_type_heaps.th_vars ts_td_infos + (subst, nr_of_attr_vars, ts_type_heaps, ts_td_infos) = liftSubstitution subst ti_common_defs cons_var_vects ts_attr_store ts_type_heaps ts_td_infos coer_demanded ={{ CT_Empty \\ i <- [0 .. nr_of_attr_vars - 1] } & [AttrUni] = CT_Unique } coer_offered = {{ CT_Empty \\ i <- [0 .. nr_of_attr_vars - 1] } & [AttrMulti] = CT_NonUnique } coercion_env = build_initial_coercion_env fun_reqs {coer_demanded = coer_demanded, coer_offered = coer_offered } @@ -2015,7 +1850,7 @@ where (contexts, coercion_env, local_pattern_variables, dict_types, { os_type_heaps, os_var_heap, os_symbol_heap, os_predef_symbols, os_special_instances, os_error }) = tryToSolveOverloading over_info main_dcl_module_n ti_common_defs class_instances coercion_env - { os_type_heaps = {ts_type_heaps & th_vars = th_vars}, os_var_heap = ts_var_heap, os_symbol_heap = ts_expr_heap, + { os_type_heaps = ts_type_heaps, os_var_heap = ts_var_heap, os_symbol_heap = ts_expr_heap, os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances } modules | not os_error.ea_ok = (True, fun_defs, os_predef_symbols, os_special_instances, create_erroneous_function_types comp { ts & ts_type_heaps = os_type_heaps, @@ -2169,7 +2004,7 @@ where = (calls, subst_and_heap) collect_and_expand_overloaded_calls [{ fe_context=Yes context, fe_requirements={req_overloaded_calls,req_case_and_let_exprs}, fe_location, fe_index}:reqs] calls (subst, expr_heap) - # (context, subst) = arraySubst context subst + # (_, context, subst) = arraySubst context subst subst_expr_heap = expand_case_or_let_types req_case_and_let_exprs (subst, expr_heap) = collect_and_expand_overloaded_calls reqs [(Yes context, req_overloaded_calls, fe_location, fe_index) : calls] (foldSt expand_type_contexts req_overloaded_calls subst_expr_heap) @@ -2180,8 +2015,10 @@ where expand_type_contexts over_info_ptr (subst, expr_heap) # (EI_Overloaded info, expr_heap) = readPtr over_info_ptr expr_heap - (oc_context, subst) = arraySubst info.oc_context subst - = (subst, expr_heap <:= (over_info_ptr, EI_Overloaded { info & oc_context = oc_context })) //---> oc_context + (changed, oc_context, subst) = arraySubst info.oc_context subst + | changed + = (subst, expr_heap <:= (over_info_ptr, EI_Overloaded { info & oc_context = oc_context })) + = (subst, expr_heap) expand_case_or_let_types info_ptrs subst_expr_heap = foldSt expand_case_or_let_type info_ptrs subst_expr_heap @@ -2189,21 +2026,25 @@ where expand_case_or_let_type info_ptr (subst, expr_heap) = case (readPtr info_ptr expr_heap) of (EI_CaseType case_type, expr_heap) - # (case_type, subst) = arraySubst case_type subst - -> (subst, expr_heap <:= (info_ptr, EI_CaseType case_type)) + # (changed, case_type, subst) = arraySubst case_type subst + | changed + -> (subst, expr_heap <:= (info_ptr, EI_CaseType case_type)) + -> (subst, expr_heap) (EI_LetType let_type, expr_heap) - # (let_type, subst) = arraySubst let_type subst - -> (subst, expr_heap <:= (info_ptr, EI_LetType let_type)) + # (changed, let_type, subst) = arraySubst let_type subst + | changed + -> (subst, expr_heap <:= (info_ptr, EI_LetType let_type)) + -> (subst, expr_heap) expand_function_types :: ![Int] !*{!Type} *{! FunctionType} -> (!*{!Type}, *{! FunctionType}) expand_function_types [fun : funs] subst ts_fun_env # (fun_type, ts_fun_env) = ts_fun_env![fun] = case fun_type of UncheckedType tst - # (exp_tst, subst) = arraySubst tst subst + # (_, exp_tst, subst) = arraySubst tst subst -> expand_function_types funs subst { ts_fun_env & [fun] = UncheckedType exp_tst} SpecifiedType ft _ tst - # (exp_tst, subst) = arraySubst tst subst + # (_, exp_tst, subst) = arraySubst tst subst -> expand_function_types funs subst { ts_fun_env & [fun] = ExpandedType ft tst exp_tst} expand_function_types [] subst ts_fun_env = (subst, ts_fun_env) diff --git a/frontend/type_io.dcl b/frontend/type_io.dcl index 5c92fbd..aefe9f7 100644 --- a/frontend/type_io.dcl +++ b/frontend/type_io.dcl @@ -21,7 +21,7 @@ where instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a /*2.0 -instance WriteTypeInfo String +instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b 0.2*/ //1.3 diff --git a/frontend/type_io.icl b/frontend/type_io.icl index 43bcc98..d06c040 100644 --- a/frontend/type_io.icl +++ b/frontend/type_io.icl @@ -386,18 +386,6 @@ where = write_type_info type_arity tcl_file wtis = (tcl_file,wtis) -/*2.0 -instance WriteTypeInfo String -where - write_type_info s tcl_file wtis - # tcl_file - = fwritei (size s) tcl_file - = (fwrites s tcl_file,wtis) - // warning: - // Should be identical to the code in Ident - -0.2*/ - // basic and structural write_type_info's instance WriteTypeInfo Int @@ -409,7 +397,7 @@ where instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b //3.1 /*2.0 -instance WriteTypeInfo {#b} | WriteTypeInfo b & Array {#} b +instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b 0.2*/ where write_type_info unboxed_array tcl_file wtis diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index e9b8b9d..acf4822 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -207,10 +207,6 @@ errorHeading error_kind err=:{ea_file,ea_loc = []} errorHeading error_kind err=:{ea_file,ea_loc = [ loc : _ ]} = { err & ea_file = ea_file <<< error_kind <<< ' ' <<< loc <<< ':', ea_ok = False } -overloadingError class_symb err - # err = errorHeading "Overloading error" err - = { err & ea_file = err.ea_file <<< " internal overloading of class \"" <<< class_symb <<< "\" is unsolvable\n" } - contextError class_symb err # err = errorHeading "Overloading error" err = { err & ea_file = err.ea_file <<< " unresolved class \"" <<< class_symb <<< "\" not occurring in specified type\n"} @@ -329,7 +325,6 @@ where clean_up_type_context tc=:{tc_types} (collected_contexts, env, error) # (cur, tc_types, env) = cleanUpClosed tc.tc_types env | checkCleanUpResult cur cUndefinedVar -// = ([{ tc & tc_types = tc_types } : collected_contexts], env, overloadingError tc.tc_class.glob_object.ds_ident error) = (collected_contexts, env, error) | checkCleanUpResult cur cLiftedVar = ([{ tc & tc_types = tc_types } : collected_contexts ], env, liftedContextError tc.tc_class.glob_object.ds_ident error) diff --git a/frontend/unitype.dcl b/frontend/unitype.dcl index 636d0e1..a5716d4 100644 --- a/frontend/unitype.dcl +++ b/frontend/unitype.dcl @@ -54,13 +54,15 @@ tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions) uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin -liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos) +liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeHeaps !*TypeDefInfos -> (*{! Type}, !Int, !*TypeHeaps, !*TypeDefInfos) :: ExpansionState = { es_type_heaps :: !.TypeHeaps , es_td_infos :: !.TypeDefInfos } -class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState)) +class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!Bool, !a, !*(!u:{! Type}, !*ExpansionState)) +//class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState)) + instance expandType AType diff --git a/frontend/unitype.icl b/frontend/unitype.icl index cfb0088..c8926dd 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -44,21 +44,50 @@ isPositive :: !TempVarId !{# BOOLVECT } -> Bool isPositive var_id cons_vars = cons_vars.[BITINDEX var_id] bitand (1 << BITNUMBER var_id) <> 0 + determineAttributeCoercions :: !AType !AType !Bool !u:{! Type} !*Coercions !{# CommonDefs } !{# BOOLVECT } !*TypeDefInfos !*TypeHeaps -> (!Optional (TypePosition, AType), !u:{! Type}, !*Coercions, !*TypeDefInfos, !*TypeHeaps) determineAttributeCoercions off_type dem_type coercible subst coercions defs cons_vars td_infos type_heaps - # (exp_off_type, es) = expandType defs cons_vars off_type (subst, { es_type_heaps = type_heaps, es_td_infos = td_infos}) - (exp_dem_type, (subst, {es_td_infos,es_type_heaps})) = expandType defs cons_vars dem_type es + # (_, exp_off_type, es) = expandType defs cons_vars off_type (subst, { es_type_heaps = type_heaps, es_td_infos = td_infos}) + (_, exp_dem_type, (subst, {es_td_infos,es_type_heaps})) = expandType defs cons_vars dem_type es (result, {crc_type_heaps, crc_coercions, crc_td_infos}) = coerce (if coercible PositiveSign TopSign) defs cons_vars [] exp_off_type exp_dem_type { crc_type_heaps = es_type_heaps, crc_coercions = coercions, crc_td_infos = es_td_infos} - error_info - = case result of - No - -> No - Yes pos - -> Yes (pos, exp_off_type) - = (error_info, subst, crc_coercions, crc_td_infos, crc_type_heaps) + = case result of + No + -> (No, subst, crc_coercions, crc_td_infos, crc_type_heaps) + Yes pos + -> (Yes (pos, exp_off_type), subst, crc_coercions, crc_td_infos, crc_type_heaps) + + +/* + + + = case result of + No + # (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions + format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) } + | file_to_true (stderr <:: (format, exp_off_type,No) <:: (format, exp_dem_type,No) <<< '\n') + ---> ("determineAttributeCoercions (OK)", off_type, exp_off_type, ('\n', dem_type, exp_dem_type)) + -> (No, subst, crc_coercions, crc_td_infos, crc_type_heaps) + -> undef +// -> (No, subst, crc_coercions, crc_td_infos, crc_type_heaps) + Yes pos + # (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions + format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) } + | file_to_true (stderr <:: (format, exp_off_type,No) <:: (format, exp_dem_type,No) <<< '\n') + ---> ("determineAttributeCoercions (NOK)", off_type, exp_off_type, ('\n', dem_type, exp_dem_type)) + -> (Yes (pos, exp_off_type), subst, crc_coercions, crc_td_infos, crc_type_heaps) + -> undef + +file_to_true :: !File -> Bool +file_to_true file = code { + .inline file_to_true + pop_b 2 + pushB TRUE + .end + } +*/ NotChecked :== -1 DummyAttrNumber :== -1 @@ -174,17 +203,17 @@ where :: CoercionTreeRecord = { tree :: !.CoercionTree } -liftSubstitution :: !*{! Type} !{# CommonDefs } !{# BOOLVECT } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos) -liftSubstitution subst modules cons_vars attr_store type_var_heap td_infos - # ls = { ls_next_attr = attr_store, ls_td_infos = td_infos, ls_type_var_heap = type_var_heap} +liftSubstitution :: !*{! Type} !{# CommonDefs } !{# BOOLVECT } !Int !*TypeHeaps !*TypeDefInfos -> (*{! Type}, !Int, !*TypeHeaps, !*TypeDefInfos) +liftSubstitution subst modules cons_vars attr_store type_heaps td_infos + # ls = { ls_next_attr = attr_store, ls_td_infos = td_infos, ls_type_heaps = type_heaps} = lift_substitution 0 modules cons_vars subst ls where lift_substitution var_index modules cons_vars subst ls | var_index < size subst # (type, subst) = subst![var_index] - # (type, subst, ls) = lift modules cons_vars type subst ls + # (_, type, subst, ls) = lift modules cons_vars type subst ls = lift_substitution (inc var_index) modules cons_vars { subst & [var_index] = type } ls - = (subst, ls.ls_next_attr, ls.ls_type_var_heap, ls.ls_td_infos) + = (subst, ls.ls_next_attr, ls.ls_type_heaps, ls.ls_td_infos) adjustSignClass :: !SignClassification !Int -> SignClassification adjustSignClass {sc_pos_vect,sc_neg_vect} arity @@ -195,121 +224,21 @@ adjustPropClass prop_class arity :== prop_class >> arity :: LiftState = { ls_next_attr :: !Int - , ls_type_var_heap :: !.TypeVarHeap + , ls_type_heaps :: !.TypeHeaps , ls_td_infos :: !.TypeDefInfos } liftTempTypeVariable :: !{# CommonDefs } !{# BOOLVECT } !TempVarId !*{! Type} !*LiftState - -> (!Type, !*{! Type}, !*LiftState) + -> (!Bool, !Type, !*{! Type}, !*LiftState) liftTempTypeVariable modules cons_vars tv_number subst ls #! type = subst.[tv_number] = case type of - TE -> (TempV tv_number, subst, ls) - _ -> lift modules cons_vars type subst ls - -class lift a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState -> (!a, !*{! Type}, !*LiftState) - -instance lift Type -where - lift modules cons_vars t=:(TempV tv_number) subst ls - #! type = subst.[tv_number] - = case type of - TE -> (t,subst, ls) - _ -> lift modules cons_vars type subst ls - lift modules cons_vars t=:(arg_type0 --> res_type0) subst ls - # (changed,arg_type, subst, ls) = lift2 modules cons_vars arg_type0 subst ls - | changed - # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls - | changed - = (arg_type --> res_type, subst, ls) - = (arg_type --> res_type0, subst, ls) - # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls - | changed - = (arg_type0 --> res_type, subst, ls) - = (t,subst, ls) - lift modules cons_vars t0=:(TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args) subst ls - # ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object] - # (changed,cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args tdi_kinds subst ls - | changed - # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos - | equal_type_prop type_prop type_prop0 - = (TA cons_id cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) - = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) - # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos - | equal_type_prop type_prop type_prop0 - = (t0, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) - = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) - where - lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState - -> (!Bool,![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) - lift_list modules cons_vars [] _ subst ls - = (False,[], [], [], subst, ls) - lift_list modules cons_vars ts0=:[t0:ts] [tk : tks] subst ls - # (changed,t,subst, ls) = lift2 modules cons_vars t0 subst ls - | changed - # (_,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes - = (True,[t:ts],sign_classes,prop_classes,subst,ls) - = (True,[t:ts],sign_classes,prop_classes,subst,ls) - # (changed,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls - | changed - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes - = (True,[t0:ts], sign_classes,prop_classes, subst, ls) - = (True,[t:ts], sign_classes, prop_classes, subst, ls) - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes - = (False,ts0, sign_classes, prop_classes, subst, ls) - = (False,ts0, sign_classes, prop_classes, subst, ls) - - add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes - = ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) - add_sign_and_prop_of_arrow_kind (TempV tmp_var_id) sign_classes prop_classes - | isPositive tmp_var_id cons_vars - = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) - = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) - add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes - = ([TopSignClass : sign_classes], [PropClass : prop_classes]) - lift modules cons_vars (TempCV temp_var :@: types) subst ls - # (type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls - (_,types, subst, ls) = lift_list modules cons_vars types subst ls - = case type of - TA type_cons cons_args - # nr_of_new_args = length types - -> (TA { type_cons & type_arity = type_cons.type_arity + nr_of_new_args } (cons_args ++ types), subst, ls) - TempV tv_number - -> (TempCV tv_number :@: types, subst, ls) - cons_var :@: cv_types - -> (cons_var :@: (cv_types ++ types), subst, ls) - where - lift_list :: !{#CommonDefs} !{# BOOLVECT } ![a] !*{!Type} !*LiftState -> (!Bool,![a], !*{!Type}, !*LiftState) | lift2 a - lift_list modules cons_vars [] subst ls - = (False,[], subst, ls) - lift_list modules cons_vars ts0=:[t0:ts] subst ls - # (changed,t, subst, ls) = lift2 modules cons_vars t0 subst ls - | changed - # (_,ts, subst, ls) = lift_list modules cons_vars ts subst ls - = (True,[t:ts], subst, ls) - # (changed,ts, subst, ls) = lift_list modules cons_vars ts subst ls - | changed - = (True,[t0:ts], subst, ls) - = (False,ts0, subst, ls) - lift modules cons_vars type subst ls - = (type, subst, ls) - -instance lift AType -where - lift modules cons_vars attr_type=:{at_attribute,at_type} subst ls - # (changed,at_type, subst, ls) = lift2 modules cons_vars at_type subst ls - | changed - | typeIsNonCoercible cons_vars at_type - = ({attr_type & at_type = at_type },subst, ls) - = ({attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) - | typeIsNonCoercible cons_vars at_type - = (attr_type,subst, ls) - = ({attr_type & at_attribute = TA_TempVar ls.ls_next_attr}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + TE + -> (False, TempV tv_number, subst, ls) + _ + # (_, type, subst, ls) = lift modules cons_vars type subst ls + -> (True, type, subst, ls) typeIsNonCoercible _ (TempV _) = True @@ -324,172 +253,152 @@ typeIsNonCoercible cons_vars (_ :@: _) typeIsNonCoercible _ _ = False -class lift2 a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState -> (!Bool,!a, !*{! Type}, !*LiftState) +class lift a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState -> (!Bool,!a, !*{! Type}, !*LiftState) + +liftTypeApplication modules cons_vars t0=:(TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args) subst ls + # ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object] + # (changed,cons_args, sign_classes, prop_classes, subst, ls=:{ls_type_heaps}) = lift_list modules cons_vars cons_args tdi_kinds subst ls + | changed + # (type_prop, th_vars, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls_type_heaps.th_vars ls.ls_td_infos + ls = { ls & ls_td_infos = ls_td_infos, ls_type_heaps = {ls_type_heaps & th_vars = th_vars}} + | equal_type_prop type_prop type_prop0 + = (True, TA cons_id cons_args, subst, ls) + = (True, TA { cons_id & type_prop = type_prop } cons_args, subst, ls) + # (type_prop, th_vars, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls_type_heaps.th_vars ls.ls_td_infos + ls = { ls & ls_td_infos = ls_td_infos, ls_type_heaps = {ls_type_heaps & th_vars = th_vars}} + | equal_type_prop type_prop type_prop0 + = (False, t0, subst, ls) + = (True, TA { cons_id & type_prop = type_prop } cons_args, subst, ls) + where + lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState + -> (!Bool,![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) + lift_list modules cons_vars [] _ subst ls + = (False, [], [], [], subst, ls) + lift_list modules cons_vars ts0=:[t0:ts] [tk : tks] subst ls + # (changed, t, subst, ls) = lift modules cons_vars t0 subst ls + | changed + # (_, ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (True,[t:ts],sign_classes,prop_classes,subst,ls) + = (True,[t:ts],sign_classes,prop_classes,subst,ls) + # (changed, ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls + | changed + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (True, [t0:ts], sign_classes,prop_classes, subst, ls) + = (True, [t:ts], sign_classes, prop_classes, subst, ls) + | IsArrowKind tk + # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes + = (False, ts0, sign_classes, prop_classes, subst, ls) + = (False, ts0, sign_classes, prop_classes, subst, ls) + + add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes + = ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) + add_sign_and_prop_of_arrow_kind (TempV tmp_var_id) sign_classes prop_classes + | isPositive tmp_var_id cons_vars + = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) + = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) + add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes + = ([TopSignClass : sign_classes], [PropClass : prop_classes]) +liftTypeApplication modules cons_vars type subst ls + = lift modules cons_vars type subst ls -instance lift2 Type +instance lift Type where - lift2 modules cons_vars t=:(TempV tv_number) subst ls - #! type = subst.[tv_number] - = case type of - TE -> (lift2_False,t,subst, ls) - _ # (type,subst, ls) =lift modules cons_vars type subst ls - -> (lift2_True,type,subst, ls) - lift2 modules cons_vars t=:(arg_type0 --> res_type0) subst ls - # (changed,arg_type, subst, ls) = lift2 modules cons_vars arg_type0 subst ls + lift modules cons_vars (TempV temp_var) subst ls + = liftTempTypeVariable modules cons_vars temp_var subst ls + lift modules cons_vars type=:(arg_type0 --> res_type0) subst ls + # (changed, arg_type, subst, ls) = lift modules cons_vars arg_type0 subst ls | changed - # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls + # (changed, res_type, subst, ls) = lift modules cons_vars res_type0 subst ls | changed - = (lift2_True,arg_type --> res_type, subst, ls) - = (lift2_True,arg_type --> res_type0, subst, ls) - # (changed,res_type, subst, ls) = lift2 modules cons_vars res_type0 subst ls + = (True, arg_type --> res_type, subst, ls) + = (True, arg_type --> res_type0, subst, ls) + # (changed, res_type, subst, ls) = lift modules cons_vars res_type0 subst ls | changed - = (lift2_True,arg_type0 --> res_type, subst, ls) - = (lift2_False,t,subst, ls) - lift2 modules cons_vars t0=:(TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args) subst ls - # ({tdi_kinds}, ls) = ls!ls_td_infos.[glob_module].[glob_object] - # (changed,cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args tdi_kinds subst ls - | changed - # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos - | equal_type_prop type_prop type_prop0 - = (lift2_True,TA cons_id cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) - = (lift2_True,TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) - # (type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos - | equal_type_prop type_prop type_prop0 - = (lift2_False,t0, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) - = (lift2_True,TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap}) + = (True, arg_type0 --> res_type, subst, ls) + = (False, type, subst, ls) + lift modules cons_vars type=:(TA cons_id cons_args) subst ls=:{ls_type_heaps} + # (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps + = liftTypeApplication modules cons_vars type subst {ls & ls_type_heaps = ls_type_heaps} + lift modules cons_vars type=:(TempCV temp_var :@: types) subst ls + # (changed, var_type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls + (changed_types, types, subst, ls) = lift_list modules cons_vars types subst ls + | changed || changed_types + = case var_type of + TA type_cons cons_args + -> (True, TA { type_cons & type_arity = type_cons.type_arity + length types } (cons_args ++ types), subst, ls) + TempV tv_number + -> (True, TempCV tv_number :@: types, subst, ls) + cons_var :@: cv_types + -> (True, cons_var :@: (cv_types ++ types), subst, ls) + = (False, type, subst, ls) where - lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !*{!Type} !*LiftState - -> (!Bool,![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) - lift_list modules cons_vars [] _ subst ls - = (False,[], [], [], subst, ls) - lift_list modules cons_vars ts0=:[t0:ts] [tk : tks] subst ls - # (changed,t,subst, ls) = lift2 modules cons_vars t0 subst ls - | changed - # (_,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes - = (True,[t:ts],sign_classes,prop_classes,subst,ls) - = (True,[t:ts],sign_classes,prop_classes,subst,ls) - # (changed,ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts tks subst ls - | changed - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes - = (True,[t0:ts], sign_classes,prop_classes, subst, ls) - = (True,[t:ts], sign_classes, prop_classes, subst, ls) - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes - = (False,ts0, sign_classes, prop_classes, subst, ls) - = (False,ts0, sign_classes, prop_classes, subst, ls) - - add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes - = ([adjustSignClass type_prop.tsp_sign type_arity : sign_classes], [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) - add_sign_and_prop_of_arrow_kind (TempV tmp_var_id) sign_classes prop_classes - | isPositive tmp_var_id cons_vars - = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) - = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) - add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes - = ([TopSignClass : sign_classes], [PropClass : prop_classes]) - lift2 modules cons_vars (TempCV temp_var :@: types) subst ls - # (type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls - (_,types, subst, ls) = lift_list modules cons_vars types subst ls - = case type of - TA type_cons cons_args - # nr_of_new_args = length types - -> (lift2_True,TA { type_cons & type_arity = type_cons.type_arity + nr_of_new_args } (cons_args ++ types), subst, ls) - TempV tv_number - -> (lift2_True,TempCV tv_number :@: types, subst, ls) - cons_var :@: cv_types - -> (lift2_True,cons_var :@: (cv_types ++ types), subst, ls) - where - lift_list :: !{#CommonDefs} !{# BOOLVECT } ![a] !*{!Type} !*LiftState -> (!Bool,![a], !*{!Type}, !*LiftState) | lift2 a + lift_list :: !{#CommonDefs} !{# BOOLVECT } ![a] !*{!Type} !*LiftState -> (!Bool,![a], !*{!Type}, !*LiftState) | lift a lift_list modules cons_vars [] subst ls - = (False,[], subst, ls) + = (False, [], subst, ls) lift_list modules cons_vars ts0=:[t0:ts] subst ls - # (changed,t, subst, ls) = lift2 modules cons_vars t0 subst ls + # (changed,t, subst, ls) = lift modules cons_vars t0 subst ls | changed - # (_,ts, subst, ls) = lift_list modules cons_vars ts subst ls + # (_, ts, subst, ls) = lift_list modules cons_vars ts subst ls = (True,[t:ts], subst, ls) - # (changed,ts, subst, ls) = lift_list modules cons_vars ts subst ls + # (changed, ts, subst, ls) = lift_list modules cons_vars ts subst ls | changed - = (True,[t0:ts], subst, ls) - = (False,ts0, subst, ls) - lift2 modules cons_vars type subst ls - = (lift2_False,type, subst, ls) - -lift2_True :== True -lift2_False :== False + = (True, [t0:ts], subst, ls) + = (False, ts0, subst, ls) + lift modules cons_vars type subst ls + = (False, type, subst, ls) -instance lift2 AType +instance lift AType where - lift2 modules cons_vars attr_type=:{at_attribute,at_type} subst ls - # (changed,at_type, subst, ls) = lift2 modules cons_vars at_type subst ls + lift modules cons_vars attr_type=:{at_attribute,at_type} subst ls + # (changed, at_type, subst, ls) = lift modules cons_vars at_type subst ls | changed | typeIsNonCoercible cons_vars at_type - = (True,{attr_type & at_type = at_type },subst, ls) - = (True,{attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + = (True, {attr_type & at_type = at_type },subst, ls) + = (True, {attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) | typeIsNonCoercible cons_vars at_type - = (False,attr_type,subst, ls) - = (True,{attr_type & at_attribute = TA_TempVar ls.ls_next_attr}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) + = (False, attr_type,subst, ls) + = (True, {attr_type & at_attribute = TA_TempVar ls.ls_next_attr}, subst, {ls & ls_next_attr = inc ls.ls_next_attr}) :: ExpansionState = { es_type_heaps :: !.TypeHeaps , es_td_infos :: !.TypeDefInfos } -class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState)) +class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!Bool,!a, !*(!u:{! Type}, !*ExpansionState)) instance expandType AType where expandType modules cons_vars attr_type=:{at_type, at_attribute} (subst, es=:{es_type_heaps}) - # (changed,at_attribute, th_attrs) = expand_attribute at_attribute es_type_heaps.th_attrs + # (changed, at_attribute, th_attrs) = expand_attribute at_attribute es_type_heaps.th_attrs | changed - # (at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) - = ({ attr_type & at_type = at_type, at_attribute = at_attribute }, subst_and_es) - # (changed,at_type, subst_and_es) = expandType2 modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) + # (_, at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) + = (True, { attr_type & at_type = at_type, at_attribute = at_attribute }, subst_and_es) + # (changed, at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) | changed - = ({ attr_type & at_type = at_type }, subst_and_es) - = (attr_type, subst_and_es) + = (True, { attr_type & at_type = at_type }, subst_and_es) + = (False, attr_type, subst_and_es) where expand_attribute :: TypeAttribute *(Heap AttrVarInfo) -> (!.Bool,TypeAttribute,!.Heap AttrVarInfo); expand_attribute (TA_Var {av_name,av_info_ptr}) attr_var_heap = case (readPtr av_info_ptr attr_var_heap) of (AVI_Attr attr, attr_var_heap) - -> (True,attr, attr_var_heap) + -> (True, attr, attr_var_heap) (info, attr_var_heap) -> abort ("expand_attribute (unitype.icl)" )//---> (av_name <<- info )) expand_attribute attr attr_var_heap - = (False,attr, attr_var_heap) - -class expandType2 a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!Bool,!a, !*(!u:{! Type}, !*ExpansionState)) - -instance expandType2 AType -where - expandType2 modules cons_vars attr_type=:{at_type, at_attribute} (subst, es=:{es_type_heaps}) - # (changed,at_attribute, th_attrs) = expand_attribute at_attribute es_type_heaps.th_attrs - | changed - # (at_type, subst_and_es) = expandType modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) - = (True,{ attr_type & at_type = at_type, at_attribute = at_attribute }, subst_and_es) - # (changed,at_type, subst_and_es) = expandType2 modules cons_vars at_type (subst, {es & es_type_heaps = { es_type_heaps & th_attrs = th_attrs }}) - | changed - = (True,{ attr_type & at_type = at_type }, subst_and_es) - = (False,attr_type, subst_and_es) - where - expand_attribute :: TypeAttribute *(Heap AttrVarInfo) -> (!.Bool,TypeAttribute,!.Heap AttrVarInfo); - expand_attribute (TA_Var {av_name,av_info_ptr}) attr_var_heap - = case (readPtr av_info_ptr attr_var_heap) of - (AVI_Attr attr, attr_var_heap) - -> (True,attr, attr_var_heap) - (info, attr_var_heap) - -> abort ("expand_attribute (unitype.icl)" )//---> (av_name <<- info )) - expand_attribute attr attr_var_heap - = (False,attr, attr_var_heap) + = (False, attr, attr_var_heap) -expandTempTypeVariable :: !TempVarId !*(!u:{! Type}, !*ExpansionState) -> (!Type, !*(!u:{! Type}, !*ExpansionState)) +expandTempTypeVariable :: !TempVarId !*(!u:{! Type}, !*ExpansionState) -> (!Bool, !Type, !*(!u:{! Type}, !*ExpansionState)) expandTempTypeVariable tv_number (subst, es) #! type = subst.[tv_number] = case type of - TE -> (TempV tv_number, (subst, es)) - _ -> (type, (subst, es)) + TE + -> (False, TempV tv_number, (subst, es)) + _ + -> (True, type, (subst, es)) IsArrowKind (KindArrow _) = True IsArrowKind _ = False @@ -497,41 +406,39 @@ IsArrowKind _ = False equal_type_prop {tsp_sign=sign0,tsp_propagation=prop0,tsp_coercible=coerc0} {tsp_sign=sign1,tsp_propagation=prop1,tsp_coercible=coerc1} = prop0==prop1 && coerc0==coerc1 && sign0.sc_pos_vect==sign1.sc_pos_vect && sign0.sc_neg_vect==sign1.sc_neg_vect - instance expandType Type where - expandType modules cons_vars t0=:(TempV tv_number) est=:(subst,es) - #! type = subst.[tv_number] - = case type of - TE -> (t0, est) - _ -> (type, est) + expandType modules cons_vars (TempV tv_number) est + = expandTempTypeVariable tv_number est expandType modules cons_vars (TV {tv_info_ptr}) (subst, es=:{es_type_heaps}) # (TVI_Type type, th_vars) = readPtr tv_info_ptr es_type_heaps.th_vars - = (type, (subst, {es & es_type_heaps = { es_type_heaps & th_vars = th_vars }})) + = (True,type, (subst, {es & es_type_heaps = { es_type_heaps & th_vars = th_vars }})) expandType modules cons_vars t0=:(arg_type0 --> res_type0) es - # (changed,arg_type, es) = expandType2 modules cons_vars arg_type0 es + # (changed,arg_type, es) = expandType modules cons_vars arg_type0 es | changed - # (res_type, es) = expandType modules cons_vars res_type0 es - = (arg_type --> res_type, es) - # (changed,res_type, es) = expandType2 modules cons_vars res_type0 es + # (changed,res_type, es) = expandType modules cons_vars res_type0 es | changed - = (arg_type0 --> res_type, es) - = (t0, es) + = (True,arg_type --> res_type, es) + = (True,arg_type --> res_type0, es) + # (changed,res_type, es) = expandType modules cons_vars res_type0 es + | changed + = (True,arg_type0 --> res_type, es) + = (False,t0, es) expandType modules cons_vars t0=:(TA cons_id=:{type_name, type_index={glob_object,glob_module},type_prop=type_prop0} cons_args) (subst, es) # ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object] (changed,cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es) | changed # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos | equal_type_prop type_prop type_prop0 - = (TA cons_id cons_args, + = (True,TA cons_id cons_args, (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) - = (TA { cons_id & type_prop = type_prop } cons_args, + = (True,TA { cons_id & type_prop = type_prop } cons_args, (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos | equal_type_prop type_prop type_prop0 - = (t0, + = (False,t0, (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) - = (TA { cons_id & type_prop = type_prop } cons_args, + = (True,TA { cons_id & type_prop = type_prop } cons_args, (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) where expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState) @@ -539,7 +446,7 @@ where expand_type_list modules cons_vars [] _ es = (False,[], [], [], es) expand_type_list modules cons_vars ts0=:[t0:ts] [tk : tks] es - # (changed,t, es) = expandType2 modules cons_vars t0 es + # (changed,t, es) = expandType modules cons_vars t0 es | changed # (_,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es | IsArrowKind tk @@ -566,134 +473,36 @@ where add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes = ([TopSignClass : sign_classes], [PropClass : prop_classes]) - expandType modules cons_vars (TempCV temp_var :@: types) es - # (type, es) = expandTempTypeVariable temp_var es - (types, es) = expandType modules cons_vars types es - = case type of - TA type_cons=:{type_arity} cons_args - # nr_of_new_args = length types - -> (TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es) - TempV tv_number - -> (TempCV tv_number :@: types, es) - cons_var :@: cv_types - -> (cons_var :@: (cv_types ++ types), es) + expandType modules cons_vars type=:(TempCV temp_var :@: types) es + # (changed_type, var_type, es) = expandTempTypeVariable temp_var es + (changed_types, types, es) = expandType modules cons_vars types es + | changed_type || changed_types + = case var_type of + TA type_cons=:{type_arity} cons_args + # nr_of_new_args = length types + -> (True, TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es) + TempV tv_number + -> (True, TempCV tv_number :@: types, es) + cons_var :@: cv_types + -> (True, cons_var :@: (cv_types ++ types), es) + = (False, type, es) expandType modules cons_vars type es - = (type, es) - -instance expandType [a] | expandType,expandType2 a -where - expandType modules cons_vars [] es - = ([],es) - expandType modules cons_vars types0=:[type0:types] es - # (changed,type,es) = expandType2 modules cons_vars type0 es - | changed - # (types,es) = expandType modules cons_vars types es - = ([type:types],es) - # (changed,types,es) = expandType2 modules cons_vars types es - | changed - = ([type0:types],es) - = (types0,es) - -instance expandType2 Type -where - expandType2 modules cons_vars t0=:(TempV tv_number) est=:(subst,es) - #! type = subst.[tv_number] - = case type of - TE -> (False,t0, est) - _ -> (True,type, est) - expandType2 modules cons_vars (TV {tv_info_ptr}) (subst, es=:{es_type_heaps}) - # (TVI_Type type, th_vars) = readPtr tv_info_ptr es_type_heaps.th_vars - = (True,type, (subst, {es & es_type_heaps = { es_type_heaps & th_vars = th_vars }})) - expandType2 modules cons_vars t0=:(arg_type0 --> res_type0) es - # (changed,arg_type, es) = expandType2 modules cons_vars arg_type0 es - | changed - # (changed,res_type, es) = expandType2 modules cons_vars res_type0 es - | changed - = (AexpandType2_True,arg_type --> res_type, es) - = (AexpandType2_True,arg_type --> res_type0, es) - # (changed,res_type, es) = expandType2 modules cons_vars res_type0 es - | changed - = (AexpandType2_True,arg_type0 --> res_type, es) - = (AexpandType2_False,t0, es) - expandType2 modules cons_vars t0=:(TA cons_id=:{type_name, type_index={glob_object,glob_module},type_prop=type_prop0} cons_args) (subst, es) - # ({tdi_kinds}, es) = es!es_td_infos.[glob_module].[glob_object] - (changed,cons_args, hio_signs, hio_props, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args tdi_kinds (subst, es) - | changed - # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos - | equal_type_prop type_prop type_prop0 - = (AexpandType2_True,TA cons_id cons_args, - (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) - = (AexpandType2_True,TA { cons_id & type_prop = type_prop } cons_args, - (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) - # (type_prop, th_vars, es_td_infos) = typeProperties glob_object glob_module hio_signs hio_props modules es_type_heaps.th_vars es_td_infos - | equal_type_prop type_prop type_prop0 - = (AexpandType2_False,t0, - (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) - = (AexpandType2_True,TA { cons_id & type_prop = type_prop } cons_args, - (subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }})) - where - expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] ![TypeKind] !(!u:{!Type}, !*ExpansionState) - -> (!Bool,![AType], ![SignClassification], ![PropClassification], !(!u:{!Type}, !*ExpansionState)) - expand_type_list modules cons_vars [] _ es - = (False,[], [], [], es) - expand_type_list modules cons_vars ts0=:[t0:ts] [tk : tks] es - # (changed,t, es) = expandType2 modules cons_vars t0 es - | changed - # (_,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; - = (True,[t:ts], sign_classes, prop_classes, es) - = (True,[t:ts], sign_classes, prop_classes, es) - # (changed,ts, sign_classes, prop_classes, es) = expand_type_list modules cons_vars ts tks es - | changed - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; - = (True,[t0:ts], sign_classes, prop_classes, es) - = (True,[t0:ts], sign_classes, prop_classes, es) - | IsArrowKind tk - # (sign_classes,prop_classes) = add_sign_and_prop_of_arrow_kind t.at_type sign_classes prop_classes; - = (False,ts0, sign_classes, prop_classes, es) - = (False,ts0, sign_classes, prop_classes, es) + = (False, type, es) - add_sign_and_prop_of_arrow_kind (TA {type_arity,type_prop} _) sign_classes prop_classes - =([adjustSignClass type_prop.tsp_sign type_arity : sign_classes],[adjustPropClass type_prop.tsp_propagation type_arity : prop_classes]) - add_sign_and_prop_of_arrow_kind ( TempV tmp_var_id) sign_classes prop_classes - | isPositive tmp_var_id cons_vars - = ([PostiveSignClass : sign_classes], [PropClass : prop_classes]) - = ([TopSignClass : sign_classes], [NoPropClass : prop_classes]) - add_sign_and_prop_of_arrow_kind _ sign_classes prop_classes - = ([TopSignClass : sign_classes], [PropClass : prop_classes]) - expandType2 modules cons_vars (TempCV temp_var :@: types) es - # (type, es) = expandTempTypeVariable temp_var es - (types, es) = expandType modules cons_vars types es - = case type of - TA type_cons=:{type_arity} cons_args - # nr_of_new_args = length types - -> (AexpandType2_True,TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es) - TempV tv_number - -> (AexpandType2_True,TempCV tv_number :@: types, es) - cons_var :@: cv_types - -> (AexpandType2_True,cons_var :@: (cv_types ++ types), es) - expandType2 modules cons_vars type es - = (False,type, es) - -AexpandType2_False :== False -AexpandType2_True :== True - -instance expandType2 [a] | expandType,expandType2 a +instance expandType [a] | expandType a where - expandType2 modules cons_vars [] es + expandType modules cons_vars [] es = (False,[],es) - expandType2 modules cons_vars types0=:[type0:types] es - # (changed,type,es) = expandType2 modules cons_vars type0 es + expandType modules cons_vars types0=:[type0:types] es + # (changed, type, es) = expandType modules cons_vars type0 es | changed - # (types,es) = expandType modules cons_vars types es - = (True,[type:types],es) - # (changed,types,es) = expandType2 modules cons_vars types es + # (_, types, es) = expandType modules cons_vars types es + = (True, [type:types], es) + # (changed, types, es) = expandType modules cons_vars types es | changed - = (True,[type0:types],es) - = (False,types0,es) + = (True, [type0:types], es) + = (False, types0, es) instance toInt TypeAttribute @@ -959,7 +768,7 @@ tryToExpandTypeSyn defs cons_vars cons_id=:{type_index={glob_object,glob_module} = case td_rhs of SynType {at_type} # type_heaps = bindTypeVarsAndAttributes td_attribute attribute td_args type_args type_heaps - (expanded_type, (_, {es_type_heaps, es_td_infos})) = expandType defs cons_vars at_type + (_, expanded_type, (_, {es_type_heaps, es_td_infos})) = expandType defs cons_vars at_type ({}, { es_type_heaps = type_heaps, es_td_infos = td_infos }) -> (True, expanded_type, clearBindingsOfTypeVarsAndAttributes attribute td_args es_type_heaps, es_td_infos) _ |