Commit 2cf31dcd authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Bug fix with array updates. Removed redundant code. Adjusted unification algorithm.

parent ac601f7c
......@@ -1635,6 +1635,7 @@ remove_function_conversion_table main_dcl_module_n dcl_modules
# dcl_modules = {dcl_modules & [main_dcl_module_n].dcl_conversions=Yes conversion_table}
-> (function_conversions,dcl_modules)
// add_function_conversion_table :: {#Int} Int *(a DclModule) -> *(a DclModule) | Array a DclModule
add_function_conversion_table dcl_to_icl_function_conversions main_dcl_module_n dcl_modules
# (dcl_mod,dcl_modules) = dcl_modules![main_dcl_module_n]
= case dcl_mod.dcl_conversions of
......
......@@ -867,7 +867,8 @@ where
check_context_types tc_class [] cs=:{cs_error}
= { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error}
check_context_types tc_class [((CV {tv_name}) :@: _):_] cs=:{cs_error}
= { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error}
= cs
// = { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error}
check_context_types tc_class [TV _ : types] cs
= cs
check_context_types tc_class [type : types] cs
......@@ -1141,11 +1142,11 @@ where
addExistentionalTypeVariablesToSymbolTable :: !TypeAttribute ![ATypeVar] !*TypeHeaps !*CheckState
-> (![ATypeVar], !(!*TypeHeaps, !*CheckState))
addExistentionalTypeVariablesToSymbolTable root_attr type_vars heaps cs
= mapSt (add_type_variable_to_symbol_table root_attr) type_vars (heaps, cs)
= mapSt (add_exi_variable_to_symbol_table root_attr) type_vars (heaps, cs)
where
add_type_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState)
add_exi_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState)
-> (!ATypeVar, !(!*TypeHeaps, !*CheckState))
add_type_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute}
add_exi_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute}
(heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error /* TD ... */, cs_x={x_type_var_position} /* ... TD */})
# tv_info = tv_name.id_info
(entry, cs_symbol_table) = readPtr tv_info cs_symbol_table
......
......@@ -903,7 +903,7 @@ where
= ([fi:fis], [fd:fds], gs)
build_cons_info {ds_index,ds_arity} cons_num type_info_def_sym group_index common_defs gs
# {cons_symb, cons_arity, cons_pos} = common_defs.com_cons_defs.[ds_index]
# {cons_symb, cons_pos} = common_defs.com_cons_defs.[ds_index]
# (fun_index, gs) = newFunIndex gs
# def_sym =
{ ds_ident = makeIdent ("cons_info_" +++ cons_symb.id_name)
......@@ -3154,7 +3154,7 @@ copyExpr expr heaps=:{hp_var_heap, hp_expression_heap}
= (expr, {heaps & hp_var_heap = us_var_heap, hp_expression_heap = us_symbol_heap})
//---> ("copy Expr")
mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st)
//mapExprSt :: (Expression .st->(Expression, .st)) Expression .st -> (Expression, .st)
mapExprSt f (App app=:{app_args}) st
# (app_args, st) = mapSt (mapExprSt f) app_args st
= f (App { app & app_args = app_args }) st
......
......@@ -506,9 +506,13 @@ where
match defs (TA cons_id1 cons_args1) (TA cons_id2 cons_args2) type_heaps
| cons_id1 == cons_id2
= match defs cons_args1 cons_args2 type_heaps
// # (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps
# (succ1, type1, type_heaps) = tryToExpandTypeSyn defs cons_id1 cons_args1 type_heaps
# (succ2, type2, type_heaps) = tryToExpandTypeSyn defs cons_id2 cons_args2 type_heaps
| succ1 || succ2
= match defs type1 type2 type_heaps
/*
| succ2
= case type2 of
TA cons_id2 cons_args2
| cons_id1 == cons_id2
......@@ -516,6 +520,8 @@ where
-> (False, type_heaps)
_
-> (False, type_heaps)
*/
= (False, type_heaps)
match defs (arg_type1 --> res_type1) (arg_type2 --> res_type2) type_heaps
= match defs (arg_type1,res_type1) (arg_type2,res_type2) type_heaps
......@@ -928,6 +934,7 @@ where
{fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb,fun_pos} = fun_def
(rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap)
// ---> ("determine_class_argument", st_context)
error = setErrorAdmin (newPosition fun_symb fun_pos) error
(type_code_info, symbol_heap, type_pattern_vars, var_heap, error)
= convertDynamicTypes fun_info.fi_dynamics (type_code_info, symbol_heap, type_pattern_vars, var_heap, error) /* MV */ rev_variables
......
......@@ -74,7 +74,7 @@ where
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 // ---> (var_name,var_expr_ptr,occ_ref_count,var_occ.occ_ref_count) of
= 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 let_expr var_heap
......@@ -100,7 +100,6 @@ where
= refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap)
refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
| isEmpty let_lazy_binds
// MW0 # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ] : free_vars]
# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ] : free_vars]
# (observing, var_heap) = binds_are_observing let_strict_binds var_heap
| observing
......@@ -110,7 +109,6 @@ where
var_heap = refMark new_free_vars sel let_expr var_heap
= let_combine free_vars var_heap
= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap)
// MW0 # new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars]
# 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
......@@ -120,7 +118,6 @@ where
binds_are_observing binds var_heap
= foldr bind_is_observing (True, var_heap) binds
where
// MW0 bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap)
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)
......@@ -134,11 +131,8 @@ 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 })
// MW0 bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap
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_bind = OB_OpenLet bind_src })
// MW0 = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet bind_src })
= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src })
refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap
......@@ -151,7 +145,9 @@ where
field_number _
= NotASelector
refMark free_vars sel (Update expr1 selectors expr2) var_heap
= refMark free_vars NotASelector expr2 (refMark free_vars NotASelector expr1 var_heap)
# var_heap = refMark free_vars NotASelector expr1 var_heap
var_heap = refMark free_vars NotASelector selectors var_heap
= refMark free_vars NotASelector expr2 var_heap
refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap
= ref_mark_of_record_expression free_vars expression expressions var_heap
where
......@@ -203,6 +199,8 @@ instance refMark Selection
where
refMark free_vars _ (ArraySelection _ _ index_expr) var_heap
= refMark free_vars NotASelector index_expr var_heap
refMark free_vars _ _ var_heap
= var_heap
collectUsedFreeVariables free_vars var_heap
= foldSt collectUsedVariables free_vars ([], var_heap)
......@@ -497,7 +495,6 @@ where
# 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 tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap
//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)
......@@ -517,6 +514,7 @@ where
-> (subst, type_def_infos, var_heap <:= (fv_info_ptr,
VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap)
// ---> ("initial_occurrence",fv_name, fv_info_ptr, is_oberving)
_
-> (subst, type_def_infos, var_heap <:= (fv_info_ptr,
VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
......@@ -549,7 +547,7 @@ where
EI_Attribute sa_attr_nr
# (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env
| succ
// ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr)
// ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr, sa_attr_nr)
-> (coercion_env, expr_heap, error)
-> (coercion_env, expr_heap, uniquenessError (CP_Expression (FreeVar free_var)) " demanded attribute cannot be offered by shared object" error)
_
......
......@@ -512,7 +512,7 @@ cIsALocalVar :== False
:: AP_Kind = APK_Constructor !Index | APK_Macro
:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_Occurrence !Occurrence | VI_UsedVar !Ident |
:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType | 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 */ |
VI_AccVar !ConsClass !ArgumentPosition /* used during fusion to determine accumulating parameters of functions */ |
......@@ -818,7 +818,7 @@ cNonRecursiveAppl :== False
| (:@:) infixl 9 !ConsVariable ![AType]
| TB !BasicType
// | TFA [ATypeVar] Type
| TFA [ATypeVar] Type /* Universally quantified types */
| GTV !TypeVar
| TV !TypeVar
......
......@@ -497,7 +497,7 @@ cIsALocalVar :== False
:: AP_Kind = APK_Constructor !Index | APK_Macro
:: VarInfo = VI_Empty |VI_Type !AType !(Optional CoercionPosition) | VI_Occurrence !Occurrence | VI_UsedVar !Ident |
:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType | 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 */ |
VI_AccVar !ConsClass !ArgumentPosition /* used during fusion to determine accumulating parameters of functions */ |
......@@ -789,7 +789,7 @@ cNotVarNumber :== -1
| (:@:) infixl 9 !ConsVariable ![AType]
| TB !BasicType
// | TFA [ATypeVar] Type
| TFA [ATypeVar] Type
| GTV !TypeVar
| TV !TypeVar
......@@ -1408,7 +1408,7 @@ where
instance <<< BoundVar
where
(<<<) file {var_name,var_info_ptr,var_expr_ptr}
= file <<< var_name <<< '<' <<< ptrToInt var_info_ptr <<< '>'
= file <<< var_name <<< "<I" <<< ptrToInt var_info_ptr <<< ", E" <<< ptrToInt var_expr_ptr <<< '>'
instance <<< (Bind a b) | <<< a & <<< b
where
......
......@@ -1352,7 +1352,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
(_, (st_args,st_result), ti_type_heaps)
= substitute (st_args,st_result) ti_type_heaps
(new_fun_args, new_arg_types_array, next_attr_nr,
new_linear_bits, new_cons_args, uniqueness_requirements, subst, ti_type_heaps=:{th_vars, th_attrs},
new_linear_bits, new_cons_args, uniqueness_requirements, subst, ti_type_heaps=:{th_vars},
ti_symbol_heap, ti_fun_defs, ti_fun_heap, ti_var_heap)
= determine_args cc_linear_bits cc_args 0 prods opt_sound_function_producer_types tb_args
(st_args_array st_args)
......@@ -1364,8 +1364,8 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
(createArray (inc (BITINDEX nr_of_all_type_vars)) 0, th_vars)
// | False--->("subst before", [el\\el<-:subst], "cons_vars", [el\\el<-:cons_vars])
// = undef
# (subst, next_attr_nr, th_vars, ti_type_def_infos)
= liftSubstitution subst ro.ro_common_defs cons_vars next_attr_nr th_vars ti_type_def_infos
# (subst, next_attr_nr, ti_type_heaps=:{th_attrs}, ti_type_def_infos)
= liftSubstitution subst ro.ro_common_defs cons_vars next_attr_nr { ti_type_heaps & th_vars = th_vars } ti_type_def_infos
// | False--->("subst after lifting", [el\\el<-:subst])
// = undef
# coer_demanded
......@@ -1385,7 +1385,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi
uniqueness_requirements coercions
(subst, coercions, ti_type_def_infos, ti_type_heaps)
= foldSt (coerce_types ro.ro_common_defs cons_vars) uniqueness_requirements
(subst, coercions, ti_type_def_infos, { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs })
(subst, coercions, ti_type_def_infos, { ti_type_heaps & th_attrs = th_attrs })
// | False--->("cons_vars", [el\\el<-:cons_vars])
// = undef
// expansion_state
......@@ -1883,11 +1883,14 @@ where
expand_type ro_common_defs cons_vars atype (coercions, subst, ti_type_heaps, ti_type_def_infos)
| is_dictionary atype ti_type_def_infos
# (atype, subst) = arraySubst atype subst
///* Sjaak */ # (atype, subst) = arraySubst atype subst
# (_, atype, subst) = arraySubst atype subst
= (atype, (coercions, subst, ti_type_heaps, ti_type_def_infos))
# es
= { es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos }
(btype, (subst, es))
/* Sjaak */
(_, btype, (subst, es))
// (btype, (subst, es))
= expandType ro_common_defs cons_vars atype (subst, es)
{ es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos }
= es
......
......@@ -10,6 +10,8 @@ typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !Common
addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState);
tryToExpand :: !Type !TypeAttribute !{# CommonDefs} !*TypeHeaps -> (!Bool, !Type, !*TypeHeaps)
:: PropState =
{ prop_type_heaps :: !.TypeHeaps
, prop_td_infos :: !.TypeDefInfos
......@@ -28,6 +30,7 @@ instance unify AType
, ti_main_dcl_module_n :: !Int
}
class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type})
class arraySubst type :: !type !u:{!Type} -> (!Bool,!type, !u:{! Type})
//class arraySubst type :: !type !u:{!Type} -> (!type, !u:{! Type})
instance arraySubst AType
This diff is collapsed.
......@@ -21,7 +21,7 @@ where
instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a
/*2.0
instance WriteTypeInfo String
instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b
0.2*/
//1.3
......
......@@ -386,18 +386,6 @@ where
= write_type_info type_arity tcl_file wtis
= (tcl_file,wtis)
/*2.0
instance WriteTypeInfo String
where
write_type_info s tcl_file wtis
# tcl_file
= fwritei (size s) tcl_file
= (fwrites s tcl_file,wtis)
// warning:
// Should be identical to the code in Ident
0.2*/
// basic and structural write_type_info's
instance WriteTypeInfo Int
......@@ -409,7 +397,7 @@ where
instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
//3.1
/*2.0
instance WriteTypeInfo {#b} | WriteTypeInfo b & Array {#} b
instance WriteTypeInfo {#b} | Array {#} b & WriteTypeInfo b
0.2*/
where
write_type_info unboxed_array tcl_file wtis
......
......@@ -207,10 +207,6 @@ errorHeading error_kind err=:{ea_file,ea_loc = []}
errorHeading error_kind err=:{ea_file,ea_loc = [ loc : _ ]}
= { err & ea_file = ea_file <<< error_kind <<< ' ' <<< loc <<< ':', ea_ok = False }
overloadingError class_symb err
# err = errorHeading "Overloading error" err
= { err & ea_file = err.ea_file <<< " internal overloading of class \"" <<< class_symb <<< "\" is unsolvable\n" }
contextError class_symb err
# err = errorHeading "Overloading error" err
= { err & ea_file = err.ea_file <<< " unresolved class \"" <<< class_symb <<< "\" not occurring in specified type\n"}
......@@ -329,7 +325,6 @@ where
clean_up_type_context tc=:{tc_types} (collected_contexts, env, error)
# (cur, tc_types, env) = cleanUpClosed tc.tc_types env
| checkCleanUpResult cur cUndefinedVar
// = ([{ tc & tc_types = tc_types } : collected_contexts], env, overloadingError tc.tc_class.glob_object.ds_ident error)
= (collected_contexts, env, error)
| checkCleanUpResult cur cLiftedVar
= ([{ tc & tc_types = tc_types } : collected_contexts ], env, liftedContextError tc.tc_class.glob_object.ds_ident error)
......
......@@ -54,13 +54,15 @@ tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions)
uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin
liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos)
liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeHeaps !*TypeDefInfos -> (*{! Type}, !Int, !*TypeHeaps, !*TypeDefInfos)
:: ExpansionState =
{ es_type_heaps :: !.TypeHeaps
, es_td_infos :: !.TypeDefInfos
}
class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState))
class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!Bool, !a, !*(!u:{! Type}, !*ExpansionState))
//class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState))
instance expandType AType
This diff is collapsed.
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