Skip to content
GitLab
Commit 725dc4d8 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Removed bugs in analysis of abstract data types and adjusted typing of record updates

parent e0c8f1db
Hide whitespace changes
Inline Side-by-side
frontend/analtypes.icl
View file @ 725dc4d8
......@@ -334,6 +334,7 @@ kindInfoToKind kind_info kind_heap
:: TypeProperties :== BITVECT
combineTypeProperties prop1 prop2 :== (combineHyperstrictness prop1 prop2) bitor (combineCoercionProperties prop1 prop2)
addHyperstrictness prop1 prop2 :== prop1 bitor (combineHyperstrictness prop1 prop2)
condCombineTypeProperties has_root_attr prop1 prop2
| has_root_attr
......@@ -381,7 +382,8 @@ analTypes_for_TA type_name glob_module glob_object type_arity types has_root_att
# (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, type_properties, conds_as)
= (kind, addHyperstrictness type_properties tdi_properties, conds_as)
= (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
......@@ -547,13 +549,14 @@ where
| is_abstract_type
= as
# (type_properties, conds, as) = foldSt (anal_type_def modules) group (cIsHyperStrict, { con_top_var_binds = [], con_var_binds = [] }, as)
as = foldSt (check_dcl_properties modules dcl_types dcl_mod_index type_properties) group as
(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
kinds_in_group kind_var_store as_kind_heap as_td_infos
= { as & as_kind_heap = as_kind_heap, as_td_infos = 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
= as
init_type_def_infos modules gi=:{gi_module,gi_index} (is_abstract_type, type_def_infos, as_type_var_heap, kind_heap)
# {td_args,td_rhs} = modules.[gi_module].com_type_defs.[gi_index]
......@@ -673,31 +676,37 @@ where
check_dcl_properties modules dcl_types dcl_mod_index properties {gi_module, gi_index} as
| gi_module == dcl_mod_index && gi_index < size dcl_types
# {td_rhs} = dcl_types.[gi_index]
# {td_name, td_rhs, td_args, td_pos} = dcl_types.[gi_index]
= case td_rhs of
AbstractType spec_properties
| equivalent_properties 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 as.as_type_var_heap as.as_td_infos as.as_error
= {as & as_type_var_heap = as_type_var_heap, as_td_infos = as_td_infos, as_error = as_error}
# as_error = checkError "abstract type properties conflict with derived properties in implementation module" "" as.as_error
= { as & as_error = as_error }
# as_error = pushErrorAdmin (newPosition td_name td_pos) as.as_error
| check_coercibility spec_properties properties
// ---> ("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 & 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
= { as & as_error = popErrorAdmin as_error }
# as_error = checkError "abstract type as defined in the implementation module is not coercible" "" as_error
= { as & as_error = popErrorAdmin as_error }
_
= as
= as
where
equivalent_properties icl_props dcl_props
| icl_props bitand cIsNonCoercible > 0 && dcl_props bitand cIsNonCoercible == 0
= False
| dcl_props bitand cIsHyperStrict > 0 && icl_props bitand cIsHyperStrict == 0
= False
= True
check_coercibility dcl_props icl_props
= dcl_props bitand cIsNonCoercible > 0 || icl_props bitand cIsNonCoercible == 0
check_hyperstrictness dcl_props icl_props
= dcl_props bitand cIsHyperStrict == 0 || icl_props bitand cIsHyperStrict > 0
check_possitive_sign mod_index type_index modules type_var_heap type_def_infos error
# (signs, type_var_heap, type_def_infos) = signClassification mod_index type_index [] modules type_var_heap type_def_infos
check_possitive_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 mod_index type_index top_signs modules type_var_heap type_def_infos
| signs.sc_neg_vect == 0
= (type_var_heap, type_def_infos, error)
# error = checkError "abstract type properties conflict with derived properties in implementation module" "" error
# error = checkError "signs of abstract type variables should be positive" "" error
= (type_var_heap, type_def_infos, error)
......
frontend/analunitypes.icl
View file @ 725dc4d8
......@@ -132,7 +132,7 @@ where
collect_sign_class_of_type_def group_nr signs_of_group_vars ci {gi_module,gi_index} (sign_requirements, type_var_heap, td_infos)
# ({tdi_group_vars,tdi_kinds,tdi_index_in_group},td_infos) = td_infos![gi_module].[gi_index]
{td_name,td_args,td_rhs} = ci.[gi_module].com_type_defs.[gi_index]
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, (glob_module, glob_object), tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
(rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args tdi_group_vars tdi_kinds signs_of_group_vars ([], type_var_heap)
(sign_env, scs) = sign_class_of_type_def gi_module td_rhs group_nr ci
{scs_type_var_heap = type_var_heap, scs_type_def_infos = td_infos, scs_rec_appls = [] }
......
frontend/syntax.dcl
View file @ 725dc4d8
......@@ -603,7 +603,12 @@ pIsSafe :== True
from convertDynamics import :: TypeCodeVariableInfo, :: DynamicValueAliasInfo
:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType !(Optional CoercionPosition) |
:: VI_TypeInfo = VITI_Empty
| VITI_Coercion CoercionPosition
| VITI_PatternType [AType] VI_TypeInfo
//:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType !(Optional CoercionPosition) |
:: VarInfo = VI_Empty | VI_Type !AType !VI_TypeInfo | VI_FAType ![ATypeVar] !AType !VI_TypeInfo |
VI_Occurrence !Occurrence | VI_UsedVar !Ident |
VI_Expression !Expression | VI_Variable !Ident !VarInfoPtr | VI_LiftedVariable !VarInfoPtr |
VI_Count !Int /* the reference count of a variable */ !Bool /* true if the variable is global, false otherwise */ |
......
frontend/type.icl
View file @ 725dc4d8
......@@ -787,7 +787,7 @@ freshOverloadedListType (OverloadedList _ stdStrictLists_index decons_u_index ni
cWithFreshContextVars :== True
cWithoutFreshContextVars :== False
freshSymbolType :: !(Optional CoercionPosition) !Bool !SymbolType {#u:CommonDefs} !*TypeState -> (!TempSymbolType,!*TypeState)
//freshSymbolType :: !(Optional CoercionPosition) !Bool !SymbolType {#u:CommonDefs} !*TypeState -> (!TempSymbolType,!*TypeState)
freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_env,st_arity} common_defs
ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_var_heap,ts_cons_variables,ts_exis_variables}
# (th_vars, ts_var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store)
......@@ -910,7 +910,7 @@ addToExistentialVariables pos new_exis_variables exis_variables
= [(pos, new_exis_variables) : exis_variables]
freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo);
//freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo);
freshInequality {ai_demanded,ai_offered} attr_heap
# (av_dem_info, attr_heap) = readPtr ai_demanded.av_info_ptr attr_heap
(av_off_info, attr_heap) = readPtr ai_offered.av_info_ptr attr_heap
......@@ -1349,7 +1349,8 @@ where
requirements_of_guarded_expressions (AlgebraicPatterns alg_type patterns) ti=:{ti_common_defs} match_expr pattern_type opt_pattern_ptr
goal_type (reqs, ts)
# (cons_types, result_type, new_attr_env, ts) = freshAlgebraicType alg_type patterns ti_common_defs ts
(used_cons_types, (reqs, ts)) = requirements_of_algebraic_patterns ti patterns cons_types goal_type [] (reqs, ts)
ts_var_heap = update_case_variable match_expr cons_types ts.ts_var_heap
(used_cons_types, (reqs, ts)) = requirements_of_algebraic_patterns ti patterns cons_types goal_type [] (reqs, { ts & ts_var_heap = ts_var_heap } )
ts_expr_heap = storeAttribute opt_pattern_ptr result_type.at_attribute ts.ts_expr_heap
(position, ts_var_heap) = getPositionOfExpr match_expr ts.ts_var_heap
= (reverse used_cons_types, ({ reqs & req_type_coercions = [{tc_demanded = result_type,tc_offered = pattern_type, tc_position = position,
......@@ -1430,7 +1431,7 @@ where
requirements_of_dynamic_pattern dyn_type dyn_context dyn_expr_ptr type_code_symbol
ti goal_type {dp_var={fv_info_ptr},dp_rhs} (reqs, ts=:{ts_expr_heap, ts_var_heap})
# ts_var_heap = addToBase fv_info_ptr dyn_type No ts_var_heap
# ts_var_heap = addToBase fv_info_ptr dyn_type VITI_Empty ts_var_heap
(dp_rhs_type, opt_expr_ptr, (reqs, ts)) = requirements ti dp_rhs (reqs, { ts & ts_expr_heap = ts_expr_heap, ts_var_heap = ts_var_heap })
ts_expr_heap = storeAttribute opt_expr_ptr dp_rhs_type.at_attribute ts.ts_expr_heap
type_coercion = { tc_demanded = goal_type, tc_offered = dp_rhs_type, tc_position = CP_Expression dp_rhs, tc_coercible = True }
......@@ -1454,6 +1455,20 @@ where
ts_expr_heap = storeAttribute opt_expr_ptr res_type.at_attribute ts.ts_expr_heap
= ({ reqs & req_type_coercions = [ { tc_demanded = goal_type, tc_offered = res_type, tc_position = CP_Expression expr, tc_coercible = True } : reqs.req_type_coercions] },
{ ts & ts_expr_heap = ts_expr_heap })
update_case_variable (Var {var_name,var_info_ptr,var_expr_ptr}) [cons_types] var_heap
# (var_info, var_heap) = readPtr var_info_ptr var_heap
// ---> ("update_case_variable 1", var_name, cons_types)
= case var_info of
VI_Type type type_info
-> var_heap <:= (var_info_ptr, VI_Type type (VITI_PatternType cons_types type_info))
VI_FAType vars type type_info
-> var_heap <:= (var_info_ptr, VI_FAType vars type (VITI_PatternType cons_types type_info))
_
-> abort "update_case_variable" // ---> (var_name <<- var_info))
update_case_variable expr cons_types var_heap
= var_heap
// ---> ("update_case_variable 2", expr, cons_types)
instance requirements Let
where
......@@ -1469,7 +1484,7 @@ where
make_base [{lb_src, lb_dst={fv_name, fv_info_ptr}}:bs] var_types ts=:{ts_var_heap}
# (v, ts) = freshAttributedVariable ts
optional_position = if (is_rare_name fv_name) (Yes (CP_Expression lb_src)) No
optional_position = if (is_rare_name fv_name) (VITI_Coercion (CP_Expression lb_src)) VITI_Empty
= make_base bs [v:var_types] { ts & ts_var_heap = writePtr fv_info_ptr (VI_Type v optional_position) ts.ts_var_heap }
make_base [] var_types ts
= (var_types, ts)
......@@ -1631,14 +1646,15 @@ where
requirements ti (RecordUpdate {glob_module,glob_object={ds_index,ds_arity}} expression expressions) (reqs, ts)
# cp = CP_Expression expression
(lhs, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts
(rhs, ts) = standardRhsConstructorType cp ds_index glob_module ds_arity ti ts
(expression_type, opt_expr_ptr, reqs_ts) = requirements ti expression (reqs, ts)
(reqs, ts) = requirements_of_fields ti expression expressions rhs.tst_args lhs.tst_args reqs_ts
ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr lhs.tst_result.at_attribute ts.ts_expr_heap }
coercion = { tc_demanded = lhs.tst_result, tc_offered = expression_type, tc_position = CP_Expression expression, tc_coercible = True }
= (rhs.tst_result, No, ({ reqs & req_attr_coercions = rhs.tst_attr_env ++ lhs.tst_attr_env ++ reqs.req_attr_coercions,
req_type_coercions = [ coercion : reqs.req_type_coercions ]}, ts))
(lhs_args, reqs_ts) = determine_record_type cp ds_index glob_module ds_arity ti expression expression_type opt_expr_ptr reqs_ts
(reqs, ts) = requirements_of_fields ti expression expressions rhs.tst_args lhs_args reqs_ts
// ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr lhs_result.at_attribute ts.ts_expr_heap }
// coercion = { tc_demanded = lhs_result, tc_offered = expression_type, tc_position = CP_Expression expression, tc_coercible = True }
// = (rhs.tst_result, No, ({ reqs & req_attr_coercions = rhs.tst_attr_env ++ lhs_attr_env ++ reqs.req_attr_coercions, ts))
= (rhs.tst_result, No, ({ reqs & req_attr_coercions = rhs.tst_attr_env ++ reqs.req_attr_coercions }, ts))
// req_type_coercions = [ coercion : reqs.req_type_coercions ]}, ts))
where
requirements_of_fields ti expression [] _ _ reqs_ts
= reqs_ts
......@@ -1655,6 +1671,28 @@ where
ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr dem_field_type.at_attribute ts.ts_expr_heap }
coercion = { tc_demanded = dem_field_type, tc_offered = expr_type, tc_position = CP_Expression bind_src, tc_coercible = True }
= ({ reqs & req_type_coercions = [ coercion : reqs.req_type_coercions ]}, ts)
determine_record_type cp cons_index mod_index arity ti (Var var) expression_type opt_expr_ptr (reqs, ts=:{ts_var_heap})
# (type_info, ts_var_heap) = getTypeInfoOfVariable var ts_var_heap
ts = { ts & ts_var_heap = ts_var_heap}
= case type_info of
VITI_PatternType arg_types _
-> (arg_types, (reqs, ts))
// ---> ("determine_record_type (Yes)", result_type, arg_types)
_
-> new_lhs_constructor_type cp cons_index mod_index arity ti expression_type opt_expr_ptr (reqs, ts)
// ---> ("determine_record_type (No) 1")
determine_record_type cp cons_index mod_index arity ti _ expression_type opt_expr_ptr reqs_ts
= new_lhs_constructor_type cp cons_index mod_index arity ti expression_type opt_expr_ptr reqs_ts
// ---> ("determine_record_type (No) 2")
new_lhs_constructor_type cp cons_index mod_index arity ti expression_type opt_expr_ptr (reqs, ts)
# (lhs, ts) = standardLhsConstructorType cp cons_index mod_index arity ti ts
ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr lhs.tst_result.at_attribute ts.ts_expr_heap }
coercion = { tc_demanded = lhs.tst_result, tc_offered = expression_type, tc_position = cp, tc_coercible = True }
req_type_coercions = [ coercion : reqs.req_type_coercions ]
req_attr_coercions = lhs.tst_attr_env ++ reqs.req_attr_coercions
= (lhs.tst_args, ({ reqs & req_type_coercions = req_type_coercions, req_attr_coercions = req_attr_coercions }, ts))
requirements ti (TupleSelect tuple_symbol arg_nr expr) (reqs=:{req_attr_coercions}, ts)
# (position, ts_var_heap) = getPositionOfExpr expr ts.ts_var_heap
......@@ -1814,8 +1852,8 @@ makeBase _ _ [] [] ts_var_heap
= ts_var_heap
makeBase fun_or_cons_ident arg_nr [{fv_name, fv_info_ptr} : vars] [type : types] ts_var_heap
| is_rare_name fv_name
= makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type (Yes (CP_FunArg fun_or_cons_ident arg_nr)) ts_var_heap)
= makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type No ts_var_heap)
= makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type (VITI_Coercion (CP_FunArg fun_or_cons_ident arg_nr)) ts_var_heap)
= makeBase fun_or_cons_ident (arg_nr+1) vars types (addToBase fv_info_ptr type VITI_Empty ts_var_heap)
addToBase info_ptr atype=:{at_type = TFA atvs type} optional_position ts_var_heap
= ts_var_heap <:= (info_ptr, VI_FAType atvs { atype & at_type = type} optional_position)
......@@ -2451,7 +2489,7 @@ where
_
-> (bitvects, subst)
build_coercion_env :: [.FunctionRequirements] v:{!Type} *Coercions {#CommonDefs} {#Int} *{#*{#TypeDefInfo}} *TypeHeaps !*ErrorAdmin -> (!w:{!Type},!.Coercions,!u:{#u:{#TypeDefInfo}},!.TypeHeaps,!.ErrorAdmin), [v <= w];
// build_coercion_env :: [.FunctionRequirements] v:{!Type} *Coercions {#CommonDefs} {#Int} *{#*{#TypeDefInfo}} *TypeHeaps !*ErrorAdmin -> (!w:{!Type},!.Coercions,!u:{#u:{#TypeDefInfo}},!.TypeHeaps,!.ErrorAdmin), [v <= w];
build_coercion_env [{fe_requirements={req_type_coercion_groups},fe_location={ip_ident}} : reqs_list] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error
# (subst, coercion_env, type_signs, type_var_heap, error)
= foldSt (build_coercion_env_for_alternative ip_ident common_defs cons_var_vects)
......@@ -2770,17 +2808,29 @@ where
is_rare_name {id_name}
= id_name.[0]=='_'
getPositionOfExpr expr=:(Var {var_info_ptr}) var_heap
= case readPtr var_info_ptr var_heap of
(VI_Type _ (Yes position), var_heap)
getPositionOfExpr expr=:(Var var) var_heap
# (type_info, var_heap) = getTypeInfoOfVariable var var_heap
= case type_info of
VITI_Coercion position
-> (position, var_heap)
(VI_FAType _ _ (Yes position), var_heap)
VITI_PatternType _ (VITI_Coercion position)
-> (position, var_heap)
(_, var_heap)
_
-> (CP_Expression expr, var_heap)
getPositionOfExpr expr var_heap
= (CP_Expression expr, var_heap)
getTypeInfoOfVariable {var_info_ptr} var_heap
# (var_info, var_heap)= readPtr var_info_ptr var_heap
= case var_info of
VI_Type _ type_info
-> (type_info, var_heap)
VI_FAType _ _ type_info
-> (type_info, var_heap)
_
-> abort "getTypeInfoOfVariable"
empty_id =: { id_name = "", id_info = nilPtr }
instance <<< (Ptr a)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment