Commit b7808f42 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Bug fixes: reference count analysis fixed,

Universally quantified types used in class members
parent b96dacd5
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -11,6 +11,8 @@ import StdEnv
:: Optional x =