Commit 474ffd08 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

*** empty log message ***

parent 2c292fb3
...@@ -10,9 +10,6 @@ import RWSDebug ...@@ -10,9 +10,6 @@ import RWSDebug
, ti_functions :: {# {# FunType }} , ti_functions :: {# {# FunType }}
} }
:: FunctionType = CheckedType !SymbolType | SpecifiedType !SymbolType ![AType] !TempSymbolType
| UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType
:: TypeState = :: TypeState =
{ ts_fun_env :: !.{! FunctionType} { ts_fun_env :: !.{! FunctionType}
, ts_var_store :: !Int , ts_var_store :: !Int
...@@ -476,20 +473,23 @@ where ...@@ -476,20 +473,23 @@ where
= (dem_attr_var <> ac_demanded || off_attr_var <> ac_offered) && is_new_ineqality dem_attr_var off_attr_var attr_env = (dem_attr_var <> ac_demanded || off_attr_var <> ac_offered) && is_new_ineqality dem_attr_var off_attr_var attr_env
is_new_ineqality dem_attr_var off_attr_var [] is_new_ineqality dem_attr_var off_attr_var []
= True = True
freshSymbolType st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_env,st_arity} common_defs cWithFreshContextVars :== True
ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos} cWithoutFreshContextVars :== False
freshSymbolType 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_td_infos,ts_var_heap}
# (th_vars, ts_var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store) # (th_vars, ts_var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store)
(th_attrs, ts_attr_store) = fresh_attributes st_attr_vars (ts_type_heaps.th_attrs, ts_attr_store) (th_attrs, ts_attr_store) = fresh_attributes st_attr_vars (ts_type_heaps.th_attrs, ts_attr_store)
(attr_env, th_attrs) = freshEnvironment st_attr_env th_attrs (attr_env, th_attrs) = freshEnvironment st_attr_env th_attrs
cs = { copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }} cs = { copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }}
(tst_args, cs) = freshCopy st_args cs (tst_args, cs) = freshCopy st_args cs
(tst_result, cs) = freshCopy st_result cs (tst_result, cs) = freshCopy st_result cs
(tst_context, {copy_heaps}) = freshTypeContexts st_context cs (tst_context, ({copy_heaps}, ts_var_heap)) = freshTypeContexts fresh_context_vars st_context (cs, ts_var_heap)
cons_variables = foldSt (collect_cons_variables_in_tc common_defs) tst_context [] cons_variables = foldSt (collect_cons_variables_in_tc common_defs) tst_context []
= ({ tst_args = tst_args, tst_result = tst_result, tst_context = tst_context, tst_attr_env = attr_env, tst_arity = st_arity, tst_lifted = 0 }, cons_variables, = ({ tst_args = tst_args, tst_result = tst_result, tst_context = tst_context, tst_attr_env = attr_env, tst_arity = st_arity, tst_lifted = 0 }, cons_variables,
{ ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = copy_heaps}) { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = copy_heaps, ts_var_heap = ts_var_heap})
// ---> ("freshSymbolType", tst_args, tst_result) // ---> ("freshSymbolType", tst_args, tst_result, tst_context)
where where
fresh_type_variables type_variables state fresh_type_variables type_variables state
= foldr (\{tv_info_ptr} (var_heap, var_store) -> (writePtr tv_info_ptr (TVI_Type (TempV var_store)) var_heap, inc var_store)) = foldr (\{tv_info_ptr} (var_heap, var_store) -> (writePtr tv_info_ptr (TVI_Type (TempV var_store)) var_heap, inc var_store))
...@@ -536,12 +536,15 @@ freshEnvironment [ineq : ineqs] attr_heap ...@@ -536,12 +536,15 @@ freshEnvironment [ineq : ineqs] attr_heap
freshEnvironment [] attr_heap freshEnvironment [] attr_heap
= ([], attr_heap) = ([], attr_heap)
freshTypeContexts tcs cs freshTypeContexts fresh_context_vars tcs cs_and_var_heap
= mapSt fresh_type_context tcs cs = mapSt (fresh_type_context fresh_context_vars) tcs cs_and_var_heap
where where
fresh_type_context tc=:{tc_types} cs fresh_type_context fresh_context_vars tc=:{tc_types} (cs, var_heap)
# (tc_types, cs) = mapSt fresh_context_type tc_types cs # (tc_types, cs) = mapSt fresh_context_type tc_types cs
= ({ tc & tc_types = tc_types}, cs) | fresh_context_vars
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
= ({ tc & tc_types = tc_types, tc_var = new_info_ptr }, (cs, var_heap))
= ({ tc & tc_types = tc_types}, (cs, var_heap))
fresh_context_type (CV tv :@: types) cs=:{copy_heaps} fresh_context_type (CV tv :@: types) cs=:{copy_heaps}
# (fresh_cons_var, th_vars) = freshConsVariable tv copy_heaps.th_vars # (fresh_cons_var, th_vars) = freshConsVariable tv copy_heaps.th_vars
...@@ -718,11 +721,9 @@ determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_var ...@@ -718,11 +721,9 @@ determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_var
ts = { ts & ts_var_heap = ts_var_heap } ts = { ts & ts_var_heap = ts_var_heap }
= case type_info of = case type_info of
VI_PropagationType symb_type VI_PropagationType symb_type
# (copy_symb_type, cons_variables, ts) = freshSymbolType symb_type common_defs ts # (copy_symb_type, cons_variables, ts) = freshSymbolType cWithFreshContextVars symb_type common_defs ts
// (ts ---> ("determineSymbolTypeOfFunction1", ident, symb_type))
(curried_st, ts) = currySymbolType copy_symb_type act_arity ts (curried_st, ts) = currySymbolType copy_symb_type act_arity ts
-> (curried_st, cons_variables, ts) -> (curried_st, cons_variables, ts)
// ---> ("determineSymbolTypeOfFunction", ident, curried_st)
_ _
# (st_args, ps) = addPropagationAttributesToATypes common_defs st_args # (st_args, ps) = addPropagationAttributesToATypes common_defs st_args
{ prop_type_heaps = ts.ts_type_heaps, prop_td_infos = ts.ts_td_infos, { prop_type_heaps = ts.ts_type_heaps, prop_td_infos = ts.ts_td_infos,
...@@ -730,36 +731,35 @@ determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_var ...@@ -730,36 +731,35 @@ determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_var
(st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error,prop_attr_env}) (st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error,prop_attr_env})
= addPropagationAttributesToAType common_defs st_result ps = addPropagationAttributesToAType common_defs st_result ps
st = { st & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env } st = { st & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env }
# (copy_symb_type, cons_variables, ts) = freshSymbolType st common_defs { ts & # (copy_symb_type, cons_variables, ts) = freshSymbolType cWithFreshContextVars st common_defs { ts &
ts_type_heaps = prop_type_heaps, ts_td_infos = prop_td_infos, ts_error = prop_error, ts_type_heaps = prop_type_heaps, ts_td_infos = prop_td_infos, ts_error = prop_error,
ts_var_heap = ts.ts_var_heap <:= (type_ptr, VI_PropagationType st) } ts_var_heap = ts.ts_var_heap <:= (type_ptr, VI_PropagationType st) }
(curried_st, ts) = currySymbolType copy_symb_type act_arity ts (curried_st, ts) = currySymbolType copy_symb_type act_arity ts
-> (curried_st, cons_variables, ts) -> (curried_st, cons_variables, ts)
// ---> ("determineSymbolTypeOfFunction", ident, st)
standardFieldSelectorType {glob_object={ds_ident,ds_index},glob_module} {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} standardFieldSelectorType {glob_object={ds_ident,ds_index},glob_module} {ti_common_defs} ts=:{ts_var_store,ts_type_heaps}
#! {sd_type,sd_exi_vars,sd_exi_attrs} = ti_common_defs.[glob_module].com_selector_defs.[ds_index] #! {sd_type,sd_exi_vars,sd_exi_attrs} = ti_common_defs.[glob_module].com_selector_defs.[ds_index]
# (th_vars, ts_var_store) = freshExistentialVariables sd_exi_vars (ts_type_heaps.th_vars, ts_var_store) # (th_vars, ts_var_store) = freshExistentialVariables sd_exi_vars (ts_type_heaps.th_vars, ts_var_store)
(inst, cons_variables, ts) = freshSymbolType sd_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } (inst, cons_variables, ts) = freshSymbolType cWithFreshContextVars sd_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store }
= (inst, ts) = (inst, ts)
// ---> ("standardFieldSelectorType", ds_ident, inst) // ---> ("standardFieldSelectorType", ds_ident, inst)
standardTupleSelectorType {ds_index} arg_nr {ti_common_defs} ts standardTupleSelectorType {ds_index} arg_nr {ti_common_defs} ts
#! {cons_type} = ti_common_defs.[cPredefinedModuleIndex].com_cons_defs.[ds_index] #! {cons_type} = ti_common_defs.[cPredefinedModuleIndex].com_cons_defs.[ds_index]
(fresh_type, cons_variables, ts) = freshSymbolType { cons_type & st_args = [cons_type.st_result], st_result = cons_type.st_args !! arg_nr } ti_common_defs ts (fresh_type, cons_variables, ts) = freshSymbolType cWithFreshContextVars { cons_type & st_args = [cons_type.st_result], st_result = cons_type.st_args !! arg_nr } ti_common_defs ts
= (fresh_type, ts) = (fresh_type, ts)
standardRhsConstructorType index mod arity {ti_common_defs} ts standardRhsConstructorType index mod arity {ti_common_defs} ts
#! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index] #! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index]
# cons_type = { cons_type & st_vars = mapAppend (\{atv_variable} -> atv_variable) cons_exi_vars cons_type.st_vars } # cons_type = { cons_type & st_vars = mapAppend (\{atv_variable} -> atv_variable) cons_exi_vars cons_type.st_vars }
(fresh_type, _, ts) = freshSymbolType cons_type ti_common_defs ts (fresh_type, _, ts) = freshSymbolType cWithFreshContextVars cons_type ti_common_defs ts
= currySymbolType fresh_type arity ts = currySymbolType fresh_type arity ts
// ---> ("standardRhsConstructorType", cons_symb, fresh_type) // ---> ("standardRhsConstructorType", cons_symb, fresh_type)
standardLhsConstructorType index mod arity {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} standardLhsConstructorType index mod arity {ti_common_defs} ts=:{ts_var_store,ts_type_heaps}
#! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index] #! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index]
# (th_vars, ts_var_store) = freshExistentialVariables cons_exi_vars (ts_type_heaps.th_vars, ts_var_store) # (th_vars, ts_var_store) = freshExistentialVariables cons_exi_vars (ts_type_heaps.th_vars, ts_var_store)
(fresh_type, _, ts) = freshSymbolType cons_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } (fresh_type, _, ts) = freshSymbolType cWithFreshContextVars cons_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store }
= (fresh_type, ts) = (fresh_type, ts)
// ---> ("standardLhsConstructorType", cons_symb, fresh_type) // ---> ("standardLhsConstructorType", cons_symb, fresh_type)
...@@ -781,11 +781,12 @@ getSymbolType ti=:{ti_functions,ti_common_defs} {symb_kind = SK_Function {glob_m ...@@ -781,11 +781,12 @@ getSymbolType ti=:{ti_functions,ti_common_defs} {symb_kind = SK_Function {glob_m
# (fun_type_copy, ts) = currySymbolType fun_type symb_arity ts # (fun_type_copy, ts) = currySymbolType fun_type symb_arity ts
-> (fun_type_copy, [], [], ts) -> (fun_type_copy, [], [], ts)
SpecifiedType fun_type lifted_arg_types _ SpecifiedType fun_type lifted_arg_types _
# (fun_type_copy, cons_variables, ts) = freshSymbolType fun_type ti_common_defs ts # (fun_type_copy=:{tst_args,tst_arity}, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars fun_type ti_common_defs ts
(fun_type_copy, ts) = currySymbolType { fun_type_copy & tst_args = lifted_arg_types ++ fun_type_copy.tst_args } symb_arity ts (fun_type_copy, ts) = currySymbolType { fun_type_copy & tst_args = lifted_arg_types ++ fun_type_copy.tst_args,
tst_arity = tst_arity + length lifted_arg_types } symb_arity ts
-> (fun_type_copy, cons_variables, [], ts) -> (fun_type_copy, cons_variables, [], ts)
CheckedType fun_type CheckedType fun_type
# (fun_type_copy, cons_variables, ts) = freshSymbolType fun_type ti_common_defs ts # (fun_type_copy, cons_variables, ts) = freshSymbolType cWithFreshContextVars fun_type ti_common_defs ts
(fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts
-> (fun_type_copy, cons_variables, [], ts) -> (fun_type_copy, cons_variables, [], ts)
_ _
...@@ -820,7 +821,7 @@ where ...@@ -820,7 +821,7 @@ where
instance requirements App instance requirements App
where where
requirements ti {app_symb,app_args,app_info_ptr} (reqs=:{req_cons_variables, req_attr_coercions}, ts) requirements ti {app_symb,app_args,app_info_ptr} (reqs=:{req_cons_variables, req_attr_coercions}, ts)
# ({tst_attr_env,tst_args,tst_result,tst_context}, cons_variables, specials, ts) = getSymbolType ti app_symb ts # (tst=:{tst_attr_env,tst_args,tst_result,tst_context}, cons_variables, specials, ts) = getSymbolType ti app_symb ts
reqs = { reqs & req_attr_coercions = tst_attr_env ++ req_attr_coercions, req_cons_variables = [cons_variables : req_cons_variables] } reqs = { reqs & req_attr_coercions = tst_attr_env ++ req_attr_coercions, req_cons_variables = [cons_variables : req_cons_variables] }
(reqs, ts) = requirements_of_args ti app_args tst_args (reqs, ts) (reqs, ts) = requirements_of_args ti app_args tst_args (reqs, ts)
| isEmpty tst_context | isEmpty tst_context
...@@ -1109,7 +1110,7 @@ requirementsOfSelector ti _ expr (RecordSelection field filed_nr) tc_coercible s ...@@ -1109,7 +1110,7 @@ requirementsOfSelector ti _ expr (RecordSelection field filed_nr) tc_coercible s
= (tst_result, ({ reqs & req_type_coercions = req_type_coercions }, ts)) = (tst_result, ({ reqs & req_type_coercions = req_type_coercions }, ts))
requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible sel_expr_type sel_expr (reqs, ts) requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible sel_expr_type sel_expr (reqs, ts)
# {me_type} = ti.ti_common_defs.[glob_module].com_member_defs.[ds_index] # {me_type} = ti.ti_common_defs.[glob_module].com_member_defs.[ds_index]
({tst_attr_env,tst_args,tst_result,tst_context}, cons_variables, ts) = freshSymbolType me_type ti.ti_common_defs ts ({tst_attr_env,tst_args,tst_result,tst_context}, cons_variables, ts) = freshSymbolType cWithFreshContextVars me_type ti.ti_common_defs ts
(dem_array_type, dem_index_type, rest_type) = array_and_index_type tst_args (dem_array_type, dem_index_type, rest_type) = array_and_index_type tst_args
reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, req_cons_variables = [ cons_variables : reqs.req_cons_variables ]} reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, req_cons_variables = [ cons_variables : reqs.req_cons_variables ]}
(index_type, opt_expr_ptr, (reqs, ts)) = requirements ti index_expr (reqs, ts) (index_type, opt_expr_ptr, (reqs, ts)) = requirements ti index_expr (reqs, ts)
...@@ -1175,7 +1176,7 @@ where ...@@ -1175,7 +1176,7 @@ where
(st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error,prop_attr_env}) = addPropagationAttributesToAType common_defs st_result ps (st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error,prop_attr_env}) = addPropagationAttributesToAType common_defs st_result ps
ft = { ft & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env } ft = { ft & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env }
(th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (prop_type_heaps.th_vars, ts.ts_expr_heap) (th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (prop_type_heaps.th_vars, ts.ts_expr_heap)
(fresh_fun_type, cons_variables, ts) = freshSymbolType ft common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap, (fresh_fun_type, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars ft common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap,
ts_td_infos = prop_td_infos, ts_error = prop_error } ts_td_infos = prop_td_infos, ts_error = prop_error }
(lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts (lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols) (ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
...@@ -1327,26 +1328,26 @@ where ...@@ -1327,26 +1328,26 @@ where
# ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error} # ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error}
= case env_type of = case env_type of
ExpandedType fun_type tmp_fun_type exp_fun_type ExpandedType fun_type tmp_fun_type exp_fun_type
# (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error) # (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType exp_fun_type type_contexts case_and_let_exprs coercion_env = cleanUpSymbolType cSpecifiedType exp_fun_type type_contexts case_and_let_exprs coercion_env
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_expr_heap ts.ts_error attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
| ts_error.ea_ok | ts_error.ea_ok
# (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error) # (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error)
= check_function_type fun_type tmp_fun_type clean_fun_type case_and_let_exprs defs ts.ts_fun_env attr_var_env ts_type_heaps ts_expr_heap ts_error = check_function_type fun_type tmp_fun_type clean_fun_type case_and_let_exprs defs ts.ts_fun_env attr_var_env ts_type_heaps ts_expr_heap ts_error
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error }) -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_error = ts_error }) -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error })
UncheckedType exp_fun_type UncheckedType exp_fun_type
# (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error) # (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType exp_fun_type type_contexts case_and_let_exprs coercion_env = cleanUpSymbolType cDerivedType exp_fun_type type_contexts case_and_let_exprs coercion_env
attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_expr_heap ts.ts_error attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type } ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type }
-> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error }) -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars} case_and_let_exprs check_function_type fun_type tmp_fun_type=:{tst_lifted} clean_fun_type=:{st_arity, st_args, st_vars, st_attr_vars, st_context} case_and_let_exprs
defs fun_env attr_var_env type_heaps expr_heap error defs fun_env attr_var_env type_heaps expr_heap error
# (equi, attr_var_env, type_heaps) = equivalent clean_fun_type tmp_fun_type defs attr_var_env type_heaps # (equi, attr_var_env, type_heaps) = equivalent clean_fun_type tmp_fun_type (length fun_type.st_context) defs attr_var_env type_heaps
| equi | equi
# type_with_lifted_arg_types = addLiftedArgumentsToSymbolType fun_type tst_lifted st_args st_vars st_attr_vars # type_with_lifted_arg_types = addLiftedArgumentsToSymbolType fun_type tst_lifted st_args st_vars st_attr_vars st_context
(type_heaps, expr_heap) = updateExpressionTypes clean_fun_type type_with_lifted_arg_types case_and_let_exprs type_heaps expr_heap (type_heaps, expr_heap) = updateExpressionTypes clean_fun_type type_with_lifted_arg_types case_and_let_exprs type_heaps expr_heap
= ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, expr_heap, error) = ({ fun_env & [fun] = CheckedType type_with_lifted_arg_types}, attr_var_env, type_heaps, expr_heap, error)
// ---> ("check_function_type", clean_fun_type, fun_type, type_with_lifted_arg_types) // ---> ("check_function_type", clean_fun_type, fun_type, type_with_lifted_arg_types)
...@@ -1357,9 +1358,10 @@ where ...@@ -1357,9 +1358,10 @@ where
= take arity_diff args2 ++ args1 = take arity_diff args2 ++ args1
= args1 = args1
addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars} nr_of_lifted_arguments new_args new_vars new_attrs addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_context} nr_of_lifted_arguments new_args new_vars new_attrs new_context
= { st & st_args = take nr_of_lifted_arguments new_args ++ st_args, st_vars = st_vars ++ drop (length st_vars) new_vars, = { st & st_args = take nr_of_lifted_arguments new_args ++ st_args, st_vars = st_vars ++ drop (length st_vars) new_vars,
st_attr_vars = st_attr_vars ++ take (length new_attrs - length st_attr_vars) new_attrs, st_arity = st_arity + nr_of_lifted_arguments } st_attr_vars = st_attr_vars ++ take (length new_attrs - length st_attr_vars) new_attrs, st_arity = st_arity + nr_of_lifted_arguments,
st_context = take (length new_context - length st_context) new_context ++ st_context }
:: FunctionRequirements = :: FunctionRequirements =
...@@ -1540,22 +1542,22 @@ where ...@@ -1540,22 +1542,22 @@ where
# ts_type_heaps = ts.ts_type_heaps # ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
tci_type_var_heap = ts_type_heaps.th_vars } tci_type_var_heap = ts_type_heaps.th_vars }
(fun_defs, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error) (fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error)
= updateDynamics comp contexts local_pattern_variables fun_defs ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error = updateDynamics comp local_pattern_variables fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error
= ( type_error || not ts_error.ea_ok, = ( type_error || not ts_error.ea_ok,
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances },
{ ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True },
ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }}) ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env})
# ts_type_heaps = ts.ts_type_heaps # ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
tci_type_var_heap = ts_type_heaps.th_vars } tci_type_var_heap = ts_type_heaps.th_vars }
(fun_defs, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error) (fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error)
= removeOverloadedFunctions [(co, pos, index) \\ (co, _, pos, index) <- over_info] = removeOverloadedFunctions comp local_pattern_variables fun_defs ts.ts_fun_env
contexts local_pattern_variables fun_defs ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error
= ( type_error || not ts_error.ea_ok, = ( type_error || not ts_error.ea_ok,
fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances },
{ ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True },
ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }}) ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env})
unify_requirements_of_functions :: ![FunctionRequirements] !TypeInput !*{!Type} !*TypeHeaps !*ErrorAdmin -> (!*{!Type},!*TypeHeaps,!*ErrorAdmin) unify_requirements_of_functions :: ![FunctionRequirements] !TypeInput !*{!Type} !*TypeHeaps !*ErrorAdmin -> (!*{!Type},!*TypeHeaps,!*ErrorAdmin)
unify_requirements_of_functions [{fe_requirements={req_type_coercions},fe_location} : reqs_list] modules subst heaps ts_error unify_requirements_of_functions [{fe_requirements={req_type_coercions},fe_location} : reqs_list] modules subst heaps ts_error
...@@ -1671,7 +1673,8 @@ where ...@@ -1671,7 +1673,8 @@ where
Yes fun_type Yes fun_type
# nr_of_lifted_arguments = checked_fun_type.st_arity - fun_type.st_arity # nr_of_lifted_arguments = checked_fun_type.st_arity - fun_type.st_arity
| nr_of_lifted_arguments > 0 | nr_of_lifted_arguments > 0
# fun_type = addLiftedArgumentsToSymbolType fun_type nr_of_lifted_arguments checked_fun_type.st_args checked_fun_type.st_vars checked_fun_type.st_attr_vars # fun_type = addLiftedArgumentsToSymbolType fun_type nr_of_lifted_arguments
checked_fun_type.st_args checked_fun_type.st_vars checked_fun_type.st_attr_vars checked_fun_type.st_context
-> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }} -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }}
-> update_function_types_in_component funs fun_env fun_defs -> update_function_types_in_component funs fun_env fun_defs
update_function_types_in_component [] fun_env fun_defs update_function_types_in_component [] fun_env fun_defs
...@@ -1713,32 +1716,40 @@ where ...@@ -1713,32 +1716,40 @@ where
{class_members} = common_defs.[pds_module].com_class_defs.[pds_def] {class_members} = common_defs.[pds_module].com_class_defs.[pds_def]
array_members = common_defs.[pds_module].com_member_defs array_members = common_defs.[pds_module].com_member_defs
(offset_table, _, predef_symbols) = arrayFunOffsetToPD_IndexTable array_members predef_symbols (offset_table, _, predef_symbols) = arrayFunOffsetToPD_IndexTable array_members predef_symbols
(rev_instances, type_heaps) = foldSt (convert_array_instance class_members array_members unboxed_array_type offset_table) si_array_instances (instances, type_heaps) = foldSt (convert_array_instance class_members array_members unboxed_array_type offset_table) si_array_instances
([], type_heaps) ([], type_heaps)
= (arrayPlusRevList fun_defs rev_instances, predef_symbols, type_heaps) = (arrayPlusList fun_defs instances, predef_symbols, type_heaps)
where where
convert_array_instance class_members array_members unboxed_array_type offset_table {ai_record} funs_and_heaps convert_array_instance class_members array_members unboxed_array_type offset_table {ai_record} funs_and_heaps
= iFoldSt (create_instance_type class_members array_members unboxed_array_type offset_table (TA ai_record [])) 0 (size class_members) funs_and_heaps = create_instance_types class_members array_members unboxed_array_type offset_table (TA ai_record []) (size class_members) funs_and_heaps
where
create_instance_type members array_members unboxed_array_type offset_table record_type member_index (array_defs, type_heaps)
# {me_type,me_symb,me_class_vars,me_pos} = array_members.[members.[member_index].ds_index] create_instance_types members array_members unboxed_array_type offset_table record_type member_index funs_and_heaps
(instance_type, _, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [], | member_index == 0
it_types = [unboxed_array_type, record_type]} SP_None type_heaps = funs_and_heaps
instance_type = makeElemTypeOfArrayFunctionStrict instance_type member_index offset_table # member_index = dec member_index
fun = funs_and_heaps = create_instance_type members array_members unboxed_array_type offset_table record_type member_index funs_and_heaps
{ fun_symb = me_symb = create_instance_types members array_members unboxed_array_type offset_table record_type member_index funs_and_heaps
, fun_arity = me_type.st_arity
, fun_priority = NoPrio create_instance_type members array_members unboxed_array_type offset_table record_type member_index (array_defs, type_heaps)
, fun_body = NoBody # {me_type,me_symb,me_class_vars,me_pos} = array_members.[members.[member_index].ds_index]
, fun_type = Yes instance_type (instance_type, _, type_heaps) = determineTypeOfMemberInstance me_type me_class_vars {it_vars = [], it_attr_vars = [], it_context = [],
, fun_pos = me_pos it_types = [unboxed_array_type, record_type]} SP_None type_heaps
, fun_index = member_index instance_type = makeElemTypeOfArrayFunctionStrict instance_type member_index offset_table
, fun_kind = FK_Unknown fun =
, fun_lifted = 0 { fun_symb = me_symb
, fun_info = EmptyFunInfo , fun_arity = me_type.st_arity
} , fun_priority = NoPrio
, fun_body = NoBody
= ([fun : array_defs], type_heaps) , fun_type = Yes instance_type
, fun_pos = me_pos
, fun_index = member_index
, fun_kind = FK_Unknown
, fun_lifted = 0
, fun_info = EmptyFunInfo
}
= ([fun : array_defs], type_heaps)
create_erroneous_function_types group ts create_erroneous_function_types group ts
= foldSt create_erroneous_function_type group ts = foldSt create_erroneous_function_type group ts
...@@ -1768,7 +1779,7 @@ where ...@@ -1768,7 +1779,7 @@ where
instance <<< TypeContext instance <<< TypeContext
where where
(<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types (<<<) file co = file <<< co.tc_class <<< " <" <<< ptrToInt co.tc_var <<< '>' <<< " " <<< co.tc_types
instance <<< DefinedSymbol instance <<< DefinedSymbol
where where
......
...@@ -5,7 +5,7 @@ import checksupport, StdCompare ...@@ -5,7 +5,7 @@ import checksupport, StdCompare
from unitype import Coercions, CoercionTree, AttributePartition from unitype import Coercions, CoercionTree, AttributePartition
// MW: this switch is used to en(dis)able the fusion algorithm // MW: this switch is used to en(dis)able the fusion algorithm
SwitchFusion fuse dont_fuse :== fuse SwitchFusion fuse dont_fuse :== dont_fuse
errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin
...@@ -29,13 +29,16 @@ instance <:: SymbolType, Type, AType, [a] | <:: a ...@@ -29,13 +29,16 @@ instance <:: SymbolType, Type, AType, [a] | <:: a
cleanSymbolType :: !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) cleanSymbolType :: !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
cleanUpSymbolType :: !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition cSpecifiedType :== True
!*VarEnv !*AttributeEnv !*TypeHeaps !*ExpressionHeap !*ErrorAdmin cDerivedType :== False
-> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*ExpressionHeap, !*ErrorAdmin)
cleanUpSymbolType :: !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition
!*VarEnv !*AttributeEnv !*TypeHeaps !*VarHeap !*ExpressionHeap !*ErrorAdmin
-> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps)
equivalent :: !SymbolType !TempSymbolType !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps) equivalent :: !SymbolType !TempSymbolType !Int !{# CommonDefs} !*AttributeEnv !*TypeHeaps -> (!Bool, !*AttributeEnv, !*TypeHeaps)
:: AttrCoercion = :: AttrCoercion =
{ ac_demanded :: !Int { ac_demanded :: !Int
...@@ -51,6 +54,10 @@ equivalent :: !SymbolType !TempSymbolType !{# CommonDefs} !*AttributeEnv !*Type ...@@ -51,6 +54,10 @@ equivalent :: !SymbolType !TempSymbolType !{# CommonDefs} !*AttributeEnv !*Type
, tst_attr_env :: ![AttrCoercion] , tst_attr_env :: ![AttrCoercion]
} }
:: FunctionType = CheckedType !SymbolType | SpecifiedType !SymbolType ![AType] !TempSymbolType
| UncheckedType !TempSymbolType | ExpandedType !SymbolType !TempSymbolType !TempSymbolType | EmptyFunctionType
updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap) updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*ExpressionHeap -> (!*TypeHeaps, !*ExpressionHeap)
class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
......
...@@ -71,6 +71,7 @@ where ...@@ -71,6 +71,7 @@ where
fold_st2 xs [] st fold_st2 xs [] st
= abort ("fold_st2: first argument list contains more elements") = abort ("fold_st2: first argument list contains more elements")
// foldSt :: !(.a -> .(.st -> .st)) ![.a] !.st -> .st // foldSt :: !(.a -> .(.st -> .st)) ![.a] !.st -> .st
foldSt op l st :== fold_st l st foldSt op l st :== fold_st l st
where where
......
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