diff options
| -rw-r--r-- | frontend/Heap.dcl | 2 | ||||
| -rw-r--r-- | frontend/analtypes.icl | 29 | ||||
| -rw-r--r-- | frontend/analunitypes.icl | 4 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 10 | ||||
| -rw-r--r-- | frontend/classify.icl | 11 | ||||
| -rw-r--r-- | frontend/hashtable.dcl | 2 | ||||
| -rw-r--r-- | frontend/overloading.icl | 35 | ||||
| -rw-r--r-- | frontend/postparse.icl | 2 | ||||
| -rw-r--r-- | frontend/refmark.icl | 64 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 2 | ||||
| -rw-r--r-- | frontend/trans.icl | 21 | ||||
| -rw-r--r-- | frontend/transform.icl | 3 | ||||
| -rw-r--r-- | frontend/type.icl | 20 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 23 |
15 files changed, 140 insertions, 90 deletions
diff --git a/frontend/Heap.dcl b/frontend/Heap.dcl index dbee0db..b6f3329 100644 --- a/frontend/Heap.dcl +++ b/frontend/Heap.dcl @@ -3,7 +3,7 @@ definition module Heap import StdClass :: Heap v = {heap::!.HeapN v} -:: HeapN v +:: .HeapN v :: Ptr v = {pointer::!.(PtrN v)}; :: PtrN v = Ptr !v !(HeapN v); diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 23fd2b3..bff03d7 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -374,16 +374,17 @@ where analTypes_for_TA :: Ident Int Int Int [AType] !Bool !{#CommonDefs} ![KindInfoPtr] !Conditions !*AnalyseState -> (!KindInfo, !TypeProperties, !(!Conditions, !*AnalyseState)) analTypes_for_TA type_name glob_module glob_object type_arity types has_root_attr modules form_tvs conds as - # form_type_arity = modules.[glob_module].com_type_defs.[glob_object].td_arity + # {td_arity, td_name} = modules.[glob_module].com_type_defs.[glob_object] ({tdi_kinds, tdi_properties}, as) = as!as_td_infos.[glob_module].[glob_object] - | type_arity <= form_type_arity + | type_arity <= td_arity # kind = kindArrowToKindInfo (drop type_arity tdi_kinds) | tdi_properties bitand cIsAnalysed == 0 # (type_properties, conds_as) = anal_types_of_rec_type_cons modules form_tvs types tdi_kinds (conds, as) = (kind, type_properties, conds_as) # (type_properties, conds_as) = anal_types_of_type_cons modules form_tvs types tdi_kinds (conds, as) -// = (kind, type_properties, conds_as) - = (kind, addHyperstrictness type_properties tdi_properties, conds_as) + new_properties = condCombineTypeProperties has_root_attr type_properties tdi_properties + = (kind, new_properties, conds_as) +// ---> ("analTypes_for_TA", td_name, type_properties, tdi_properties, new_properties, has_root_attr) = (KI_Const, tdi_properties, (conds, { as & as_error = checkError type_name type_appl_error as.as_error })) where anal_types_of_rec_type_cons modules form_tvs [] _ conds_as @@ -517,6 +518,7 @@ where (combineTypeProperties cv_props other_type_props) (combineCoercionProperties cv_props other_type_props) = (cons_props, (conds, { as & as_kind_heap = uki_kind_heap, as_error = uki_error })) +// ---> ("anal_types_of_cons", type) analTypesOfConstructor _ _ [] conds_as = (cIsHyperStrict, conds_as) @@ -535,6 +537,7 @@ where # (kind_info_ptr, kind_heap) = newPtr KI_Const kind_heap = (KindVar kind_info_ptr, (type_var_heap <:= (tv_info_ptr, TVI_TypeKind kind_info_ptr), kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr))) + analyseTypeDefs :: !{#CommonDefs} !TypeGroups !{#CheckedTypeDef} !Int !*TypeDefInfos !*TypeVarHeap !*ErrorAdmin -> (!*TypeDefInfos, !*TypeVarHeap, !*ErrorAdmin) analyseTypeDefs modules groups dcl_types dcl_mod_index type_def_infos type_var_heap error @@ -552,7 +555,7 @@ where (kinds_in_group, (as_kind_heap, as_td_infos)) = mapSt determine_kinds group (as.as_kind_heap, as.as_td_infos) as_kind_heap = unify_var_binds conds.con_var_binds as_kind_heap (normalized_top_vars, (kind_var_store, as_kind_heap)) = normalize_top_vars conds.con_top_var_binds 0 as_kind_heap - (as_kind_heap, as_td_infos) = update_type_def_infos type_properties normalized_top_vars group + (as_kind_heap, as_td_infos) = update_type_def_infos modules type_properties normalized_top_vars group kinds_in_group kind_var_store as_kind_heap as_td_infos as = { as & as_kind_heap = as_kind_heap, as_td_infos = as_td_infos } as = foldSt (check_dcl_properties modules dcl_types dcl_mod_index type_properties) group as @@ -644,19 +647,21 @@ where # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) - update_type_def_infos type_properties top_vars group updated_kinds_of_group kind_store kind_heap td_infos - # (_, as_kind_heap, as_td_infos) = fold2St (update_type_def_info (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group (kind_store, kind_heap, td_infos) + update_type_def_infos modules type_properties top_vars group updated_kinds_of_group kind_store kind_heap td_infos + # (_, as_kind_heap, as_td_infos) = fold2St (update_type_def_info modules (type_properties bitor cIsAnalysed) top_vars) group updated_kinds_of_group (kind_store, kind_heap, td_infos) = (as_kind_heap, as_td_infos) where - update_type_def_info type_properties top_vars {gi_module,gi_index} updated_kinds + update_type_def_info modules type_properties top_vars {gi_module,gi_index} updated_kinds (kind_store, kind_heap, td_infos) - # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index] +// # {com_type_defs} = modules.[gi_module] +// {td_name} = com_type_defs.[gi_index] + # (td_info=:{tdi_kinds}, td_infos) = td_infos![gi_module].[gi_index] // ---> ("update_type_def_info", td_name, type_properties) # (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info tdi_kinds updated_kinds top_vars kind_store kind_heap = (kind_store, kind_heap, { td_infos & [gi_module,gi_index] = {td_info & tdi_properties = type_properties, tdi_kinds = updated_kinds, tdi_group_vars = group_vars, tdi_cons_vars = cons_vars }}) determine_type_def_info [ KindVar kind_info_ptr : kind_vars ] [ kind : kinds ] top_vars kind_store kind_heap - #! kind_info = sreadPtr kind_info_ptr kind_heap + # (kind_info, kind_heap) = readPtr kind_info_ptr kind_heap # (var_number, (kind_store, kind_heap)) = nomalize_var kind_info_ptr kind_info (kind_store, kind_heap) (group_vars, cons_vars, kind_store, kind_heap) = determine_type_def_info kind_vars kinds top_vars kind_store kind_heap = case kind of @@ -684,7 +689,7 @@ where // ---> ("check_coercibility", td_name, spec_properties, properties) |check_hyperstrictness spec_properties properties | spec_properties bitand cIsNonCoercible == 0 - # (as_type_var_heap, as_td_infos, as_error) = check_possitive_sign gi_module gi_index modules td_args as.as_type_var_heap as.as_td_infos as_error + # (as_type_var_heap, as_td_infos, as_error) = check_positive_sign gi_module gi_index modules td_args as.as_type_var_heap as.as_td_infos as_error = {as & as_type_var_heap = as_type_var_heap, as_td_infos = as_td_infos, as_error = popErrorAdmin as_error} = {as & as_error = popErrorAdmin as_error} # as_error = checkError "abstract type as defined in the implementation module is not hyperstrict" "" as_error @@ -701,7 +706,7 @@ where check_hyperstrictness dcl_props icl_props = dcl_props bitand cIsHyperStrict == 0 || icl_props bitand cIsHyperStrict > 0 - check_possitive_sign mod_index type_index modules td_args type_var_heap type_def_infos error + check_positive_sign mod_index type_index modules td_args type_var_heap type_def_infos error # top_signs = [ TopSignClass \\ _ <- td_args ] # (signs, type_var_heap, type_def_infos) = signClassification type_index mod_index top_signs modules type_var_heap type_def_infos | signs.sc_neg_vect == 0 diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index 68567b5..ab0b524 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -243,7 +243,7 @@ signClassOfType_for_TA glob_module glob_object types sign use_top_sign group_nr # (td_info=:{tdi_group_nr,tdi_index_in_group,tdi_kinds}, scs) = scs!scs_type_def_infos.[glob_module].[glob_object] | tdi_group_nr == group_nr = sign_class_of_type_list_of_rec_type types sign use_top_sign tdi_index_in_group ci [] scs - # {td_arity} = ci.[glob_module].com_type_defs.[glob_object] + # {td_arity,td_name} = ci.[glob_module].com_type_defs.[glob_object] (sign_classes, hio_signs, scs) = collect_sign_classes_of_type_list types tdi_kinds group_nr ci scs (type_class, scs_type_var_heap, scs_type_def_infos) = determineSignClassOfTypeDef glob_object glob_module td_info hio_signs ci scs.scs_type_var_heap scs.scs_type_def_infos @@ -266,6 +266,8 @@ where = collect_sign_classes_of_type_list ts tks group_nr ci scs collect_sign_classes_of_type_list [] _ _ ci scs = ([], [], scs) + collect_sign_classes_of_type_list _ _ _ ci scs + = abort "collect_sign_classes_of_type_list (analunitypes)" determine_cummulative_sign [t : ts] [tk : tks] sign use_top_sign sign_class sign_classes type_index ci cumm_class scs | IsArrowKind tk diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 0825905..27a1d77 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -38,7 +38,8 @@ where check_type_attribute :: !TypeAttribute !TypeAttribute !TypeAttribute !*ErrorAdmin -> (!TypeAttribute,!*ErrorAdmin) check_type_attribute TA_Anonymous type_attr root_attr error | try_to_combine_attributes type_attr root_attr - = (root_attr, error) + = (to_root_attr root_attr, error) +// = (root_attr, error) = (TA_Multi, checkError "conflicting attribution of type definition" "" error) check_type_attribute TA_Unique type_attr root_attr error | try_to_combine_attributes TA_Unique type_attr || try_to_combine_attributes TA_Unique root_attr @@ -69,7 +70,12 @@ where = checkError var "uniqueness attribute not allowed" error check_attr_of_type_var attr _ error = error - + + to_root_attr (TA_Var var) + = TA_RootVar var + to_root_attr attr + = attr + instance bindTypes TypeVar where bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table}) diff --git a/frontend/classify.icl b/frontend/classify.icl index 5f25e53..c5d5f36 100644 --- a/frontend/classify.icl +++ b/frontend/classify.icl @@ -277,8 +277,8 @@ instance consumerRequirements App where | glob_module == main_dcl_module_n | glob_object < size ai_cons_class - #! fun_class = ai_cons_class.[glob_object] - = reqs_of_args fun_class.cc_args app_args CPassive common_defs ai + # (fun_class, ai_cons_class) = ai_cons_class![glob_object] + = reqs_of_args fun_class.cc_args app_args CPassive common_defs { ai & ai_cons_class = ai_cons_class } = consumerRequirements app_args common_defs ai | glob_module == stdStrictLists_module_n && (not (isEmpty app_args)) @@ -323,8 +323,8 @@ instance consumerRequirements App where common_defs=:(ConsumerAnalysisRO {main_dcl_module_n}) ai=:{ai_cons_class} | glob_object < size ai_cons_class - #! fun_class = ai_cons_class.[glob_object] - = reqs_of_args fun_class.cc_args app_args CPassive common_defs ai + # (fun_class, ai_cons_class) = ai_cons_class![glob_object] + = reqs_of_args fun_class.cc_args app_args CPassive common_defs { ai & ai_cons_class = ai_cons_class } = consumerRequirements app_args common_defs ai // new alternative for generated function + reanalysis... @@ -356,10 +356,11 @@ reqs_of_args [form_cc : ccs] [arg : args] cumm_arg_class common_defs ai = reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs ai reqs_of_args cc xp _ _ _ = abort "classify:reqs_of_args doesn't match" ---> (cc,xp) +/* showRefCount :: !String !*AnalyseInfo -> *AnalyseInfo showRefCount msg ai=:{ai_cur_ref_counts} = ai <--- (msg,display ai_cur_ref_counts) - +*/ display :: !RefCounts -> String display rc = {show c \\ c <-: rc} where diff --git a/frontend/hashtable.dcl b/frontend/hashtable.dcl index 801117f..433f270 100644 --- a/frontend/hashtable.dcl +++ b/frontend/hashtable.dcl @@ -2,7 +2,7 @@ definition module hashtable import syntax -:: HashTableEntry +:: .HashTableEntry :: HashTable = { hte_symbol_heap :: !.SymbolTable diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 5e4fd75..e5b4b61 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -161,7 +161,9 @@ where try_to_reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error | context_is_reducible tc predef_symbols = reduce_any_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error +// ---> ("try_to_reduce_context (Yes)", tc) | containsContext tc new_contexts +// ---> ("try_to_reduce_context (No)", tc) = (CA_Context tc, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error) # (var_heap, type_heaps) = heaps (tc_var, var_heap) = newPtr VI_Empty var_heap @@ -355,16 +357,15 @@ where -> (False, coercion_env) context_is_reducible {tc_class=TCClass class_symb,tc_types = [type : types]} predef_symbols -// = type_is_reducible type && is_reducible types - = type_is_reducible type && types_are_reducible types type class_symb predef_symbols + = type_is_reducible type class_symb predef_symbols && types_are_reducible types type class_symb predef_symbols context_is_reducible tc=:{tc_class=TCGeneric {gtc_class}, tc_types = [type : types]} predef_symbols - = type_is_reducible type && types_are_reducible types type gtc_class predef_symbols + = type_is_reducible type gtc_class predef_symbols && types_are_reducible types type gtc_class predef_symbols - type_is_reducible (TempV _) + type_is_reducible (TempV _) tc_class predef_symbols + = False // is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_TypeCodeClass predef_symbols + type_is_reducible (_ :@: _) tc_class predef_symbols = False - type_is_reducible (_ :@: _) - = False - type_is_reducible _ + type_is_reducible _ tc_class predef_symbols = True types_are_reducible [] _ _ _ @@ -376,8 +377,7 @@ where _ :@: _ -> is_lazy_or_strict_array_or_list_context _ - -> is_reducible types - + -> is_reducible types tc_class predef_symbols where is_lazy_or_strict_array_or_list_context => (is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_ArrayClass predef_symbols && @@ -402,10 +402,11 @@ where is_lazy_or_strict_list_type _ _ = False - is_reducible [] - = True - is_reducible [ type : types] - = type_is_reducible type && is_reducible types + is_reducible [] tc_class predef_symbols + = True + is_reducible [ type : types] tc_class predef_symbols + = type_is_reducible type tc_class predef_symbols && is_reducible types tc_class predef_symbols + fresh_contexts contexts heaps = mapSt fresh_context contexts heaps @@ -1425,17 +1426,17 @@ where (app_args, (ui_var_heap, ui_error)) = mapAppendSt (build_context_arg symb_name) st_context app_args (ui.ui_var_heap, ui.ui_error) -> (App { app & app_args = app_args }, { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) EI_Context context_args - # (app_args, ui=:{ui_var_heap, ui_error}) = adjustClassExpressions symb_name context_args app_args ui + # (app_args, ui) = adjustClassExpressions symb_name context_args app_args ui #! main_dcl_module_n = ui.ui_x.UpdateInfoX.x_main_dcl_module_n #! fun_index = get_recursive_fun_index group_index symb_kind main_dcl_module_n ui.ui_fun_defs | fun_index == NoIndex # app = { app & app_args = app_args} - -> (App app, examine_calls context_args { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) + -> (App app, examine_calls context_args ui) # (CheckedType {st_context}, ui) = ui!ui_fun_env.[fun_index] nr_of_context_args = length context_args nr_of_lifted_contexts = length st_context - nr_of_context_args - (app_args, (ui_var_heap, ui_error)) = mapAppendSt (build_context_arg symb_name) (take nr_of_lifted_contexts st_context) app_args (ui_var_heap, ui_error) - -> (App { app & app_args = app_args }, examine_calls context_args { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) + (app_args, (ui_var_heap, ui_error)) = mapAppendSt (build_context_arg symb_name) (take nr_of_lifted_contexts st_context) app_args (ui.ui_var_heap,ui.ui_error) + -> (App { app & app_args = app_args }, examine_calls context_args {ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) EI_Instance inst_symbol context_args # (context_args, ui=:{ui_var_heap, ui_error}) = adjustClassExpressions symb_name context_args [] ui -> (build_application inst_symbol context_args app_args app_info_ptr, diff --git a/frontend/postparse.icl b/frontend/postparse.icl index a81a358..9bfba72 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1327,7 +1327,7 @@ reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs propertie # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca type_def = { type_def & td_rhs = AbstractType properties } c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } - = (fun_defs, c_defs, imports, imported_objects, ca) + = (fun_defs, c_defs, imports, imported_objects, ca) reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = AbstractTypeSpec properties type} : defs] cons_count sel_count mem_count type_count ca # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count (type_count+1) ca type_def = { type_def & td_rhs = AbstractSynType properties type } diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 0232978..a452c7b 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -90,13 +90,13 @@ where = mark_selected_variable sel pvs var_heap mark_variable {pv_var={fv_name,fv_info_ptr}} var_heap - # (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap + # (VI_Occurrence old_occ=:{occ_ref_count,occ_observing = (_, expr_ptr)}, var_heap) = readPtr fv_info_ptr var_heap = case occ_ref_count ===> ("mark_variable", fv_name) of RC_Unused - # occ_ref_count = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [nilPtr]} + # occ_ref_count = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [expr_ptr]} -> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } ) RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively} - # occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ rcu_multiply), + # occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [expr_ptr : rcu_multiply]), rcu_selectively = [], rcu_uniquely = [] } -> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } ) @@ -105,7 +105,7 @@ refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var=:{var_name, var_info # occ_ref_count = adjust_ref_count sel var_occ.occ_ref_count var_expr_ptr rms_var_heap = markPatternVariables sel var_occ.occ_pattern_vars rms_var_heap = ref_count_of_bindings free_vars var_name var_info_ptr occ_ref_count var_occ { rms & rms_var_heap = rms_var_heap } - ===> ("refMarkOfVariable", var_name, var_occ.occ_ref_count, occ_ref_count) + ===> ("refMarkOfVariable", var_name, var_occ.occ_ref_count, occ_ref_count, var_occ.occ_pattern_vars) where adjust_ref_count sel RC_Unused var_expr_ptr | sel == NotASelector @@ -134,7 +134,7 @@ where ref_count_of_bindings free_vars var_name var_info_ptr occ_ref_count var_occ=:{occ_bind = OB_OpenLet fv let_info} rms=:{rms_var_heap,rms_let_vars} # rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet var_occ.occ_bind }) = { rms & rms_var_heap = rms_var_heap, rms_let_vars = [ fv : rms_let_vars ]} -// ===> ("ref_count_of_bindings (OB_OpenLet)", var_name) + ===> ("ref_count_of_bindings (OB_OpenLet)", var_name) ref_count_of_bindings free_vars var_name var_info_ptr occ_ref_count var_occ=:{occ_bind = OB_LockedLet _} rms=:{rms_var_heap} = { rms & rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })} // ===> ("ref_count_of_bindings (OB_LockedLet)", var_name) @@ -152,14 +152,14 @@ where # rms_var_heap = rms.rms_var_heap <:= (fv_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet var_occ.occ_bind}) rms_var_heap = addParRefCounts call ref_counts rms_var_heap -> addParRefMarksOfLets call let_vars ([fv : closed_let_vars], {rms & rms_var_heap = rms_var_heap}) -// ===> ("addParRefMarksOfLets (OB_OpenLet Yes)", fv_name) + ===> ("addParRefMarksOfLets (OB_OpenLet Yes)", fv_name) OB_OpenLet _ No # rms_var_heap = rms.rms_var_heap <:= (fv_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet var_occ.occ_bind}) -> (closed_let_vars, { rms & rms_var_heap = rms_var_heap, rms_let_vars = [fv : rms.rms_let_vars]}) -// ===> ("addParRefMarksOfLets (OB_OpenLet No)", fv_name) + ===> ("addParRefMarksOfLets (OB_OpenLet No)", fv_name) OB_LockedLet _ -> (closed_let_vars, rms) -// ===> ("addParRefMarksOfLets (OB_LockedLet)", fv_name) + ===> ("addParRefMarksOfLets (OB_LockedLet)", fv_name) addParRefCounts call ref_counts var_heap = foldSt (set_occurrence call) ref_counts var_heap @@ -219,9 +219,9 @@ where binds_are_observing binds var_heap = foldSt bind_is_observing binds (True, var_heap) where - 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) + bind_is_observing {lb_dst={fv_info_ptr}} (observing, var_heap) + # (VI_Occurrence {occ_observing=(observe,attr)}, var_heap) = readPtr fv_info_ptr var_heap + = (observing && observe, var_heap) let_combine free_vars var_heap = foldSt (foldSt let_combine_ref_count) free_vars var_heap @@ -253,8 +253,13 @@ where refMark free_vars sel def (Case ca) rms = refMarkOfCase free_vars sel def ca rms - refMark free_vars sel _ (Selection _ expr selectors) rms - = refMark free_vars (field_number selectors) No expr rms + refMark free_vars sel _ (Selection selkind expr selectors) rms + = case selkind of + UniqueSelector + -> refMark free_vars NotASelector No expr rms + _ + -> refMark free_vars (field_number selectors) No expr rms +// = refMark free_vars (field_number selectors) No expr rms where field_number [ RecordSelection _ field_nr : _ ] = field_nr @@ -650,17 +655,18 @@ seqCombineRefCount (RC_Used sec_ref) (RC_Used prim_ref) = [] -emptyOccurrence observing = +emptyOccurrence type_info = { occ_ref_count = RC_Unused , occ_previous = [] - , occ_observing = observing + , occ_observing = type_info , occ_bind = OB_Empty , occ_pattern_vars = [] } +/* emptyObservingOccurrence =: VI_Occurrence (emptyOccurrence True) emptyNonObservingOccurrence =: VI_Occurrence (emptyOccurrence False) - +*/ makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !v:TypeDefInfos !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !v:TypeDefInfos, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) makeSharedReferencesNonUnique [] fun_defs coercion_env subst type_def_infos var_heap expr_heap error @@ -679,6 +685,7 @@ where position = newPosition fun_symb fun_pos (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env rms_var_heap expr_heap (setErrorAdmin position error) + var_heap = empty_occurrences variables var_heap = (coercion_env, subst, type_def_infos, var_heap, expr_heap, error) where @@ -687,9 +694,20 @@ where where initial_occurrence {fv_name,fv_info_ptr} (subst, type_def_infos, var_heap, expr_heap) # (var_info, var_heap) = readPtr fv_info_ptr var_heap - | has_observing_base_type var_info type_def_infos subst - = (subst, type_def_infos, var_heap <:= (fv_info_ptr, emptyObservingOccurrence), expr_heap) - = (subst, type_def_infos, var_heap <:= (fv_info_ptr, emptyNonObservingOccurrence), expr_heap) + {at_type, at_attribute} = get_type var_info + (expr_ptr, expr_heap) = newPtr (EI_Attribute (toInt at_attribute)) expr_heap +// | has_observing_base_type var_info type_def_infos subst +// = (subst, type_def_infos, var_heap <:= (fv_info_ptr, emptyObservingOccurrence), expr_heap) +// = (subst, type_def_infos, var_heap <:= (fv_info_ptr, emptyNonObservingOccurrence), expr_heap) + | has_observing_type at_type type_def_infos subst + = (subst, type_def_infos, var_heap <:= (fv_info_ptr, VI_Occurrence (emptyOccurrence (True, expr_ptr))), expr_heap) + = (subst, type_def_infos, var_heap <:= (fv_info_ptr, VI_Occurrence (emptyOccurrence (False, expr_ptr))), expr_heap) + + empty_occurrences vars var_heap + = foldSt empty_occurrence vars var_heap + where + empty_occurrence {fv_info_ptr} var_heap + = var_heap <:= (fv_info_ptr, VI_Empty) has_observing_base_type (VI_Type {at_type} _) type_def_infos subst = has_observing_type at_type type_def_infos subst @@ -698,6 +716,11 @@ where has_observing_base_type _ type_def_infos subst = abort "has_observing_base_type (refmark.icl)" + get_type (VI_Type atype _) = atype + get_type (VI_FAType _ atype _) = atype + get_type _ = abort "has_observing_base_type (refmark.icl)" + + make_shared_vars_non_unique vars coercion_env var_heap expr_heap error = foldl make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) vars @@ -774,4 +797,7 @@ instance <<< CountedFreeVar where (<<<) file {cfv_var,cfv_count} = file <<< cfv_var <<< ':' <<< cfv_count +instance <<< PatternVar +where + (<<<) file {pv_var} = file <<< pv_var diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index cb7ac34..3ab1a5a 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1018,7 +1018,7 @@ instance toString KindInfo { occ_ref_count :: !ReferenceCount , occ_bind :: !OccurrenceBinding , occ_pattern_vars :: ![[PatternVar]] - , occ_observing :: !Bool + , occ_observing :: (Bool, Ptr ExprInfo) , occ_previous :: ![ReferenceCount] } diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 188be9c..87c7ee2 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -127,7 +127,7 @@ where toString (TA_Var avar) = toString avar + ":" toString (TA_RootVar avar) - = toString avar + ":" + = toString avar + ":)" toString (TA_Anonymous) = "." toString TA_None diff --git a/frontend/trans.icl b/frontend/trans.icl index c40df06..88d007c 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -1785,7 +1785,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_vars, st_context, st_attr_env, st_arity}) {fv_info_ptr,fv_name} prod_index ((linear_bit, _),ro) - das=:{das_subst,das_type_heaps,das_fun_defs,das_fun_heap,das_var_heap,das_cons_args} + das=:{das_subst,das_type_heaps,das_fun_defs,das_fun_heap,das_var_heap,das_cons_args,das_arg_types,das_next_attr_nr} # {th_vars, th_attrs} = das_type_heaps # (symbol,symbol_arity) = get_producer_symbol producer @@ -1794,12 +1794,11 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var # ({cc_args, cc_linear_bits}, das_fun_heap, das_cons_args) = calc_cons_args curried symbol symbol_arity das_cons_args linear_bit size_fun_defs das_fun_heap - - ({ats_types=[arg_type:_],ats_strictness}, das) - = das!das_arg_types.[prod_index] + ({ats_types=[arg_type:_],ats_strictness}, das_arg_types) + = das_arg_types![prod_index] (das_next_attr_nr, th_attrs) - = foldSt bind_to_temp_attr_var st_attr_vars (das.das_next_attr_nr, th_attrs) + = foldSt bind_to_temp_attr_var st_attr_vars (das_next_attr_nr, th_attrs) // prepare for substitute calls (_, (st_args, st_result), das_type_heaps) = substitute (st_args, st_result) { das_type_heaps & th_vars = th_vars, th_attrs = th_attrs } @@ -1876,9 +1875,10 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var -> (VI_Empty, das_var_heap, let_bindings) _ -> (expr_to_unfold,das_var_heap,let_bindings) ...DvA */ + # das_arg_types = { das_arg_types & [prod_index] = {ats_types=take nr_of_applied_args st_args,ats_strictness=st_args_strictness} } = { das & das_vars = form_vars - , das_arg_types.[prod_index] = {ats_types=take nr_of_applied_args st_args,ats_strictness=st_args_strictness} + , das_arg_types = das_arg_types , das_next_attr_nr = das_next_attr_nr , das_new_linear_bits = cc_linear_bits ++ das.das_new_linear_bits , das_new_cons_args = cc_args ++ das.das_new_cons_args @@ -1984,6 +1984,7 @@ where has_unique_attribute {at_attribute=TA_Unique} = True has_unique_attribute _ = False */ + // DvA: from type.icl... currySymbolType tst_args tst_arity tst_result tst_attr_env req_arity ts_attr_store | tst_arity == req_arity @@ -2597,10 +2598,10 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args # { glob_module, glob_object } = gi | glob_module == ro.ro_main_dcl_module_n | glob_object < size ti_cons_args - #! cons_class = ti_cons_args.[glob_object] + # (cons_class,ti_cons_args) = ti_cons_args![glob_object] (instances, ti_instances) = ti_instances![glob_object] (fun_def, ti_fun_defs) = ti_fun_defs![glob_object] - ti = { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs } + ti = { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs, ti_cons_args = ti_cons_args } = transformFunctionApplication fun_def instances cons_class app extra_args ro ti // It seems as if we have an array function | isEmpty extra_args @@ -2698,10 +2699,10 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args transformApplication app=:{app_symb={symb_name,symb_kind = SK_GeneratedFunction fun_def_ptr fun_index}} extra_args ro ti=:{ti_cons_args,ti_instances,ti_fun_defs,ti_fun_heap} | fun_index < size ti_cons_args - #! cons_class = ti_cons_args.[fun_index] + # (cons_class, ti_cons_args) = ti_cons_args![fun_index] (instances, ti_instances) = ti_instances![fun_index] (fun_def, ti_fun_defs) = ti_fun_defs![fun_index] - ti = { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs } + ti = { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs, ti_cons_args = ti_cons_args } = transformFunctionApplication fun_def instances cons_class app extra_args ro ti # (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap ti = { ti & ti_fun_heap = ti_fun_heap } diff --git a/frontend/transform.icl b/frontend/transform.icl index 460d907..c7326c0 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -2111,7 +2111,8 @@ where instance collectVariables BoundVar where collectVariables var=:{var_name,var_info_ptr,var_expr_ptr} free_vars dynamics cos=:{cos_var_heap} - #! var_info = sreadPtr var_info_ptr cos_var_heap + # (var_info, cos_var_heap) = readPtr var_info_ptr cos_var_heap + cos = { cos & cos_var_heap = cos_var_heap } = case var_info of VI_Alias alias # (original, free_vars, dynamics, cos) = collectVariables alias free_vars dynamics cos diff --git a/frontend/type.icl b/frontend/type.icl index bbd83b5..4262256 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -988,7 +988,7 @@ determine_attribute_of_cons modules cons_attr cons_args prop_class attr_var_heap where determine_cummulative_attribute [] cumm_attr attr_vars prop_class = (cumm_attr, attr_vars, prop_class) - determine_cummulative_attribute [{at_attribute} : types ] cumm_attr attr_vars prop_class + determine_cummulative_attribute [t=:{at_attribute} : types ] cumm_attr attr_vars prop_class | prop_class bitand 1 == 0 = determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1) = case at_attribute of @@ -998,9 +998,12 @@ where -> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1) TA_Var attr_var -> determine_cummulative_attribute types at_attribute [attr_var : attr_vars] (prop_class >> 1) + TA_RootVar attr_var + -> determine_cummulative_attribute types at_attribute [attr_var : attr_vars] (prop_class >> 1) TA_MultiOfPropagatingConsVar -> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1) - + _ + -> abort ("determine_cummulative_attribute" ---> at_attribute) combine_attributes (TA_Var attr_var) cumm_attr prop_vars attr_var_heap attr_vars attr_env ps_error = case cumm_attr of TA_Unique @@ -1010,6 +1013,8 @@ where -> (TA_Var attr_var, attr_var_heap, attr_vars, attr_env, ps_error) TA_Var _ -> (TA_Var attr_var, attr_var_heap, attr_vars, foldSt (new_inequality attr_var) prop_vars attr_env, ps_error) + _ + -> abort ("combine_attributes" ---> cumm_attr) where new_inequality off_attr_var dem_attr_var [] = [{ ai_demanded = dem_attr_var, ai_offered = off_attr_var }] @@ -2624,18 +2629,19 @@ where type_functions group ti ts = mapSt (type_function ti) group ts - type_function ti fun_index ts=:{ts_fun_env, ts_var_heap, ts_expr_heap, ts_error} - # (fd, ts) = ts!ts_fun_defs.[fun_index] - (type, ts_fun_env) = ts_fun_env![fun_index] + type_function ti fun_index ts=:{ts_fun_env, ts_var_heap, ts_error, ts_fun_defs} + # (fd, ts_fun_defs) = ts_fun_defs![fun_index] + (type, ts_fun_env) = ts_fun_env![fun_index] {fun_symb,fun_arity,fun_body=TransformedBody {tb_args,tb_rhs},fun_pos, fun_info, fun_type} = fd temp_fun_type = type_of type ts_var_heap = makeBase fun_symb 1 tb_args temp_fun_type.tst_args ts_var_heap fe_location = newPosition fun_symb fun_pos ts_error = setErrorAdmin fe_location ts_error +// ts = { ts & ts_var_heap = ts_var_heap, ts_error = ts_error} + ts = { ts & ts_var_heap = ts_var_heap, ts_error = ts_error, ts_fun_defs = ts_fun_defs, ts_fun_env = ts_fun_env} reqs = { req_overloaded_calls = [], req_type_coercion_groups = [], req_type_coercions = [], req_attr_coercions = [], req_case_and_let_exprs = [] } - ( rhs_type, rhs_expr_ptr, (rhs_reqs, ts)) = requirements ti tb_rhs (reqs, - { ts & ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error, ts_fun_env = ts_fun_env }) + (rhs_type, rhs_expr_ptr, (rhs_reqs, ts)) = requirements ti tb_rhs (reqs, ts) req_type_coercions = [{tc_demanded = temp_fun_type.tst_result,tc_offered = rhs_type, tc_position = CP_Expression tb_rhs, tc_coercible = True} : rhs_reqs.req_type_coercions ] ts_expr_heap = storeAttribute rhs_expr_ptr temp_fun_type.tst_result.at_attribute ts.ts_expr_heap diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 244b8fd..0f01704 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -906,20 +906,21 @@ where equi_attrs attr1 attr2 attr_var_heap = (attr1 == attr2, attr_var_heap) -equivTypeVars :: !TypeVar !TempVarId !*TypeHeaps -> (!Bool, !*TypeHeaps) -equivTypeVars {tv_info_ptr} var_number heaps=:{th_vars} - #! tv_info = sreadPtr tv_info_ptr th_vars +equivTypeVars :: !TypeVar !TempVarId !*TypeVarHeap -> (!Bool, !*TypeVarHeap) +equivTypeVars {tv_info_ptr} var_number type_var_heap + # (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap = case tv_info of TVI_Forward forw_var_number - -> (forw_var_number == var_number, heaps) + -> (forw_var_number == var_number, type_var_heap) _ - -> (True, { heaps & th_vars = writePtr tv_info_ptr (TVI_Forward var_number) heaps.th_vars }) + -> (True, type_var_heap <:= (tv_info_ptr, TVI_Forward var_number)) instance equiv Type where - equiv (TV tv) (TempV var_number) heaps - = equivTypeVars tv var_number heaps + equiv (TV tv) (TempV var_number) heaps=:{th_vars} + # (equiv, th_vars) = equivTypeVars tv var_number th_vars + = (equiv, { heaps & th_vars = th_vars }) equiv (TV tv1) (TV tv2) heaps = (True, heaps) equiv (arg_type1 --> restype1) (arg_type2 --> restype2) heaps @@ -946,11 +947,11 @@ where = (False, heaps) equiv (TB basic1) (TB basic2) heaps = (basic1 == basic2, heaps) - equiv (CV tv :@: types1) (TempCV var_number :@: types2) heaps - # (equi_vars, heaps) = equivTypeVars tv var_number heaps + equiv (CV tv :@: types1) (TempCV var_number :@: types2) heaps=:{th_vars} + # (equi_vars, th_vars) = equivTypeVars tv var_number th_vars | equi_vars - = equiv types1 types2 heaps - = (False, heaps) + = equiv types1 types2 { heaps & th_vars = th_vars } + = (False, { heaps & th_vars = th_vars }) equiv (TFA vars1 type1) (TFA vars2 type2) heaps = equiv type1 type2 heaps equiv type1 type2 heaps |