diff options
| -rw-r--r-- | frontend/analtypes.icl | 40 | ||||
| -rw-r--r-- | frontend/check.dcl | 4 | ||||
| -rw-r--r-- | frontend/check.icl | 143 | ||||
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 5 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 17 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 10 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 2 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 11 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 2 | ||||
| -rw-r--r-- | frontend/frontend.icl | 1 | ||||
| -rw-r--r-- | frontend/general.dcl | 2 | ||||
| -rw-r--r-- | frontend/general.icl | 2 | ||||
| -rw-r--r-- | frontend/generics.icl | 11 | ||||
| -rw-r--r-- | frontend/overloading.icl | 2 | ||||
| -rw-r--r-- | frontend/refmark.icl | 415 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 46 | ||||
| -rw-r--r-- | frontend/syntax.icl | 39 | ||||
| -rw-r--r-- | frontend/trans.icl | 2 | ||||
| -rw-r--r-- | frontend/type.icl | 79 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 8 | ||||
| -rw-r--r-- | frontend/unitype.icl | 4 |
21 files changed, 483 insertions, 362 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 3724b07..b7e2281 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -653,29 +653,17 @@ determine_kinds_of_type_contexts modules type_contexts class_infos as where determine_kinds_of_type_context :: !{#CommonDefs} !TypeContext !(!*ClassDefInfos, !*AnalyseState) -> (!*ClassDefInfos, !*AnalyseState) determine_kinds_of_type_context modules {tc_class={glob_module,glob_object={ds_ident,ds_index}},tc_types} (class_infos, as) -// # (class_kinds, class_infos) = myselect ds_ident class_infos glob_module ds_index # (class_kinds, class_infos) = class_infos![glob_module,ds_index] - as = fold2St (verify_kind_of_type modules) class_kinds tc_types as - = (class_infos, as) - + | length class_kinds == length tc_types + # as = fold2St (verify_kind_of_type modules) class_kinds tc_types as + = (class_infos, as) + = abort ("determine_kinds_of_type_context" ---> (ds_ident, class_kinds, tc_types)) + verify_kind_of_type modules req_kind type as # (kind_of_type, as=:{as_kind_heap,as_error}) = determineKind modules type as {uki_kind_heap, uki_error} = unifyKinds kind_of_type (kindToKindInfo req_kind) {uki_kind_heap = as_kind_heap, uki_error = as_error} = { as & as_kind_heap = uki_kind_heap, as_error = uki_error } -/* -import cheat - -myselect name array i j - # (copy, array) = uniqueCopy array - #! i_size = size copy - | i < i_size - #! j_size = size copy.[i] - | j < j_size - = array![i].[j] - = abort (("second index out of range " +++ toString j +++ ">=" +++ toString j_size) ---> ("myselect", name, i)) - = abort (("first index out of range " +++ toString i +++ ">=" +++ toString i_size) ---> ("myselect", name, j)) -*/ determine_kinds_type_list :: !{#CommonDefs} [AType] !*AnalyseState -> *AnalyseState determine_kinds_type_list modules types as = foldSt (force_star_kind modules) types as @@ -684,7 +672,6 @@ where # (off_kind, as=:{as_kind_heap,as_error}) = determineKind modules type as {uki_kind_heap, uki_error} = unifyKinds off_kind KI_Const {uki_kind_heap = as_kind_heap, uki_error = as_error} = { as & as_kind_heap = uki_kind_heap, as_error = uki_error } - class_def_error = "cyclic dependencies between type classes" type_appl_error = "type constructor has too many arguments" @@ -727,13 +714,14 @@ where as_type_var_heap = bind_kind_vars class_args class_kind_vars as.as_type_var_heap as_error = pushErrorAdmin (newPosition class_name class_pos) as.as_error class_infos = { class_infos & [class_module,class_index] = cyclicClassInfoMark } - (class_infos, as) = foldSt (determine_kinds_of_context_class modules) class_context (class_infos, + (class_infos, as) = determine_kinds_of_context_classes class_context (class_infos, { as & as_kind_heap = as_kind_heap, as_type_var_heap = as_type_var_heap, as_error = as_error }) | as.as_error.ea_ok # (class_infos, as) = determine_kinds_of_type_contexts modules class_context class_infos as (class_infos, as) = determine_kinds_of_members modules class_members com_member_defs class_kind_vars (class_infos, as) (class_kinds, as_kind_heap) = retrieve_class_kinds class_kind_vars as.as_kind_heap = ({class_infos & [class_module,class_index] = class_kinds }, { as & as_kind_heap = as_kind_heap, as_error = popErrorAdmin as.as_error}) +// ---> ("determine_kinds_of_class", class_name, class_kinds) = ({class_infos & [class_module,class_index] = [ KindConst \\ _ <- [1..class_arity]] }, { as & as_error = popErrorAdmin as.as_error }) | isCyclicClass class_infos.[class_module,class_index] # class_name = modules.[class_module].com_class_defs.[class_index].class_name @@ -746,12 +734,16 @@ where = fresh_kind_vars (dec nr_of_vars) [ kind_info_ptr : fresh_vars] (kind_heap <:= (kind_info_ptr, KI_Var kind_info_ptr)) = (fresh_vars, kind_heap) - determine_kinds_of_context_class modules {tc_class={glob_module,glob_object={ds_index}}} infos_and_as - = determine_kinds_of_class modules glob_module ds_index infos_and_as isCyclicClass [ KindCycle : _ ] = True isCyclicClass _ = False + determine_kinds_of_context_classes contexts class_infos_and_as + = foldSt (determine_kinds_of_context_class modules) contexts class_infos_and_as + where + determine_kinds_of_context_class modules {tc_class={glob_module,glob_object={ds_index}}} infos_and_as + = determine_kinds_of_class modules glob_module ds_index infos_and_as + bind_kind_vars type_vars kind_ptrs type_var_heap = fold2St bind_kind_var type_vars kind_ptrs type_var_heap where @@ -767,14 +759,16 @@ where determine_kinds_of_members modules members member_defs class_kind_vars (class_infos, as) = iFoldSt (determine_kind_of_member modules members member_defs class_kind_vars) 0 (size members) (class_infos, as) - determine_kind_of_member modules members member_defs class_kind_vars loc_member_index (class_infos, as) + determine_kind_of_member modules members member_defs class_kind_vars loc_member_index class_infos_and_as # glob_member_index = members.[loc_member_index].ds_index {me_class_vars,me_type={st_vars,st_args,st_result,st_context}} = member_defs.[glob_member_index] + other_contexts = (tl st_context) + (class_infos, as) = determine_kinds_of_context_classes other_contexts class_infos_and_as as_type_var_heap = clear_variables st_vars as.as_type_var_heap as_type_var_heap = bind_kind_vars me_class_vars class_kind_vars as_type_var_heap (as_type_var_heap, as_kind_heap) = fresh_kind_vars_for_unbound_vars st_vars as_type_var_heap as.as_kind_heap as = determine_kinds_type_list modules [st_result:st_args] { as & as_type_var_heap = as_type_var_heap, as_kind_heap = as_kind_heap} - (class_infos, as) = determine_kinds_of_type_contexts modules (tl st_context) class_infos as + (class_infos, as) = determine_kinds_of_type_contexts modules other_contexts class_infos as = (class_infos, as) where fresh_kind_vars_for_unbound_vars type_vars type_var_heap kind_heap diff --git a/frontend/check.dcl b/frontend/check.dcl index 1f5129a..8f9a018 100644 --- a/frontend/check.dcl +++ b/frontend/check.dcl @@ -7,8 +7,8 @@ checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional Scanned checkFunctions :: !Index !Level !Index !Index !*{#FunDef} !*ExpressionInfo !*Heaps !*CheckState -> (!*{#FunDef}, !*ExpressionInfo, !*Heaps, !*CheckState) -determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !(Optional *ErrorAdmin) - -> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !Optional *ErrorAdmin) +determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin + -> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin) arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x] diff --git a/frontend/check.icl b/frontend/check.icl index 1ddda1f..1a02ac3 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -109,8 +109,8 @@ checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, spe { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }, predef_symbols, error)) where substitute_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment type_heaps error - # (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, _, type_heaps, Yes error) - = instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment [] type_heaps (Yes error) + # (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, _, type_heaps, error) + = instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment [] type_heaps error = ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars, st_context = st_context, st_attr_env = st_attr_env }, type_heaps, error) @@ -399,8 +399,8 @@ where instance_types member_defs type_defs modules var_heap type_heaps { cs & cs_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error} # ({me_symb, me_type,me_class_vars,me_pos}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules - (instance_type, _, type_heaps, Yes (modules, type_defs), Yes cs_error) - = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) (Yes cs.cs_error) + (instance_type, _, type_heaps, Yes (modules, type_defs), cs_error) + = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes (modules, type_defs, x_main_dcl_module_n)) cs.cs_error (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap = check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type [ (ins_member.ds_index, { instance_type & st_context = st_context }) : instance_types ] member_defs type_defs modules var_heap type_heaps { cs & cs_error = cs_error } @@ -432,35 +432,32 @@ getGenericDef {glob_module, glob_object={ds_ident, ds_index}} mod_index generic_ = (dcl_mod.dcl_common.com_generic_defs.[ds_index], generic_defs, modules) // ..AA -instantiateTypes :: ![TypeVar] ![AttributeVar] !types ![TypeContext] ![AttrInequality] !SpecialSubstitution ![SpecialSubstitution] !*TypeHeaps !(Optional *ErrorAdmin) - -> (![TypeVar], ![AttributeVar], !types , ![TypeContext], ![AttrInequality], ![SpecialSubstitution], !*TypeHeaps, !(Optional *ErrorAdmin)) | substitute types -instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_environ, ss_vars, ss_attrs, ss_context} special_subst_list type_heaps=:{th_vars, th_attrs} opt_error +instantiateTypes :: ![TypeVar] ![AttributeVar] ![AType] ![TypeContext] ![AttrInequality] !SpecialSubstitution ![SpecialSubstitution] !*TypeHeaps !*ErrorAdmin + -> (![TypeVar], ![AttributeVar], ![AType], ![TypeContext], ![AttrInequality], ![SpecialSubstitution], !*TypeHeaps, !*ErrorAdmin) +instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_environ, ss_vars, ss_attrs, ss_context} special_subst_list type_heaps=:{th_vars, th_attrs} error # th_vars = clear_vars old_type_vars th_vars (new_type_vars, th_vars) = foldSt build_var_subst ss_vars ([], th_vars) - (new_attr_vars, th_attrs) = foldSt build_attr_subst ss_attrs ([], th_attrs) + (new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs) type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs } (ok1, new_ss_context, type_heaps) = substitute ss_context type_heaps - (inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars) - (inst_attr_vars, th_attrs) = foldSt build_attr_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs) + (inst_vars, th_vars) = foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars) + (inst_attr_vars, th_attrs) = foldSt build_attr_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs) - (ok2, inst_types, type_heaps) = substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs } + (inst_types, (ok2, type_heaps)) = mapSt substitue_arg_type types (True, { type_heaps & th_vars = th_vars, th_attrs = th_attrs }) +// (ok2, inst_types, type_heaps) = substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs } (ok3, inst_contexts, type_heaps) = substitute type_contexts type_heaps (ok4, inst_attr_env, type_heaps) = substitute attr_env type_heaps - (special_subst_list, th_vars) = mapSt adjust_special_subst special_subst_list type_heaps.th_vars - - opt_error = case ok1 && ok2 && ok3 && ok4 of - True -> opt_error - _ -> case opt_error of - No -> No - Yes error_admin - -> Yes (checkError "instance type incompatible with class type" "" - error_admin) - // e.g.:class c a :: (a Int); instance c Real - - = (inst_vars, inst_attr_vars, inst_types, inst_contexts ++ new_ss_context, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, opt_error) + (special_subst_list, th_vars) = mapSt adjust_special_subst special_subst_list type_heaps.th_vars + error = case ok1 && ok2 && ok3 && ok4 of + True + -> error + False + -> checkError "instance type incompatible with class type" "" error + + = (inst_vars, inst_attr_vars, inst_types, inst_contexts ++ new_ss_context, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, error) where clear_vars type_vars type_var_heap = foldSt (\tv -> writePtr tv.tv_info_ptr TVI_Empty) type_vars type_var_heap @@ -492,12 +489,34 @@ where // ... RWS = { type_heaps & th_vars = writePtr bind_dst.tv_info_ptr (TVI_Type bind_src) type_heaps.th_vars} + substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps) + # (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps) + (ok, new_at, type_heaps) = substitute {at & at_type = type} type_heaps + = ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok && ok, type_heaps)) + substitue_arg_type type (was_ok, type_heaps) + # (ok, type, type_heaps) = substitute type type_heaps + = (type, (was_ok && ok, type_heaps)) + build_var_subst var (free_vars, type_var_heap) # (new_info_ptr, type_var_heap) = newPtr TVI_Empty type_var_heap new_fv = { var & tv_info_ptr = new_info_ptr} = ([ new_fv : free_vars ], writePtr var.tv_info_ptr (TVI_Type (TV new_fv)) type_var_heap) - build_attr_subst attr (free_attrs, attr_var_heap) + build_avar_subst atv=:{atv_variable,atv_attribute} (free_vars, type_heaps) + # (new_info_ptr, th_vars) = newPtr TVI_Empty type_heaps.th_vars + new_fv = { atv_variable & tv_info_ptr = new_info_ptr} + th_vars = th_vars <:= (atv_variable.tv_info_ptr, TVI_Type (TV new_fv)) + (new_attr, th_attrs) = build_attr_subst atv_attribute type_heaps.th_attrs + = ([ { atv & atv_variable = new_fv, atv_attribute = new_attr } : free_vars], { type_heaps & th_vars = th_vars, th_attrs = th_attrs }) + where + build_attr_subst (TA_Var avar) attr_var_heap + # (new_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_attr = { avar & av_info_ptr = new_info_ptr} + = (TA_Var new_attr, attr_var_heap <:= (avar.av_info_ptr, AVI_Attr (TA_Var new_attr))) + build_attr_subst attr attr_var_heap + = (attr, attr_var_heap) + + build_attr_var_subst attr (free_attrs, attr_var_heap) # (new_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap new_attr = { attr & av_info_ptr = new_info_ptr} = ([new_attr : free_attrs], writePtr attr.av_info_ptr (AVI_Attr (TA_Var new_attr)) attr_var_heap) @@ -510,47 +529,41 @@ where # (TVI_Type (TV new_tv), type_var_heap) = readPtr tv_info_ptr type_var_heap = ({ bind & bind_dst = new_tv }, type_var_heap) -substituteInstanceType :: !InstanceType !SpecialSubstitution !*TypeHeaps !*ErrorAdmin -> (!InstanceType,!*TypeHeaps,!.ErrorAdmin) -substituteInstanceType it=:{it_vars,it_attr_vars,it_types,it_context} environment type_heaps cs_error - # (it_vars, it_attr_vars, it_types, it_context, _, _, type_heaps, Yes cs_error) - = instantiateTypes it_vars it_attr_vars it_types it_context [] environment [] type_heaps (Yes cs_error) - = ({it & it_vars = it_vars, it_types = it_types, it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps, cs_error) - -determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !(Optional *ErrorAdmin) - -> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !Optional *ErrorAdmin) -determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps opt_modules opt_error +determineTypeOfMemberInstance :: !SymbolType ![TypeVar] !InstanceType !Specials !*TypeHeaps !u:(Optional (v:{#DclModule}, w:{#CheckedTypeDef}, Index)) !*ErrorAdmin + -> (!SymbolType, !Specials, !*TypeHeaps, !u:Optional (v:{#DclModule}, w:{#CheckedTypeDef}), !*ErrorAdmin) +determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,it_context} specials type_heaps opt_modules error # env = { ss_environ = foldl2 (\binds var type -> [ {bind_src = type, bind_dst = var} : binds]) [] class_vars it_types, ss_context = it_context, ss_vars = it_vars, ss_attrs = it_attr_vars} - (st, specials, type_heaps, opt_error) - = determine_type_of_member_instance mem_st env specials type_heaps opt_error - (type_heaps, opt_modules, opt_error) - = check_attribution_consistency mem_st type_heaps opt_modules opt_error - = (st, specials, type_heaps, opt_modules, opt_error) + (st, specials, type_heaps, error) + = determine_type_of_member_instance mem_st env specials type_heaps error + (type_heaps, opt_modules, error) + = check_attribution_consistency mem_st type_heaps opt_modules error + = (st, specials, type_heaps, opt_modules, error) where - determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps opt_error - # (mem_st, substs, type_heaps, opt_error) - = substitute_symbol_type { mem_st & st_context = tl st_context } env substs type_heaps opt_error - = (mem_st, SP_Substitutions substs, type_heaps, opt_error) - determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps opt_error - # (mem_st, _, type_heaps, opt_error) - = substitute_symbol_type { mem_st & st_context = tl st_context } env [] type_heaps opt_error - = (mem_st, SP_None, type_heaps, opt_error) - - substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps opt_error - # (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps, opt_error) - = instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment specials type_heaps opt_error + determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps error + # (mem_st, substs, type_heaps, error) + = substitute_symbol_type { mem_st & st_context = tl st_context } env substs type_heaps error + = (mem_st, SP_Substitutions substs, type_heaps, error) + determine_type_of_member_instance mem_st=:{st_context} env SP_None type_heaps error + # (mem_st, _, type_heaps, error) + = substitute_symbol_type { mem_st & st_context = tl st_context } env [] type_heaps error + = (mem_st, SP_None, type_heaps, error) + + substitute_symbol_type st=:{st_vars,st_attr_vars,st_args,st_result,st_context,st_attr_env} environment specials type_heaps error + # (st_vars, st_attr_vars, [st_result : st_args], st_context, st_attr_env, specials, type_heaps, error) + = instantiateTypes st_vars st_attr_vars [ st_result : st_args ] st_context st_attr_env environment specials type_heaps error = ({st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_attr_vars = st_attr_vars, - st_context = st_context, st_attr_env = st_attr_env }, specials, type_heaps, opt_error) + st_context = st_context, st_attr_env = st_attr_env }, specials, type_heaps, error) - check_attribution_consistency {st_args, st_result} type_heaps No No - = (type_heaps, No, No) - check_attribution_consistency {st_args, st_result} type_heaps=:{th_vars} (Yes (modules, type_defs, x_main_dcl_module_n)) (Yes error) + check_attribution_consistency {st_args, st_result} type_heaps No error + = (type_heaps, No, error) + check_attribution_consistency {st_args, st_result} type_heaps=:{th_vars} (Yes (modules, type_defs, x_main_dcl_module_n)) error // it is assumed that all type vars bindings done in instantiateTypes are still valid # (_, th_vars, modules, type_defs, error) = foldSt (foldATypeSt (check_it x_main_dcl_module_n) (\_ st -> st)) [st_result:st_args] (False, th_vars, modules, type_defs, error) - = ({ type_heaps & th_vars = th_vars }, Yes (modules, type_defs), Yes error) + = ({ type_heaps & th_vars = th_vars }, Yes (modules, type_defs), error) check_it _ {at_attribute} (error_already_given, th_vars, modules, type_defs, error) | at_attribute==TA_Unique || error_already_given @@ -639,8 +652,6 @@ where (next_mem_inst_index + class_size) mod_index all_class_specials class_defs member_defs generic_defs modules { instance_defs & [inst_index] = { instance_def & ins_specials = ins_specials }} type_heaps var_heap predef_symbols error = (memb_inst_defs1 ++ memb_inst_defs2, next_mem_inst_index, all_class_specials, class_defs, member_defs, generic_defs, modules, instance_defs, type_heaps, var_heap ,predef_symbols,error) - //---> ("determine_types_of_instances: generic ", gen_name, mod_index, inst_index, x_main_dcl_module_n) -// = abort "exporting generics is not yet supported\n" # ({class_name, class_members}, class_defs, modules) = getClassDef ins_class mod_index class_defs modules class_size = size class_members (ins_members, memb_inst_defs1, member_defs, modules, type_heaps, var_heap, error) @@ -667,8 +678,8 @@ where ({me_symb,me_type,me_priority,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules cs_error = pushErrorAdmin (newPosition class_name ins_pos) cs_error - (instance_type, new_ins_specials, type_heaps, Yes (modules, _), Yes cs_error) - = determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps (Yes (modules, {}, cUndef)) (Yes cs_error) + (instance_type, new_ins_specials, type_heaps, Yes (modules, _), cs_error) + = determineTypeOfMemberInstance me_type me_class_vars ins_type ins_specials type_heaps (Yes (modules, {}, cUndef)) cs_error cs_error = popErrorAdmin cs_error (new_info_ptr, var_heap) = newPtr VI_Empty var_heap @@ -686,12 +697,20 @@ where = (SP_ContextTypes list_of_specials, next_inst_index, all_instances, type_heaps, predef_symbols, error) where check_specials mod_index inst=:{ins_type} type_offset [ subst : substs ] list_of_specials next_inst_index all_instances type_heaps predef_symbols error - # (special_type, type_heaps, error) = substituteInstanceType ins_type subst type_heaps error + # (special_type, type_heaps, error) = substitute_instance_type ins_type subst type_heaps error (spec_types, predef_symbols,error) = checkAndCollectTypesOfContextsOfSpecials special_type.it_context predef_symbols error special = { spec_index = { glob_module = mod_index, glob_object = next_inst_index }, spec_types = spec_types, spec_vars = subst.ss_vars, spec_attrs = subst.ss_attrs } = check_specials mod_index inst (inc type_offset) substs [ special : list_of_specials ] (inc next_inst_index) [{ inst & ins_type = { special_type & it_context = [] }, ins_specials = SP_TypeOffset type_offset} : all_instances ] type_heaps predef_symbols error + where + substitute_instance_type :: !InstanceType !SpecialSubstitution !*TypeHeaps !*ErrorAdmin -> (!InstanceType,!*TypeHeaps,!.ErrorAdmin) + substitute_instance_type it=:{it_vars,it_attr_vars,it_types,it_context} environment type_heaps cs_error + # (it_vars, it_attr_vars, it_atypes, it_context, _, _, type_heaps, cs_error) + = instantiateTypes it_vars it_attr_vars [MakeAttributedType type \\ type <- it_types] it_context [] environment [] type_heaps cs_error + = ({it & it_vars = it_vars, it_types = [ at_type \\ {at_type} <- it_atypes ], it_attr_vars = it_attr_vars, it_context = it_context }, type_heaps, cs_error) + + check_specials mod_index inst=:{ins_type} type_offset [] list_of_specials next_inst_index all_instances type_heaps predef_symbols error = (list_of_specials, next_inst_index, all_instances, type_heaps, predef_symbols, error) check_instance_specials mod_index fun_type fun_index SP_None next_inst_index all_instances type_heaps predef_symbols error @@ -2147,9 +2166,9 @@ check_needed_modules_are_imported mod_name extension cs=:{cs_x={x_needed_modules = cs where check_it pd mod_name explanation extension cs=:{cs_predef_symbols, cs_symbol_table} - #! {pds_ident} = cs_predef_symbols.[pd] + # (pds_ident, cs_predef_symbols) = cs_predef_symbols![pd].pds_ident # ({ste_kind}, cs_symbol_table) = readPtr pds_ident.id_info cs_symbol_table - cs = { cs & cs_symbol_table = cs_symbol_table } + cs = { cs & cs_symbol_table = cs_symbol_table, cs_predef_symbols = cs_predef_symbols } = case ste_kind of STE_ClosedModule -> cs diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 99248f1..93afa69 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -1945,12 +1945,11 @@ where determine_selector mod_index type_mod_index type_index [{glob_module, glob_object} : selectors] selector_defs modules | type_mod_index == glob_module | type_mod_index == mod_index - #! selector_def = selector_defs.[glob_object] + # (selector_def,selector_defs) = selector_defs![glob_object] | selector_def.sd_type_index == type_index = (glob_object, selector_def.sd_field_nr, selector_defs, modules) = determine_selector mod_index type_mod_index type_index selectors selector_defs modules - #! {dcl_common={com_selector_defs}} = modules.[glob_module] - #! selector_def = com_selector_defs.[glob_object] + # (selector_def, modules) = modules![glob_module].dcl_common.com_selector_defs.[glob_object] | selector_def.sd_type_index == type_index = (glob_object, selector_def.sd_field_nr, selector_defs, modules) = determine_selector mod_index type_mod_index type_index selectors selector_defs modules diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 223da52..0fb2843 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -289,9 +289,9 @@ where remove_declared_symbols_in_array :: !Int !{!Declaration} !*SymbolTable -> !*SymbolTable remove_declared_symbols_in_array symbol_index symbols symbol_table | symbol_index<size symbols - #! (symbol,symbols) = symbols![symbol_index] + # symbol = symbols.[symbol_index] # (Declaration {decl_ident={id_info}})=symbol - #! entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table # {ste_kind,ste_def_level} = entry | ste_kind == STE_Empty || ste_def_level > cModuleScope = remove_declared_symbols_in_array (symbol_index+1) symbols symbol_table @@ -325,7 +325,7 @@ NewEntry symbol_table symb_ptr def_kind def_index level previous :== addDefToSymbolTable :: !Level !Index !Ident !STE_Kind !*SymbolTable !*ErrorAdmin -> (!* SymbolTable, !*ErrorAdmin) addDefToSymbolTable level def_index def_ident=:{id_info} def_kind symbol_table error - #! entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table | entry.ste_kind == STE_Empty || entry.ste_def_level <> level # entry = {ste_index = def_index, ste_kind = def_kind, ste_def_level = level, ste_previous = entry } = (symbol_table <:= (id_info,entry), error) @@ -373,7 +373,8 @@ addDeclarationsOfDclModToSymbolTable ste_index locals imported cs addImportedFunctionOrMacro :: !(Optional IndexRange) !Ident !Int !*CheckState -> (!Bool, !.CheckState) addImportedFunctionOrMacro opt_dcl_macro_range ident=:{id_info} def_index cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + cs = { cs & cs_symbol_table = cs_symbol_table } = case entry.ste_kind of STE_Empty -> (True, { cs & cs_symbol_table = NewEntry cs.cs_symbol_table id_info (STE_FunctionOrMacro []) @@ -432,7 +433,7 @@ addGlobalDefinitionsToSymbolTable decls cs = foldSt add_global_definition decls cs where add_global_definition (Declaration {decl_ident=ident=:{id_info},decl_pos,decl_kind,decl_index}) cs=:{cs_symbol_table} - #! entry = sreadPtr id_info cs_symbol_table + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table | entry.ste_def_level < cGlobalScope # cs = { cs & cs_symbol_table = NewEntry cs_symbol_table id_info decl_kind decl_index cGlobalScope entry } = case decl_kind of @@ -440,7 +441,7 @@ where -> addFieldToSelectorDefinition selector_id { glob_module = NoIndex, glob_object = decl_index } cs _ -> cs - = { cs & cs_error = checkErrorWithIdentPos (newPosition ident decl_pos) "multiply defined" cs.cs_error} + = { cs & cs_symbol_table = cs_symbol_table, cs_error = checkErrorWithIdentPos (newPosition ident decl_pos) "multiply defined" cs.cs_error} removeImportedSymbolsFromSymbolTable :: Declaration !*SymbolTable -> .SymbolTable removeImportedSymbolsFromSymbolTable (Declaration {decl_ident=decl_ident=:{id_info}, decl_index}) symbol_table @@ -495,7 +496,7 @@ removeLocalIdentsFromSymbolTable level idents symbol_table removeIdentFromSymbolTable :: !.Int !Ident !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry; removeIdentFromSymbolTable level {id_name,id_info} symbol_table - #! {ste_previous,ste_def_level} = sreadPtr id_info symbol_table + # ({ste_previous,ste_def_level}, symbol_table) = readPtr id_info symbol_table | level <= ste_def_level = symbol_table <:= (id_info,ste_previous) // ---> ("removeIdentFromSymbolTable", id_name) = symbol_table // ---> ("NO removeIdentFromSymbolTable", id_name) @@ -510,7 +511,7 @@ where = (defs, symbol_table) #! def = defs.[from_index] id_info = (toIdent def).id_info - entry = sreadPtr id_info symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table | level == entry.ste_def_level = remove_defs_from_symbol_table level (inc from_index) to_index defs (symbol_table <:= (id_info, entry.ste_previous)) = remove_defs_from_symbol_table level (inc from_index) to_index defs symbol_table diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 2959e4e..a4baf5d 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -1114,10 +1114,10 @@ instance e_corresponds DynamicPattern where o` e_corresponds_dp_type dcl.dp_type icl.dp_type where e_corresponds_dp_type dcl_expr_ptr icl_expr_ptr ec_state=:{ec_expr_heap, ec_tc_state} - #! dcl_type - = sreadPtr dcl_expr_ptr ec_expr_heap - icl_type - = sreadPtr icl_expr_ptr ec_expr_heap + # (dcl_type, ec_expr_heap) + = readPtr dcl_expr_ptr ec_expr_heap + (icl_type, ec_expr_heap) + = readPtr icl_expr_ptr ec_expr_heap # (EI_DynamicTypeWithVars _ dcl_dyn_type _) = dcl_type (EI_DynamicTypeWithVars _ icl_dyn_type _) @@ -1125,7 +1125,7 @@ instance e_corresponds DynamicPattern where (corresponds, ec_tc_state) = t_corresponds dcl_dyn_type icl_dyn_type ec_tc_state ec_state - = { ec_state & ec_tc_state = ec_tc_state } + = { ec_state & ec_tc_state = ec_tc_state, ec_expr_heap = ec_expr_heap } | corresponds = ec_state = give_error "" ec_state diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index a25e048..9e46335 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -622,7 +622,7 @@ determine_defaults :: case_default default_expr varheap -> (this_case_default, n 2nd = directly surrounding default */ determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap} - #! var_info = sreadPtr var_info_ptr ci_var_heap + # (var_info, ci_var_heap) = readPtr var_info_ptr ci_var_heap # (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap} # expression = expression// ---> expression diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 3cf2454..b1de953 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -123,7 +123,7 @@ convertCasesInBody (TransformedBody body) (Yes type) group_index common_defs cs checkImportedSymbol :: SymbKind VarInfoPtr ([SymbKind], *VarHeap) -> ([SymbKind], *VarHeap) checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap) - #! type_info = sreadPtr symb_type_ptr var_heap + # (type_info, var_heap) = readPtr symb_type_ptr var_heap = case type_info of VI_Used -> (collected_imports, var_heap) @@ -144,11 +144,12 @@ class weightedRefCount e :: RCInfo !e !*RCState -> *RCState instance weightedRefCount BoundVar where - weightedRefCount rci=:{rci_depth} {var_name,var_info_ptr} rs=:{rcs_var_heap,rcs_free_vars} - #! var_info = sreadPtr var_info_ptr rcs_var_heap + weightedRefCount rci=:{rci_depth} {var_name,var_info_ptr} rs=:{rcs_var_heap} + # (var_info, rcs_var_heap) = readPtr var_info_ptr rcs_var_heap + rs = { rs & rcs_var_heap = rcs_var_heap } = case var_info of VI_LetVar lvi - # (is_new, lvi=:{lvi_expression}, rcs_free_vars) = weightedRefCountOfVariable rci_depth var_info_ptr lvi 1 rcs_free_vars + # (is_new, lvi=:{lvi_expression}, rcs_free_vars) = weightedRefCountOfVariable rci_depth var_info_ptr lvi 1 rs.rcs_free_vars | is_new # rs = weightedRefCount rci lvi_expression { rs & rcs_free_vars = rcs_free_vars, @@ -234,7 +235,7 @@ where = abort ("weightedRefCount [Expression] (convertcases, 864))" -*-> expr) addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap) - #! var_info = sreadPtr var_info_ptr var_heap + # (var_info, var_heap) = readPtr var_info_ptr var_heap = case var_info of VI_LetVar lvi # (_, lvi, free_vars) = weightedRefCountOfVariable depth var_info_ptr lvi ref_count free_vars diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 99f5646..ae94b7e 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -790,7 +790,7 @@ instance check_completeness SymbIdent where // otherwise the function was defined locally in a macro // it is not a consequence, but it's type and body are consequences ! #! (already_visited, ccs) = ccs!box_ccs.ccs_set_of_visited_icl_funs.[glob_object] - | already_visited + | /* ccs.box_ccs.ccs_set_of_visited_icl_funs.[glob_object] */ already_visited = ccs #! ccs = { ccs & box_ccs.ccs_set_of_visited_icl_funs.[glob_object] = True } = check_completeness fun_def cci ccs diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 24fd0a4..b76c653 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -87,7 +87,6 @@ frontEndInterface :: !FrontEndOptions !Ident !SearchPaths !{#DclModule} !{#FunDe -> ( !Optional *FrontEndSyntaxTree,!*{# FunDef },!{#DclModule},!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional !*File, !*Heaps) frontEndInterface options mod_ident search_paths cached_dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table modtimefunction files error io out tcl_file heaps // # files = trace_n ("Compiling "+++mod_ident.id_name) files - # (ok, mod, hash_table, error, predef_symbols, files) = wantModule cWantIclFile mod_ident NoPos options.feo_generics(hash_table /* ---> ("Parsing:", mod_ident)*/) error search_paths predef_symbols modtimefunction files | not ok diff --git a/frontend/general.dcl b/frontend/general.dcl index ac5e052..6ee3b29 100644 --- a/frontend/general.dcl +++ b/frontend/general.dcl @@ -20,6 +20,8 @@ instance <<< [a] | <<< a :: Optional x = Yes !x | No +:: Choice a b = Either a | Or b + (--->) infix :: .a !b -> .a | <<< b (-?->) infix :: .a !(!Bool, !b) -> .a | <<< b diff --git a/frontend/general.icl b/frontend/general.icl index 5b3bb1a..b542268 100644 --- a/frontend/general.icl +++ b/frontend/general.icl @@ -11,6 +11,8 @@ import StdEnv :: Optional x = Yes !x | No +:: Choice a b = Either a | Or b + cMAXINT :== 2147483647 :: BITVECT :== Int diff --git a/frontend/generics.icl b/frontend/generics.icl index ffbfe14..50b5670 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -1677,15 +1677,16 @@ where gs_heaps=gs_heaps=:{hp_var_heap, hp_type_heaps}, gs_dcl_modules, gs_main_dcl_module_n, - gs_opt_dcl_icl_conversions} + gs_opt_dcl_icl_conversions, + gs_error} #! (class_def, gs_modules) = getClassDef ins_class.glob_module ins_class.glob_object.ds_index gs_modules #! (member_def, gs_modules) = getMemberDef ins_class.glob_module class_def.class_members.[0].ds_index gs_modules #! {me_type, me_class_vars} = member_def // determine type of the instance function - #! (symbol_type, _, hp_type_heaps, _, _) = - determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No No + #! (symbol_type, _, hp_type_heaps, _, gs_error) = + determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None hp_type_heaps No gs_error #! (st_context, hp_var_heap) = initializeContextVariables symbol_type.st_context hp_var_heap #! symbol_type = {symbol_type & st_context = st_context} @@ -1729,7 +1730,8 @@ where , gs_fun_defs = gs_fun_defs , gs_dcl_modules = gs_dcl_modules , gs_opt_dcl_icl_conversions = gs_opt_dcl_icl_conversions - , gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} + , gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} + , gs_error = gs_error } | otherwise // dcl module @@ -1739,6 +1741,7 @@ where & gs_modules = gs_modules , gs_dcl_modules = gs_dcl_modules , gs_heaps = {gs_heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap} + , gs_error = gs_error } update_dcl_fun_type module_index fun_index symbol_type dcl_modules diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 3218836..e72560f 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -1684,7 +1684,7 @@ where = equalTypes atype1.at_type atype2.at_type type_var_heap equalTypeVars {tv_info_ptr} temp_var_id type_var_heap - #! tv_info = sreadPtr tv_info_ptr 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 == temp_var_id, type_var_heap) diff --git a/frontend/refmark.icl b/frontend/refmark.icl index f607bc1..b77ae39 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -6,8 +6,7 @@ import syntax, Heap, typesupport, check, overloading, unitype, utilities //, RWS NotASelector :== -1 -class refMark expr :: ![[FreeVar]] !Int !(Optional [(FreeVar,ReferenceCount)]) !expr !*VarHeap -> *VarHeap - +class refMark expr :: ![[FreeVar]] !Int !(Optional [CountedFreeVar]) !expr !*VarHeap -> *VarHeap instance refMark [a] | refMark a where @@ -27,13 +26,32 @@ addSelection var_expr_ptr sel sels=:[selection=:{ su_field,su_multiply,su_unique | sel < su_field = [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] } : sels ] = [ selection : addSelection var_expr_ptr sel selections ] + +/* +saveOccurrencesWhenNeeded pattern_nr free_vars var_heap + | pattern_nr == 0 + = var_heap + = saveOccurrences free_vars var_heap +*/ saveOccurrences free_vars var_heap - = foldSt (foldSt save_occurrence) free_vars var_heap + = foldSt (foldSt save_occurrence) free_vars var_heap // (free_vars ---> ("saveOccurrences", free_vars)) var_heap where save_occurrence {fv_name,fv_info_ptr} var_heap # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = RC_Unused, occ_previous = [occ_ref_count : occ_previous] } ) +// ---> ("save_occurrence", fv_name, occ_ref_count, length occ_previous) +restoreOccurrences free_vars var_heap + = foldSt (foldSt restore_occurrence) (free_vars /* ---> ("restoreOccurrences", free_vars) */) ([], var_heap) +where + restore_occurrence fv=:{fv_name,fv_info_ptr} (occurrences, var_heap) + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous = [prev_ref_count : occ_previous]}, var_heap) = readPtr fv_info_ptr var_heap + var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = prev_ref_count, occ_previous = occ_previous }) + = case occ_ref_count of // ---> ("restore_occurrence", fv_name, prev_ref_count, occ_previous) of + RC_Unused + -> (occurrences, var_heap) + _ + -> ([{cfv_var = fv,cfv_count = occ_ref_count} : occurrences ], var_heap) adjustRefCount sel RC_Unused var_expr_ptr | sel == NotASelector @@ -48,19 +66,22 @@ adjustRefCount sel (RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}) var_exp rcu_multiply = rcu_uniquely ++ rcu_multiply = RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = rcu_selectively } -markPatternVariables sel used_pattern_vars var_heap - | sel == NotASelector - = foldSt mark_variable [ fv \\ (fv,_) <- used_pattern_vars ] var_heap - = mark_pattern_variable sel used_pattern_vars var_heap +markPatternVariables sel list_of_used_pattern_vars var_heap + = foldSt (mark_pattern_variables sel) list_of_used_pattern_vars var_heap where - mark_pattern_variable sel [] var_heap + mark_pattern_variables sel used_pattern_vars var_heap + | sel == NotASelector + = foldSt mark_variable used_pattern_vars var_heap + = mark_selected_variable sel used_pattern_vars var_heap + + mark_selected_variable sel [] var_heap = var_heap - mark_pattern_variable sel [(fv, var_number) : used_pattern_vars ] var_heap - | sel == var_number - = mark_variable fv var_heap - = mark_pattern_variable sel used_pattern_vars var_heap + mark_selected_variable sel [pv=:{pv_var, pv_arg_nr} : pvs ] var_heap + | sel == pv_arg_nr + = mark_variable pv var_heap + = mark_selected_variable sel pvs var_heap - mark_variable {fv_info_ptr} var_heap + mark_variable {pv_var={fv_info_ptr}} var_heap # (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap = case occ_ref_count of RC_Unused @@ -71,17 +92,30 @@ where rcu_selectively = [], rcu_uniquely = [] } -> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } ) +closeAndMarkBinding free_vars var_info_ptr occ_ref_count var_occ let_expr=:(Either expr) var_heap + # 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 NotASelector No expr var_heap +closeAndMarkBinding free_vars var_info_ptr occ_ref_count var_occ let_expr=:(Or ref_counts) var_heap + # var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr }) + = addRefCounts ref_counts var_heap + 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 // ---> ("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 No let_expr var_heap - OB_Pattern used_pattern_vars occ_bind - -> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })) - _ - -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }) - + var_heap = markPatternVariables sel var_occ.occ_pattern_vars var_heap + = ref_count_of_bindings free_vars var_info_ptr occ_ref_count var_occ var_heap +where + ref_count_of_bindings free_vars var_info_ptr occ_ref_count var_occ=:{occ_bind = OB_OpenLet let_expr} var_heap + = closeAndMarkBinding free_vars var_info_ptr occ_ref_count var_occ let_expr var_heap + ref_count_of_bindings free_vars var_info_ptr occ_ref_count var_occ var_heap + = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }) + +addRefCounts ref_counts var_heap + = foldSt set_occurrence ref_counts var_heap +where + set_occurrence {cfv_var = {fv_name,fv_info_ptr}, cfv_count} var_heap + # (VI_Occurrence occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap + comb_ref_count = parCombineRefCount occ_ref_count cfv_count + = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = comb_ref_count}) instance refMark BoundVar where @@ -115,9 +149,13 @@ where var_heap = refMark new_free_vars sel def let_expr var_heap = let_combine free_vars var_heap = refMark new_free_vars sel def let_expr (refMark new_free_vars NotASelector No let_strict_binds var_heap) - # 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 + # all_binds = let_strict_binds ++ let_lazy_binds + local_let_vars = [ lb_dst \\ {lb_dst} <- all_binds ] + new_free_vars = [ local_let_vars : free_vars] +// (global_let_vars, var_heap) = collectOpenLetVars free_vars var_heap + var_heap = init_let_binds all_binds var_heap +// (let_occurrences, var_heap) = ref_mark_of_lets new_free_vars local_let_vars global_let_vars all_binds var_heap +// var_heap = finish_let_binds let_occurrences var_heap = refMark new_free_vars sel def let_expr var_heap where @@ -137,10 +175,44 @@ 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 }) - 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_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src }) + init_let_binds let_binds var_heap + = foldSt bind_variable let_binds var_heap + where + 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_ref_count = RC_Unused, occ_bind = OB_OpenLet (Either lb_src) }) + + finish_let_binds let_binds var_heap + = foldSt finish_let_bind let_binds var_heap + where + finish_let_bind (let_var_ptr, occurrences) var_heap + # (VI_Occurrence occ, var_heap) = readPtr let_var_ptr var_heap + = var_heap <:= (let_var_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet (Or occurrences) }) + ref_mark_of_lets free_vars local_let_vars global_let_vars let_binds var_heap + = foldSt (ref_mark_of_let free_vars local_let_vars global_let_vars) let_binds ([], var_heap) + + ref_mark_of_let free_vars local_let_vars global_let_vars {lb_src,lb_dst={fv_info_ptr}} (all_occurrences, var_heap) + # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap + var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_LockedLet (Either lb_src) }) + var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars NotASelector No lb_src var_heap + var_heap = open_locked_lets local_let_vars var_heap + (_, var_heap) = collectUsedLetVars global_let_vars ([], var_heap) + (occurrences, var_heap) = restoreOccurrences free_vars var_heap + = ([(fv_info_ptr, occurrences) : all_occurrences], var_heap) + where + open_locked_lets let_vars var_heap + = foldSt open_locked_let let_vars var_heap + where + open_locked_let fv=:{fv_name,fv_info_ptr} var_heap + # (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap + = case var_occ.occ_bind of + OB_LockedLet expr + -> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_OpenLet expr }) + _ + -> var_heap + refMark free_vars sel def (Case kees) var_heap = refMarkOfCase free_vars sel def kees var_heap refMark free_vars sel _ (Selection _ expr selectors) var_heap @@ -219,15 +291,15 @@ collectPatternsVariables pattern_vars where collect_used_vars [ fv=:{fv_count} : pattern_vars ] arg_nr collected_vars | fv_count > 0 - = collect_used_vars pattern_vars (inc arg_nr) [ (fv, arg_nr) : collected_vars ] + = collect_used_vars pattern_vars (inc arg_nr) [ {pv_var = fv, pv_arg_nr = arg_nr} : collected_vars ] = collect_used_vars pattern_vars (inc arg_nr) collected_vars collect_used_vars [] arg_nr collected_vars = collected_vars -collectLocalLetVars free_vars var_heap - = foldSt (foldSt collect_local_let_var) free_vars ([], var_heap) +collectOpenLetVars free_vars var_heap + = foldSt (foldSt collect_open_let_var) free_vars ([], var_heap) where - collect_local_let_var fv=:{fv_info_ptr} (collected_vars, var_heap) + collect_open_let_var fv=:{fv_info_ptr} (collected_vars, var_heap) # (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap = case var_occ.occ_bind of OB_OpenLet _ @@ -241,8 +313,8 @@ where collect_local_let_var fv_info_ptr (used_vars, var_heap) # (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap = case var_occ.occ_bind of - OB_LockedLet let_expr - -> ([ fv_info_ptr : used_vars], var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_OpenLet let_expr })) + OB_LockedLet ref_counts + -> ([ fv_info_ptr : used_vars], var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_OpenLet ref_counts })) _ -> (used_vars, var_heap) @@ -252,8 +324,8 @@ where set_used_let_var fv_info_ptr var_heap # (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap = case var_occ.occ_bind of - OB_OpenLet let_expr - -> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_LockedLet let_expr }) + OB_OpenLet ref_counts + -> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_LockedLet ref_counts }) _ -> var_heap @@ -261,113 +333,110 @@ refMarkOfCase free_vars sel def {case_expr, case_guards=AlgebraicPatterns type p = refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default var_heap refMarkOfCase free_vars sel def {case_expr,case_guards=BasicPatterns type patterns,case_default,case_explicit} var_heap - # var_heap = refMark free_vars NotASelector No case_expr var_heap - (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + # (local_lets, var_heap) = collectOpenLetVars free_vars var_heap (def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets def) patterns (0, used_lets, var_heap) - = addRefMarkOfDefault False pattern_depth free_vars def used_lets var_heap + var_heap = addRefMarkOfDefault pattern_depth free_vars def used_lets var_heap + var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars NotASelector No case_expr var_heap + = caseCombine False free_vars var_heap where ref_mark_of_basic_pattern free_vars sel local_lets def {bp_expr} (pattern_depth, used_lets, var_heap) - # pattern_depth = inc pattern_depth - var_heap = saveOccurrences free_vars var_heap +// # var_heap = saveOccurrencesWhenNeeded pattern_depth free_vars var_heap + # var_heap = saveOccurrences free_vars var_heap var_heap = refMark free_vars sel def bp_expr var_heap (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) - = (pattern_depth, used_lets, var_heap) + = (inc pattern_depth, used_lets, var_heap) refMarkOfCase free_vars sel def {case_expr, case_guards=OverloadedListPatterns type _ patterns, case_explicit, case_default} var_heap = refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default var_heap refMarkOfCase free_vars sel def {case_expr,case_guards=DynamicPatterns patterns,case_default,case_explicit} var_heap - # var_heap = saveOccurrences free_vars var_heap - var_heap = refMark free_vars NotASelector No case_expr var_heap - (used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap + # (used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap var_heap = parCombine free_vars var_heap - (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + (local_lets, var_heap) = collectOpenLetVars free_vars var_heap (def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets def) patterns (0, used_lets, var_heap) - = addRefMarkOfDefault True pattern_depth free_vars def used_lets var_heap + var_heap = addRefMarkOfDefault pattern_depth free_vars def used_lets var_heap + var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars NotASelector No case_expr var_heap + = caseCombine True free_vars var_heap where ref_mark_of_dynamic_pattern free_vars sel local_lets def {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap) - # pattern_depth = inc pattern_depth - var_heap = saveOccurrences free_vars var_heap +// # var_heap = saveOccurrencesWhenNeeded pattern_depth free_vars var_heap + # var_heap = saveOccurrences free_vars var_heap used_pattern_vars = collectPatternsVariables [dp_var] - var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def dp_rhs var_heap + var_heap = refMark [ [ pv_var \\ {pv_var} <- used_pattern_vars ] : free_vars ] sel def dp_rhs var_heap (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) - = (pattern_depth, used_lets, var_heap) + = (inc pattern_depth, used_lets, var_heap) -refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default var_heap - = ref_mark_of_algebraic_case free_vars sel def case_expr patterns case_explicit case_default var_heap +refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr alternatives case_explicit case_default var_heap + # (with_pattern_bindings, var_heap) = ref_mark_of_alternatives free_vars sel def (is_variable_pattern case_expr) alternatives case_explicit case_default var_heap + = ref_mark_of_pattern free_vars with_pattern_bindings case_expr var_heap where - ref_mark_of_algebraic_case free_vars sel def (Var {var_name,var_info_ptr,var_expr_ptr}) patterns explicit defaul var_heap - # (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap - = case occ_bind of - OB_Empty - -> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap - 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 }) - var_heap = refMark free_vars sel No let_expr var_heap - -> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap - OB_LockedLet _ - -> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap - OB_Pattern vars ob - -> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap - ref_mark_of_algebraic_case free_vars sel def expr patterns explicit defaul var_heap - = ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel def expr patterns explicit defaul var_heap - - ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused} - free_vars sel def patterns case_explicit case_default var_heap - # var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel def (Yes var_info_ptr) patterns case_explicit case_default var_heap - (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap - = case var_occ.occ_ref_count of - RC_Unused - -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & - occ_ref_count = RC_Used { rcu_multiply = [], rcu_uniquely = [var_expr_ptr], rcu_selectively = [] }}) - RC_Used rcu - -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & - occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }}) - ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr - var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel def patterns case_explicit case_default var_heap - # var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]), - rcu_uniquely = [], rcu_selectively = [] }} - var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ ) - = ref_mark_of_patterns with_composite_pattern free_vars sel def (Yes var_info_ptr) patterns case_explicit case_default var_heap - - ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel def expr patterns case_explicit case_default var_heap - # var_heap = refMark free_vars NotASelector No expr var_heap - = ref_mark_of_patterns True free_vars sel def No patterns case_explicit case_default var_heap - - ref_mark_of_patterns with_composite_pattern free_vars sel def opt_pattern_var patterns case_explicit case_default var_heap - # (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + is_variable_pattern (Var {var_info_ptr}) = Yes var_info_ptr + is_variable_pattern _ = No + + ref_mark_of_pattern free_vars with_pattern_bindings (Var {var_name,var_info_ptr,var_expr_ptr}) var_heap + # (VI_Occurrence var_occ_in_alts, var_heap) = readPtr var_info_ptr var_heap + var_heap = adjust_ref_count_of_variable_pattern var_occ_in_alts var_info_ptr var_expr_ptr var_heap + var_heap = saveOccurrences free_vars var_heap + var_heap = ref_mark_of_variable_pattern free_vars var_info_ptr var_occ_in_alts var_heap +// var_heap = markPatternVariables NotASelector var_occ_in_alts.occ_pattern_vars var_heap + var_heap = caseCombine with_pattern_bindings free_vars var_heap + = var_heap + where + adjust_ref_count_of_variable_pattern var_occ_in_alts=:{occ_ref_count = RC_Unused} var_info_ptr var_expr_ptr var_heap + = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ_in_alts & + occ_ref_count = RC_Used { rcu_multiply = [], rcu_uniquely = [var_expr_ptr], rcu_selectively = [] }}) + adjust_ref_count_of_variable_pattern var_occ_in_alts=:{occ_ref_count = RC_Used rcu} var_info_ptr var_expr_ptr var_heap + = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ_in_alts & + occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }}) + + ref_mark_of_variable_pattern free_vars var_info_ptr var_occ=:{occ_bind = OB_OpenLet let_expr} var_heap + # (VI_Occurrence empty_var_occ, var_heap) = readPtr var_info_ptr var_heap + = closeAndMarkBinding free_vars var_info_ptr empty_var_occ.occ_ref_count empty_var_occ let_expr var_heap + ref_mark_of_variable_pattern _ _ _ var_heap + = var_heap + + ref_mark_of_pattern free_vars with_pattern_bindings expr var_heap + # var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars NotASelector No expr var_heap + var_heap = caseCombine with_pattern_bindings free_vars var_heap + = var_heap + + ref_mark_of_alternatives free_vars sel def opt_pattern_var patterns case_explicit case_default var_heap + # (local_lets, var_heap) = collectOpenLetVars free_vars var_heap (def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap (with_pattern_bindings, pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def) patterns (False, 0, used_lets, var_heap) - = addRefMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars def used_lets var_heap - + var_heap = addRefMarkOfDefault pattern_depth free_vars def used_lets var_heap + = (with_pattern_bindings, var_heap) + ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def {ap_vars,ap_expr} (with_pattern_bindings, pattern_depth, used_lets, var_heap) - # pattern_depth = inc pattern_depth - var_heap = saveOccurrences free_vars var_heap +// # var_heap = saveOccurrencesWhenNeeded pattern_depth free_vars var_heap + # var_heap = saveOccurrences free_vars var_heap used_pattern_vars = collectPatternsVariables ap_vars var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap - var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap // (var_heap ---> ("ref_mark_of_algebraic_pattern", ap_expr)) + var_heap = refMark [ [ pv_var \\ {pv_var} <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap var_heap = restore_binding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) - = (with_pattern_bindings || not (isEmpty used_pattern_vars), pattern_depth, used_lets, var_heap) - + = (with_pattern_bindings || not (isEmpty used_pattern_vars), inc pattern_depth, used_lets, var_heap) bind_optional_pattern_variable _ [] var_heap = var_heap bind_optional_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap - # (VI_Occurrence var_occ=:{occ_bind}, var_heap) = readPtr var_info_ptr var_heap - = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_Pattern used_pattern_vars occ_bind }) + # (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap + = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_pattern_vars = [ used_pattern_vars : var_occ.occ_pattern_vars ] }) bind_optional_pattern_variable _ used_pattern_vars var_heap = var_heap restore_binding_of_pattern_variable _ [] var_heap = var_heap restore_binding_of_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap - # (VI_Occurrence var_occ=:{occ_ref_count, occ_bind = OB_Pattern _ occ_bind}, var_heap) = readPtr var_info_ptr var_heap - = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = occ_bind}) + # (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap + = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_pattern_vars = tl var_occ.occ_pattern_vars }) restore_binding_of_pattern_variable _ used_pattern_vars var_heap = var_heap @@ -375,50 +444,27 @@ refMarkOfDefault case_explicit free_vars sel def (Yes expr) local_lets var_heap # var_heap = saveOccurrences free_vars var_heap var_heap = refMark free_vars sel No expr var_heap (used_lets, var_heap) = collectUsedLetVars local_lets ([], var_heap) - (occurrences, var_heap) = restore_occurrences free_vars var_heap + (occurrences, var_heap) = restoreOccurrences free_vars var_heap = (Yes occurrences, used_lets, var_heap) -where - restore_occurrences free_vars var_heap - = foldSt (foldSt restore_occurrence) free_vars ([], var_heap) - where - restore_occurrence fv=:{fv_name,fv_info_ptr} (occurrences, var_heap) - # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous = [prev_ref_count : occ_previous]}, var_heap) = readPtr fv_info_ptr var_heap - var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = prev_ref_count, occ_previous = occ_previous }) - = case occ_ref_count of - RC_Unused - -> (occurrences, var_heap) - _ - -> ([(fv,occ_ref_count) : occurrences ], var_heap) refMarkOfDefault case_explicit free_vars sel def No local_lets var_heap | case_explicit = (No, [], var_heap) = (def, [], var_heap) - -addRefMarkOfDefault do_par_combine pattern_depth free_vars (Yes occurrences) used_lets var_heap - # var_heap = saveOccurrences free_vars var_heap - var_heap = foldSt set_occurrence occurrences var_heap +addRefMarkOfDefault pattern_depth free_vars (Yes occurrences) used_lets var_heap +// # var_heap = saveOccurrencesWhenNeeded pattern_depth free_vars var_heap + # var_heap = saveOccurrences free_vars var_heap + var_heap = foldSt set_occurrence occurrences var_heap var_heap = setUsedLetVars used_lets var_heap - = caseCombine do_par_combine free_vars var_heap (inc pattern_depth) + = altCombine (inc pattern_depth) free_vars var_heap where - set_occurrence (fv=:{fv_name,fv_info_ptr}, ref_count) var_heap - # (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap - = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = ref_count } ) -addRefMarkOfDefault do_par_combine pattern_depth free_vars No used_lets var_heap + set_occurrence {cfv_var={fv_name,fv_info_ptr}, cfv_count} var_heap + # (VI_Occurrence old_occ, var_heap) = readPtr fv_info_ptr var_heap + = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = cfv_count } ) +addRefMarkOfDefault pattern_depth free_vars No used_lets var_heap # var_heap = setUsedLetVars used_lets var_heap - = caseCombine do_par_combine free_vars var_heap pattern_depth + = altCombine pattern_depth free_vars var_heap -/* -refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap - # pattern_depth = inc pattern_depth - var_heap = saveOccurrences free_vars var_heap - var_heap = refMark free_vars sel No (expr ---> ("refMarkOfDefault", (expr, free_vars))) var_heap - var_heap = setUsedLetVars used_lets var_heap - = caseCombine do_par_combine free_vars var_heap pattern_depth -refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap - # var_heap = setUsedLetVars used_lets var_heap - = caseCombine do_par_combine free_vars var_heap pattern_depth -*/ parCombine free_vars var_heap = foldSt (foldSt (par_combine)) free_vars var_heap @@ -428,48 +474,58 @@ where = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = parCombineRefCount occ_ref_count prev_ref_count , occ_previous = prev_counts }) +caseCombine do_par_combine free_vars var_heap + = foldSt (foldSt (case_combine do_par_combine)) free_vars var_heap // (var_heap ---> ("caseCombine", free_vars)) +where + case_combine do_par_combine {fv_name,fv_info_ptr} var_heap + # (VI_Occurrence old_occ, var_heap) = readPtr fv_info_ptr var_heap + = case old_occ.occ_previous of // ---> ("case_combine", fv_name, old_occ.occ_ref_count, length old_occ.occ_previous) of + [ref_count_in_alt , glob_ref_count : occ_previous] + # comb_ref_count = case_combine_ref_counts do_par_combine old_occ.occ_ref_count ref_count_in_alt + # comb_ref_count = parCombineRefCount comb_ref_count glob_ref_count + -> var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count , occ_previous = occ_previous }) + _ + -> abort ("inconsistent reference count administration" ---> fv_name) + + case_combine_ref_counts do_par_combine ref_count_in_pattern ref_count_in_alt + | do_par_combine + = parCombineRefCount ref_count_in_pattern ref_count_in_alt + = seqCombineRefCount ref_count_in_alt ref_count_in_pattern -caseCombine do_par_combine free_vars var_heap depth - = foldSt (foldSt (case_combine do_par_combine depth)) free_vars var_heap +altCombine depth free_vars var_heap + = foldSt (foldSt (alt_combine depth)) free_vars var_heap // (var_heap ---> ("altCombine", free_vars)) where - case_combine do_par_combine depth {fv_name,fv_info_ptr} var_heap + alt_combine depth {fv_name,fv_info_ptr} var_heap # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap - (occ_ref_count, occ_previous) = case_combine_ref_counts do_par_combine occ_ref_count occ_previous (dec depth) + (occ_ref_count, occ_previous) = alt_combine_ref_counts occ_ref_count occ_previous ((dec depth)) // ---> ("alt_combine", fv_name, occ_ref_count, length occ_previous, depth)) = var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = occ_ref_count , occ_previous = occ_previous }) -// ---> ("case_combine", fv_name, occ_ref_count) - - case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] 0 - | do_par_combine - # new_comb_ref_count = parCombineRefCount comb_ref_count occ_ref_count - = (new_comb_ref_count, occ_previous) -// ---> ("parCombineRefCount", ("this:", comb_ref_count), ("prev:", occ_ref_count), ("new:", new_comb_ref_count)) - # new_comb_ref_count = seqCombineRefCount comb_ref_count occ_ref_count - = (new_comb_ref_count, occ_previous) -// ---> ("seqCombineRefCount", ("this:", comb_ref_count), ("prev:", occ_ref_count), ("new:", new_comb_ref_count)) - case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] depth - # new_comb_ref_count = case_combine_ref_count comb_ref_count occ_ref_count - = case_combine_ref_counts do_par_combine new_comb_ref_count occ_previous (dec depth) -// ---> ("case_combine_ref_count", comb_ref_count, occ_ref_count, new_comb_ref_count) - - case_combine_ref_count RC_Unused ref_count + + alt_combine_ref_counts comb_ref_count ref_counts 0 + = (comb_ref_count, ref_counts) + alt_combine_ref_counts comb_ref_count [occ_ref_count:occ_previous] depth + # new_comb_ref_count = alt_combine_ref_count comb_ref_count occ_ref_count + = alt_combine_ref_counts new_comb_ref_count occ_previous (dec depth) +// ---> ("alt_combine_ref_count", comb_ref_count, occ_ref_count, new_comb_ref_count) + + alt_combine_ref_count RC_Unused ref_count = ref_count - case_combine_ref_count ref_count RC_Unused + alt_combine_ref_count ref_count RC_Unused = ref_count - case_combine_ref_count (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2) + alt_combine_ref_count (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2) = RC_Used { rcu_uniquely = rcu_uniquely ++ ref_count2.rcu_uniquely, rcu_multiply = rcu_multiply ++ ref_count2.rcu_multiply, - rcu_selectively = case_combine_of_selections rcu_selectively ref_count2.rcu_selectively } + rcu_selectively = alt_combine_of_selections rcu_selectively ref_count2.rcu_selectively } where - case_combine_of_selections [] sels + alt_combine_of_selections [] sels = sels - case_combine_of_selections sels [] + alt_combine_of_selections sels [] = sels - case_combine_of_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2] + alt_combine_of_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2] | su_field == sel2.su_field # sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply, su_uniquely = sel2.su_uniquely ++ su_uniquely } - = [ sel1 : case_combine_of_selections sels1 sels2 ] + = [ sel1 : alt_combine_of_selections sels1 sels2 ] | su_field < sel2.su_field - = [sel1 : case_combine_of_selections sels1 sl2 ] - = [sel2 : case_combine_of_selections sl1 sels2 ] + = [sel1 : alt_combine_of_selections sels1 sl2 ] + = [sel2 : alt_combine_of_selections sl1 sels2 ] parCombineRefCount RC_Unused ref_count = ref_count @@ -525,10 +581,18 @@ seqCombineRefCount (RC_Used sec_ref) (RC_Used prim_ref) = [ { sel & su_multiply = su_uniquely ++ su_multiply, su_uniquely = [] } : make_primary_selections_on_unique sels ] make_primary_selections_on_unique [] = [] -/* -makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} v:{# v:{# TypeDefInfo}} !*VarHeap !*ExpressionHeap !*ErrorAdmin - -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !v:{# v:{# TypeDefInfo}}, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) -*/ + +emptyOccurrence observing = + { occ_ref_count = RC_Unused + , occ_previous = [] + , occ_observing = observing + , 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 @@ -543,7 +607,7 @@ where coercion_env subst type_def_infos var_heap expr_heap error # 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 No tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb)) var_heap + var_heap = refMark [tb_args] NotASelector No tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, 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) @@ -555,10 +619,9 @@ 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 - #! occ_observing = has_observing_base_type var_info type_def_infos subst - = (subst, type_def_infos, - var_heap <:= (fv_info_ptr, VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [], - occ_observing = occ_observing, occ_bind = OB_Empty }), 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_base_type (VI_Type {at_type} _) type_def_infos subst = has_observing_type at_type type_def_infos subst diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index f85a457..5437bfb 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -949,32 +949,42 @@ instance toString KindInfo /* A few obscure type definitions */ +:: PatternVar = + { pv_var :: !FreeVar + , pv_arg_nr :: !Int + } + :: Occurrence = - { occ_ref_count :: !ReferenceCount -// , occ_aliases :: ![[(FreeVar,Int)]] -// , occ_expression :: !Expression - , occ_bind :: !OccurrenceBinding - , occ_observing :: !Bool -// , occ_attribute :: !ExprInfoPtr - , occ_previous :: ![ReferenceCount] + { occ_ref_count :: !ReferenceCount + , occ_bind :: !OccurrenceBinding + , occ_pattern_vars :: ![[PatternVar]] + , occ_observing :: !Bool + , occ_previous :: ![ReferenceCount] } :: ReferenceCount = RC_Used !RC_Used | RC_Unused -:: SelectiveUse = { su_field :: !Int, su_multiply :: ![ExprInfoPtr], su_uniquely :: ![ExprInfoPtr] } - -:: RC_Used = { rcu_multiply :: ![ExprInfoPtr], rcu_selectively :: ![SelectiveUse], rcu_uniquely :: ![ExprInfoPtr] } +:: SelectiveUse = + { su_field :: !Int + , su_multiply :: ![ExprInfoPtr] + , su_uniquely :: ![ExprInfoPtr] + } -:: OccurrenceBinding = OB_Empty | OB_OpenLet !Expression | OB_LockedLet !Expression - | OB_Pattern ![(FreeVar, Int)] !OccurrenceBinding -// | OB_Closed !LetOccurrences | OB_Marked !LetOccurrences +:: RC_Used = + { rcu_multiply :: ![ExprInfoPtr] + , rcu_selectively :: ![SelectiveUse] + , rcu_uniquely :: ![ExprInfoPtr] + } -/* -:: LetOccurrences = - { lo_used_lets :: ![FreeVar] - , lo_free_variables :: ![(FreeVar, ReferenceCount)] +:: CountedFreeVar = + { cfv_var :: !FreeVar + , cfv_count :: !ReferenceCount } -*/ + +:: OccurrenceBinding = OB_Empty + | OB_OpenLet (Choice Expression [CountedFreeVar]) + | OB_LockedLet (Choice Expression [CountedFreeVar]) + :: OptGuardedAlts = GuardedAlts ![GuardedExpr] !(Optional ExprWithLocalDefs) | UnGuardedExpr !ExprWithLocalDefs diff --git a/frontend/syntax.icl b/frontend/syntax.icl index ec1de27..63d0a91 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -927,21 +927,44 @@ cNotVarNumber :== -1 :: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] | KindCycle +:: PatternVar = + { pv_var :: !FreeVar + , pv_arg_nr :: !Int + } + :: Occurrence = - { occ_ref_count :: !ReferenceCount - , occ_bind :: !OccurrenceBinding - , occ_observing :: !Bool - , occ_previous :: ![ReferenceCount] + { occ_ref_count :: !ReferenceCount + , occ_bind :: !OccurrenceBinding + , occ_pattern_vars :: ![[PatternVar]] + , occ_observing :: !Bool + , occ_previous :: ![ReferenceCount] } :: ReferenceCount = RC_Used !RC_Used | RC_Unused -:: SelectiveUse = { su_field :: !Int, su_multiply :: ![ExprInfoPtr], su_uniquely :: ![ExprInfoPtr] } +:: SelectiveUse = + { su_field :: !Int + , su_multiply :: ![ExprInfoPtr] + , su_uniquely :: ![ExprInfoPtr] + } + +:: RC_Used = + { rcu_multiply :: ![ExprInfoPtr] + , rcu_selectively :: ![SelectiveUse] + , rcu_uniquely :: ![ExprInfoPtr] + } -:: RC_Used = { rcu_multiply :: ![ExprInfoPtr], rcu_selectively :: ![SelectiveUse], rcu_uniquely :: ![ExprInfoPtr] } +:: CountedFreeVar = + { cfv_var :: !FreeVar + , cfv_count :: !ReferenceCount + } -:: OccurrenceBinding = OB_Empty | OB_OpenLet !Expression | OB_LockedLet !Expression - | OB_Pattern ![(FreeVar, Int)] !OccurrenceBinding +:: OccurrenceBinding = OB_Empty + | OB_OpenLet (Choice Expression [CountedFreeVar]) + | OB_LockedLet (Choice Expression [CountedFreeVar]) +// | OB_OpenLet !Expression | OB_LockedLet !Expression +// | OB_Pattern ![PatternVar] !OccurrenceBinding +// | OB_Closed !LetOccurrences | OB_Marked !LetOccurrences :: TypeDefInfo = { tdi_kinds :: ![TypeKind] diff --git a/frontend/trans.icl b/frontend/trans.icl index 599424b..2412c7b 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -86,7 +86,7 @@ where close_group :: !Int ![Int] !*{# Int} ![Int] !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, ![Int], !*{# FunDef}) close_group fun_index [d:ds] marks group max_fun_nr group_number fun_defs # marks = { marks & [d] = max_fun_nr } - #! fd = fun_defs.[d] + # (fd,fun_defs) = fun_defs![d] # fun_defs = { fun_defs & [d] = { fd & fun_info.fi_group_index = group_number }} | d == fun_index = (ds, marks, [d : group], fun_defs) diff --git a/frontend/type.icl b/frontend/type.icl index 6160182..ff279bd 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1940,8 +1940,8 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de (type_error, fun_defs, predef_symbols, special_instances, {ts_td_infos,ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps, ts_out}) = type_instances list_inferred_types specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances, { ts & ts_fun_env = ts_fun_env }) - (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,type_code_instances,predef_symbols,ts_type_heaps) - = create_special_instances special_instances fun_env_size ti_common_defs fun_defs predef_symbols ts_type_heaps + (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,type_code_instances,predef_symbols,ts_type_heaps,ts_error) + = create_special_instances special_instances fun_env_size ti_common_defs fun_defs predef_symbols ts_type_heaps ts_error array_and_list_instances = { ali_array_first_instance_indices=array_first_instance_indices, ali_list_first_instance_indices=list_first_instance_indices, @@ -2360,7 +2360,7 @@ where type_of (UncheckedType tst) = tst type_of (SpecifiedType _ _ tst) = tst - create_special_instances {si_array_instances,si_list_instances,si_tail_strict_list_instances,si_next_array_member_index,si_next_TC_member_index,si_TC_instances} fun_env_size common_defs fun_defs predef_symbols type_heaps + create_special_instances {si_array_instances,si_list_instances,si_tail_strict_list_instances,si_next_array_member_index,si_next_TC_member_index,si_TC_instances} fun_env_size common_defs fun_defs predef_symbols type_heaps error # fun_defs = add_extra_elements_to_fun_def_array (si_next_array_member_index-fun_env_size) fun_defs with add_extra_elements_to_fun_def_array n_new_elements fun_defs @@ -2369,43 +2369,47 @@ where # dummy_fun_def = { fun_symb = {id_name="",id_info=nilPtr},fun_arity=0,fun_priority=NoPrio,fun_body=NoBody,fun_type=No,fun_pos=NoPos, fun_kind=FK_DefOrImpUnknown,fun_lifted=0,fun_info = {fi_calls=[],fi_group_index=0,fi_def_level=NotALevel,fi_free_vars=[],fi_local_vars=[],fi_dynamics=[],fi_properties=0}} = {createArray (size fun_defs+n_new_elements) dummy_fun_def & [i]=fun_defs.[i] \\ i<-[0..size fun_defs-1]} - (array_first_instance_indices,fun_defs, predef_symbols, type_heaps) = convert_array_instances si_array_instances common_defs fun_defs predef_symbols type_heaps - (list_first_instance_indices,fun_defs, predef_symbols, type_heaps) = convert_list_instances si_list_instances PD_UListClass common_defs fun_defs predef_symbols type_heaps - (tail_strict_list_first_instance_indices,fun_defs, predef_symbols, type_heaps) = convert_list_instances si_tail_strict_list_instances PD_UTSListClass common_defs fun_defs predef_symbols type_heaps + (array_first_instance_indices,fun_defs, predef_symbols, type_heaps, error) + = convert_array_instances si_array_instances common_defs fun_defs predef_symbols type_heaps error + (list_first_instance_indices,fun_defs, predef_symbols, type_heaps, error) + = convert_list_instances si_list_instances PD_UListClass common_defs fun_defs predef_symbols type_heaps error + (tail_strict_list_first_instance_indices,fun_defs, predef_symbols, type_heaps, error) + = convert_list_instances si_tail_strict_list_instances PD_UTSListClass common_defs fun_defs predef_symbols type_heaps error type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = gtci_type \\ {gtci_index, gtci_type} <- si_TC_instances} array_first_instance_indices = first_instance_indices si_array_instances - = (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,type_code_instances,predef_symbols,type_heaps) + = (array_first_instance_indices,list_first_instance_indices,tail_strict_list_first_instance_indices,fun_defs,type_code_instances,predef_symbols,type_heaps,error) where - convert_array_instances array_instances common_defs fun_defs predef_symbols type_heaps + convert_array_instances array_instances common_defs fun_defs predef_symbols type_heaps error | isEmpty array_instances - = ([],fun_defs, predef_symbols, type_heaps) + = ([],fun_defs, predef_symbols, type_heaps, error) # ({pds_ident,pds_module,pds_def},predef_symbols) = predef_symbols![PD_UnboxedArrayType] unboxed_array_type = TA (MakeTypeSymbIdent { glob_object = pds_def, glob_module = pds_module } pds_ident 0) [] ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_ArrayClass] {class_members} = common_defs.[pds_module].com_class_defs.[pds_def] array_members = common_defs.[pds_module].com_member_defs (offset_table, _, predef_symbols) = arrayFunOffsetToPD_IndexTable array_members predef_symbols - (fun_defs, type_heaps) = foldSt (convert_array_instance class_members array_members unboxed_array_type offset_table) array_instances (fun_defs, type_heaps) + (fun_defs, type_heaps, error) = foldSt (convert_array_instance class_members array_members unboxed_array_type offset_table) array_instances (fun_defs, type_heaps, error) array_first_instance_indices = first_instance_indices array_instances - = (array_first_instance_indices,fun_defs, predef_symbols, type_heaps) + = (array_first_instance_indices,fun_defs, predef_symbols, type_heaps, error) where - convert_array_instance class_members array_members unboxed_array_type offset_table {ai_record,ai_members} funs_and_heaps - = create_instance_types class_members array_members unboxed_array_type offset_table (TA ai_record []) (size class_members) funs_and_heaps + convert_array_instance class_members array_members unboxed_array_type offset_table {ai_record,ai_members} funs_heaps_and_error + = create_instance_types class_members array_members unboxed_array_type offset_table (TA ai_record []) (size class_members) funs_heaps_and_error where first_instance_index=ai_members.[0].ds_index - create_instance_types :: {#DefinedSymbol} {#MemberDef} Type {#Int} Type !Int !*(*{#FunDef},*TypeHeaps) -> (!*{#FunDef},!*TypeHeaps); - create_instance_types members array_members unboxed_array_type offset_table record_type member_index funs_and_heaps + create_instance_types :: {#DefinedSymbol} {#MemberDef} Type {#Int} Type !Int !(!*{#FunDef}, !*TypeHeaps, !*ErrorAdmin) + -> (!*{#FunDef}, !*TypeHeaps, !*ErrorAdmin); + create_instance_types members array_members unboxed_array_type offset_table record_type member_index funs_heaps_and_error | member_index == 0 - = funs_and_heaps + = funs_heaps_and_error # member_index = dec member_index - funs_and_heaps = create_instance_type members array_members unboxed_array_type offset_table record_type member_index funs_and_heaps - = create_instance_types members array_members unboxed_array_type offset_table record_type member_index funs_and_heaps + funs_heaps_and_error = create_instance_type members array_members unboxed_array_type offset_table record_type member_index funs_heaps_and_error + = create_instance_types members array_members unboxed_array_type offset_table record_type member_index funs_heaps_and_error - create_instance_type members array_members unboxed_array_type offset_table record_type member_index (fun_defs, type_heaps) + create_instance_type members array_members unboxed_array_type offset_table record_type member_index (fun_defs, type_heaps, error) # {me_type,me_symb,me_class_vars,me_pos} = array_members.[members.[member_index].ds_index] - (instance_type, _, type_heaps, _, _) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [], - it_types = [unboxed_array_type, record_type]} SP_None type_heaps No No + (instance_type, _, type_heaps, _, error) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [], + it_types = [unboxed_array_type, record_type]} SP_None type_heaps No error instance_type = makeElemTypeOfArrayFunctionStrict instance_type member_index offset_table fun_index = first_instance_index+member_index fun = @@ -2419,35 +2423,36 @@ where , fun_lifted = 0 , fun_info = EmptyFunInfo } - = ({fun_defs & [fun_index]=fun},type_heaps) + = ({fun_defs & [fun_index]=fun}, type_heaps, error) - convert_list_instances list_instances predef_list_class_index common_defs fun_defs predef_symbols type_heaps + convert_list_instances list_instances predef_list_class_index common_defs fun_defs predef_symbols type_heaps error | isEmpty list_instances - = ([],fun_defs, predef_symbols, type_heaps) + = ([],fun_defs, predef_symbols, type_heaps, error) # ({pds_module,pds_def},predef_symbols) = predef_symbols![predef_list_class_index] {class_members} = common_defs.[pds_module].com_class_defs.[pds_def] list_members = common_defs.[pds_module].com_member_defs - (fun_defs, type_heaps) = foldSt (convert_list_instance class_members list_members) list_instances (fun_defs, type_heaps) + (fun_defs, type_heaps, error) = foldSt (convert_list_instance class_members list_members) list_instances (fun_defs, type_heaps, error) list_first_instance_indices = first_instance_indices list_instances - = (list_first_instance_indices,fun_defs, predef_symbols, type_heaps) + = (list_first_instance_indices,fun_defs, predef_symbols, type_heaps, error) where - convert_list_instance class_members list_members {ai_record,ai_members} funs_and_heaps - = create_instance_types class_members list_members (TA ai_record []) (size class_members) funs_and_heaps + convert_list_instance class_members list_members {ai_record,ai_members} funs_heaps_and_error + = create_instance_types class_members list_members (TA ai_record []) (size class_members) funs_heaps_and_error where first_instance_index=ai_members.[0].ds_index - create_instance_types :: {#DefinedSymbol} {#MemberDef} Type !Int !*(*{#FunDef},*TypeHeaps) -> (!*{#FunDef},!*TypeHeaps); - create_instance_types members list_members record_type member_index funs_and_heaps + create_instance_types :: {#DefinedSymbol} {#MemberDef} Type !Int !(!*{#FunDef}, !*TypeHeaps, !*ErrorAdmin) + -> (!*{#FunDef}, !*TypeHeaps, !*ErrorAdmin) + create_instance_types members list_members record_type member_index funs_heaps_and_error | member_index == 0 - = funs_and_heaps + = funs_heaps_and_error # member_index = dec member_index - funs_and_heaps = create_instance_type members list_members record_type member_index funs_and_heaps - = create_instance_types members list_members record_type member_index funs_and_heaps + funs_heaps_and_error = create_instance_type members list_members record_type member_index funs_heaps_and_error + = create_instance_types members list_members record_type member_index funs_heaps_and_error - create_instance_type members list_members record_type member_index (fun_defs, type_heaps) + create_instance_type members list_members record_type member_index (fun_defs, type_heaps, error) # {me_type,me_symb,me_class_vars,me_pos} = list_members.[members.[member_index].ds_index] - (instance_type, _, type_heaps, _, _) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [], - it_types = [record_type]} SP_None type_heaps No No + (instance_type, _, type_heaps, _, error) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [], + it_types = [record_type]} SP_None type_heaps No error fun_index = first_instance_index+member_index fun = { fun_symb = me_symb @@ -2460,7 +2465,7 @@ where , fun_lifted = 0 , fun_info = EmptyFunInfo } - = ({fun_defs & [fun_index]=fun},type_heaps) + = ({fun_defs & [fun_index]=fun}, type_heaps, error) first_instance_indices instances = [ai_members.[0].ds_index \\ {ai_members}<-instances] diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index f458dc5..d7aa529 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -391,7 +391,7 @@ where = iFoldSt determine_type_var 0 to_index (all_vars, var_env) where determine_type_var var_index (all_vars, var_env) - #! type = var_env.[var_index] + # (type, var_env) = var_env![var_index] = case type of TV var -> ([var : all_vars], { var_env & [var_index] = TLifted var}) @@ -471,7 +471,7 @@ where build_attribute_environment appears_in_lifted_part attr_group_index max_attr_nr coercions attr_env attr_vars inequalities error | attr_group_index == max_attr_nr = (attr_env, attr_vars, inequalities, error) - #! attr = attr_env.[attr_group_index] + # (attr, attr_env) = attr_env![attr_group_index] = case attr of TA_Var attr_var # (ok, attr_env, inequalities) @@ -494,7 +494,7 @@ where = build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var left coercions attr_env inequalities (ok2, attr_env, inequalities) = build_inequalities appears_in_lifted_part off_appears_in_lifted_part off_var right coercions attr_env inequalities - #! attr = attr_env.[dem_attr] + # (attr, attr_env) = attr_env![dem_attr] = case attr of TA_Var attr_var | is_new_inequality attr_var off_var inequalities @@ -889,7 +889,7 @@ where where equi_attrs attr=:(TA_Var {av_info_ptr}) (TA_TempVar av_number) attr_var_heap - #! av_info = sreadPtr av_info_ptr attr_var_heap + # (av_info, attr_var_heap) = readPtr av_info_ptr attr_var_heap = case av_info of AVI_Forward forw_var_number -> (forw_var_number == av_number, attr_var_heap) diff --git a/frontend/unitype.icl b/frontend/unitype.icl index 3850467..4db67cd 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -232,7 +232,7 @@ adjustPropClass prop_class arity :== prop_class >> arity liftTempTypeVariable :: !{# CommonDefs } !{# BOOLVECT } !TempVarId !*{! Type} !*LiftState -> (!Bool, !Type, !*{! Type}, !*LiftState) liftTempTypeVariable modules cons_vars tv_number subst ls - #! type = subst.[tv_number] + # (type, subst) = subst![tv_number] = case type of TE -> (False, TempV tv_number, subst, ls) @@ -419,7 +419,7 @@ where expandTempTypeVariable :: !TempVarId !*(!u:{! Type}, !*ExpansionState) -> (!Bool, !Type, !*(!u:{! Type}, !*ExpansionState)) expandTempTypeVariable tv_number (subst, es) - #! type = subst.[tv_number] + # (type, subst) = subst![tv_number] = case type of TE -> (False, TempV tv_number, (subst, es)) |