Skip to content

GitLab

Commit 9fcae5c3 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Bug fix: uniqueness error in records

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