Skip to content

GitLab

Commit 955e1a8f authored by John van Groningen's avatar John van Groningen
Browse files

refactor, make some local functions global, remove some function arguments... 

refactor, make some local functions global, remove some function arguments that always have the same constant value
parent 05360070
Hide whitespace changes
Inline Side-by-side
frontend/checktypes.icl
View file @ 955e1a8f
......@@ -936,20 +936,20 @@ new_demanded_attribute _ TA_Unique
new_demanded_attribute dem_attr_kind _
= DAK_None /* dem_attr_kind */
checkOpenArgAType :: !Index !Int !DemandedAttributeKind !AType !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
-> (!AType, !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
checkOpenArgAType mod_index scope dem_attr atype=:{at_type = TFA vars type, at_attribute} (ots, oti, cs)
checkOpenArgAType :: !Index !AType !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
-> (!AType,!(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
checkOpenArgAType mod_index atype=:{at_type = TFA vars type, at_attribute} (ots, oti, cs)
# (vars, (oti, cs)) = add_universal_vars vars oti cs
(checked_type, (ots, oti, cs)) = checkOpenAType mod_index cRankTwoScope dem_attr { atype & at_type = type } (ots, oti, cs)
(checked_type, (ots, oti, cs)) = checkOpenAType mod_index cRankTwoScope DAK_None {atype & at_type = type} (ots, oti, cs)
cs = {cs & cs_symbol_table = remove_universal_vars vars cs.cs_symbol_table}
= ({checked_type & at_type = TFA vars checked_type.at_type }, (ots, oti, cs))
checkOpenArgAType mod_index scope dem_attr atype=:{at_type = TFAC vars type contexts, at_attribute} (ots, oti, cs)
checkOpenArgAType mod_index atype=:{at_type = TFAC vars type contexts, at_attribute} (ots, oti, cs)
# cs = add_universal_vars_again vars cs
(checked_type, (ots, oti, cs)) = checkOpenAType mod_index cRankTwoScope dem_attr {atype & at_type = type} (ots, oti, cs)
(checked_type, (ots, oti, cs)) = checkOpenAType mod_index cRankTwoScope DAK_None {atype & at_type = type} (ots, oti, cs)
cs = {cs & cs_symbol_table = remove_universal_vars vars cs.cs_symbol_table}
= ({checked_type & at_type = TFAC vars checked_type.at_type contexts}, (ots, oti, cs))
checkOpenArgAType mod_index scope dem_attr type ots_oti_cs
= checkOpenAType mod_index scope dem_attr type ots_oti_cs
checkOpenArgAType mod_index type ots_oti_cs
= checkOpenAType mod_index cGlobalScope DAK_None type ots_oti_cs
checkOpenAType :: !Index !Int !DemandedAttributeKind !AType !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)
-> (!AType, !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState))
......@@ -1072,8 +1072,8 @@ checkOpenType mod_index scope dem_attr type cot_state
# ({at_type}, cot_state) = checkOpenAType mod_index scope dem_attr { at_type = type, at_attribute = TA_Multi } cot_state
= (at_type, cot_state)
checkOpenArgATypes mod_index scope types cot_state
= mapSt (checkOpenArgAType mod_index scope DAK_None) types cot_state
checkOpenArgATypes mod_index types cot_state
= mapSt (checkOpenArgAType mod_index) types cot_state
add_universal_vars vars oti cs
= mapSt add_universal_var vars (oti, cs)
......@@ -1246,7 +1246,7 @@ checkSymbolType is_function mod_index st=:{st_args,st_result,st_context,st_attr_
# ots = {ots_type_defs = type_defs, ots_modules = modules}
oti = {oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= []}
(st_args,class_defs,ots,oti,cs) = check_argument_type_contexts st_args mod_index class_defs ots oti cs
(st_args, cot_state) = checkOpenArgATypes mod_index cGlobalScope st_args (ots, oti, cs)
(st_args, cot_state) = checkOpenArgATypes mod_index st_args (ots, oti, cs)
(st_result, (ots, oti=:{oti_all_vars = st_vars,oti_all_attrs = st_attr_vars,oti_global_vars}, cs))
= checkOpenAType mod_index cGlobalScope DAK_None st_result cot_state
oti = {oti & oti_all_vars = [], oti_all_attrs = []}
......@@ -1431,7 +1431,7 @@ checkDynamicTypes :: !Index ![ExprInfoPtr] !FunDefType
!u:{#CheckedTypeDef} !v:{#ClassDef} !u:{#DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState
-> (!u:{#CheckedTypeDef},!v:{#ClassDef},!u:{#DclModule},!*TypeHeaps,!*ExpressionHeap,!*CheckState)
checkDynamicTypes mod_index dyn_type_ptrs NoFunDefType type_defs class_defs modules type_heaps expr_heap cs
# (type_defs, class_defs, modules, heaps, expr_heap, cs) = checkDynamics mod_index (inc cModuleScope) dyn_type_ptrs type_defs class_defs modules type_heaps expr_heap cs
# (type_defs, class_defs, modules, heaps, expr_heap, cs) = checkDynamics mod_index cGlobalScope dyn_type_ptrs type_defs class_defs modules type_heaps expr_heap cs
(expr_heap, cs_symbol_table) = remove_global_type_variables_in_dynamics dyn_type_ptrs (expr_heap, cs.cs_symbol_table)
= (type_defs, class_defs, modules, heaps, expr_heap, { cs & cs_symbol_table = cs_symbol_table })
where
......@@ -1459,7 +1459,7 @@ where
checkDynamicTypes mod_index dyn_type_ptrs (FunDefType {st_vars}) type_defs class_defs modules type_heaps expr_heap cs=:{cs_symbol_table}
# (th_vars, cs_symbol_table) = foldSt add_type_variable_to_symbol_table st_vars (type_heaps.th_vars, cs_symbol_table)
(type_defs, class_defs, modules, heaps, expr_heap, cs)
= checkDynamics mod_index (inc cModuleScope) dyn_type_ptrs type_defs class_defs modules
= checkDynamics mod_index cGlobalScope dyn_type_ptrs type_defs class_defs modules
{ type_heaps & th_vars = th_vars } expr_heap { cs & cs_symbol_table = cs_symbol_table }
cs_symbol_table = removeVariablesFromSymbolTable cModuleScope st_vars cs.cs_symbol_table
(expr_heap, cs) = check_global_type_variables_in_dynamics dyn_type_ptrs (expr_heap, { cs & cs_symbol_table = cs_symbol_table })
......
frontend/type.icl
View file @ 955e1a8f
......@@ -2433,11 +2433,24 @@ CreateInitialSymbolTypes start_index common_defs [fun : funs] (pre_def_symbols,
(pre_def_symbols, ts) = initial_symbol_type (start_index == fun) common_defs fd (pre_def_symbols, ts)
= CreateInitialSymbolTypes start_index common_defs funs (pre_def_symbols, ts)
where
initial_symbol_type is_start_rule common_defs
{fun_type=FunDefType ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env},fun_ident,fun_lifted,fun_info={fi_dynamics},fun_pos}
(pre_def_symbols, ts=:{ts_type_heaps,ts_expr_heap,ts_td_infos,ts_error})
# ts_error = setErrorPosition fun_ident fun_pos ts_error
(st_args, ps) = addPropagationAttributesToATypes common_defs st_args
initial_symbol_type is_start_rule common_defs {fun_type=FunDefType ft,fun_ident,fun_lifted,fun_info={fi_dynamics},fun_pos} (pre_def_symbols, ts)
# ts & ts_error = setErrorPosition fun_ident fun_pos ts.ts_error
(ft_with_prop,lifted_args,fresh_fun_type,pre_def_symbols,ts)
= create_specified_symbol_type common_defs ft fun_lifted fi_dynamics pre_def_symbols ts
ts & ts_fun_env.[fun] = SpecifiedType ft_with_prop lifted_args fresh_fun_type
= (pre_def_symbols, ts)
initial_symbol_type is_start_rule common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}, fun_kind} (pre_def_symbols, ts)
# (st_gen, ts) = create_general_symboltype is_start_rule (fun_kind == FK_Caf) fun_arity fun_lifted ts
ts_type_heaps = ts.ts_type_heaps
(th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (ts_type_heaps.th_vars, ts.ts_expr_heap)
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
= fresh_dynamics fi_dynamics (ts.ts_var_store, { ts_type_heaps & th_vars = th_vars }, ts.ts_var_heap, ts_expr_heap, pre_def_symbols)
= (pre_def_symbols, { ts & ts_fun_env = {ts.ts_fun_env & [fun] = UncheckedType st_gen}, ts_var_store = ts_var_store,
ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap})
create_specified_symbol_type common_defs ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env} fun_lifted fi_dynamics
pre_def_symbols ts=:{ts_type_heaps,ts_expr_heap,ts_td_infos,ts_error}
# (st_args, ps) = addPropagationAttributesToATypes common_defs st_args
{ prop_type_heaps = ts_type_heaps, prop_td_infos = ts_td_infos,
prop_attr_vars = st_attr_vars, prop_attr_env = st_attr_env, prop_error = Yes ts_error}
(st_result, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error = Yes ts_error,prop_attr_env})
......@@ -2450,18 +2463,9 @@ where
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
= fresh_dynamics fi_dynamics (ts.ts_var_store, ts.ts_type_heaps, ts.ts_var_heap, ts.ts_expr_heap, pre_def_symbols)
= (pre_def_symbols,
{ ts & ts_fun_env = { ts.ts_fun_env & [fun] = SpecifiedType ft_with_prop lifted_args
{fresh_fun_type & tst_arity = st_arity + fun_lifted, tst_args = lifted_args ++ fresh_fun_type.tst_args, tst_lifted = fun_lifted}},
ts_var_heap = ts_var_heap, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps })
initial_symbol_type is_start_rule common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}, fun_kind} (pre_def_symbols, ts)
# (st_gen, ts) = create_general_symboltype is_start_rule (fun_kind == FK_Caf) fun_arity fun_lifted ts
ts_type_heaps = ts.ts_type_heaps
(th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (ts_type_heaps.th_vars, ts.ts_expr_heap)
(ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols)
= fresh_dynamics fi_dynamics (ts.ts_var_store, { ts_type_heaps & th_vars = th_vars }, ts.ts_var_heap, ts_expr_heap, pre_def_symbols)
= (pre_def_symbols, { ts & ts_fun_env = {ts.ts_fun_env & [fun] = UncheckedType st_gen}, ts_var_store = ts_var_store,
ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap})
fresh_fun_type & tst_arity = st_arity + fun_lifted, tst_args = lifted_args ++ fresh_fun_type.tst_args, tst_lifted = fun_lifted
ts & ts_var_heap = ts_var_heap, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps
= (ft_with_prop,lifted_args,fresh_fun_type,pre_def_symbols,ts)
create_general_symboltype :: !Bool !Bool !Int !Int !*TypeState -> (!TempSymbolType, !*TypeState)
create_general_symboltype is_start_rule is_caf nr_of_args nr_of_lifted_args ts
......
frontend/typesupport.icl
View file @ 955e1a8f
......@@ -549,13 +549,14 @@ cleanUpSymbolType is_start_rule spec_type {tst_arity,tst_args,tst_result,tst_con
(lifted_args, cus=:{cus_var_env}) = clean_up cui (take tst_lifted tst_args) cus
cui = { cui & cui_is_lifted_part = False }
(lifted_vars, cus_var_env) = determine_type_vars nr_of_temp_vars [] cus_var_env
(st_args, (_, cus)) = mapSt (clean_up_arg_type cui) (drop tst_lifted tst_args) ([], { cus & cus_var_env = cus_var_env })
cus & cus_var_env = cus_var_env
(st_args, cus) = clean_up_arg_types cui tst_lifted tst_args cus
(st_result, cus) = clean_up_result_type cui tst_result cus
(st_context, ambiguous_or_missing_contexts, cus_var_env, type_heaps, var_heap, cus_error)
= clean_up_type_contexts spec_type tst_context derived_context cus.cus_var_env cus.cus_heaps var_heap cus.cus_error
= clean_up_type_contexts spec_type tst_context derived_context common_defs cus.cus_var_env cus.cus_heaps var_heap cus.cus_error
(st_vars, cus_var_env) = determine_type_vars nr_of_temp_vars lifted_vars cus_var_env
(cus_attr_env, st_attr_vars, st_attr_env, cus_error)
= build_attribute_environment cus.cus_appears_in_lifted_part 0 max_attr_nr coercions (bitvectCreate max_attr_nr) cus.cus_attr_env [] [] cus_error
= build_attribute_environment cus.cus_appears_in_lifted_part max_attr_nr coercions cus.cus_attr_env cus_error
(expr_heap, {cuets_var_env=cus_var_env,cuets_heaps=cus_heaps})
= clean_up_expression_types case_and_let_exprs expr_heap
{cuets_var_env=cus_var_env,cuets_heaps=type_heaps,cuets_var_store=cus.cus_var_store}
......@@ -577,6 +578,25 @@ where
_
-> (all_vars, var_env)
check_type_of_start_rule is_start_rule {st_context,st_arity,st_args} cus_error
| is_start_rule
| isEmpty st_context
| st_arity > 0
| st_arity == 1
= case st_args of
[{at_type = TB BT_World} : _]
-> cus_error
_
-> startRuleError "argument of Start rule should have type World.\n" cus_error
= startRuleError "Start rule has too many arguments.\n" cus_error
= cus_error
= startRuleError "Start rule cannot be overloaded.\n" cus_error
= cus_error
clean_up_arg_types cui tst_lifted tst_args cus
# (st_args, (_, cus)) = mapSt (clean_up_arg_type cui) (drop tst_lifted tst_args) ([], cus)
= (st_args,cus)
where
clean_up_arg_type cui at=:{at_type = TFA avars type, at_attribute} (all_exi_vars, cus)
# (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus
(type, cus) = clean_up cui type cus
......@@ -616,27 +636,27 @@ where
# cus = {cus & cus_error = liftedError var cus.cus_error, cus_var_env.[var_number] = TE}
-> ([{atv_attribute=var_attr, atv_variable=var} : exi_vars], all_vars, cus)
clean_up_result_type cui at cus
# (at, cus=:{cus_exis_vars}) = clean_up cui at cus
| isEmpty cus_exis_vars
= (at, cus)
= (at, { cus & cus_error = existentialError cus.cus_error })
clean_up_type_contexts spec_type spec_context derived_context env type_heaps var_heap error
| spec_type
# (type_heaps,var_heap) = foldSt (mark_specified_context derived_context) spec_context (type_heaps,var_heap)
(derived_context,var_heap) = remove_specified_contexts derived_context var_heap
(type_heaps,var_heap) = mark_TAll_contexts derived_context spec_context type_heaps var_heap
var_heap = if (derived_context=:[]) var_heap (mark_specified_polymorphic_contexts spec_context derived_context var_heap)
(rev_contexts, ambiguous_or_missing_contexts, env, var_heap, error)
= foldSt clean_up_lifted_type_context derived_context ([], NoErrorContexts, env, var_heap, error)
(rev_contexts, ambiguous_or_missing_contexts, env, var_heap, error)
= foldSt clean_up_type_context spec_context (rev_contexts, ambiguous_or_missing_contexts, env, var_heap, error)
= (reverse rev_contexts, ambiguous_or_missing_contexts, env, type_heaps, var_heap, error)
# (rev_contexts, ambiguous_or_missing_contexts, env, type_heaps, var_heap, error)
= foldSt clean_up_type_context2 derived_context ([], NoErrorContexts, env, type_heaps, var_heap, error)
= (reverse rev_contexts, ambiguous_or_missing_contexts, env, type_heaps, var_heap, error)
clean_up_result_type cui at cus
# (at, cus=:{cus_exis_vars}) = clean_up cui at cus
| isEmpty cus_exis_vars
= (at, cus)
= (at, { cus & cus_error = existentialError cus.cus_error })
clean_up_type_contexts spec_type spec_context derived_context common_defs env type_heaps var_heap error
| spec_type
# (type_heaps,var_heap) = foldSt (mark_specified_context derived_context) spec_context (type_heaps,var_heap)
(derived_context,var_heap) = remove_specified_contexts derived_context var_heap
(type_heaps,var_heap) = mark_TAll_contexts derived_context spec_context type_heaps var_heap
var_heap = if (derived_context=:[]) var_heap (mark_specified_polymorphic_contexts spec_context derived_context var_heap)
(rev_contexts, ambiguous_or_missing_contexts, env, var_heap, error)
= foldSt clean_up_lifted_type_context derived_context ([], NoErrorContexts, env, var_heap, error)
(rev_contexts, ambiguous_or_missing_contexts, env, var_heap, error)
= foldSt clean_up_type_context spec_context (rev_contexts, ambiguous_or_missing_contexts, env, var_heap, error)
= (reverse rev_contexts, ambiguous_or_missing_contexts, env, type_heaps, var_heap, error)
# (rev_contexts, ambiguous_or_missing_contexts, env, type_heaps, var_heap, error)
= foldSt clean_up_type_context2 derived_context ([], NoErrorContexts, env, type_heaps, var_heap, error)
= (reverse rev_contexts, ambiguous_or_missing_contexts, env, type_heaps, var_heap, error)
where
mark_specified_context :: ![TypeContext] !TypeContext !*(*TypeHeaps,!*VarHeap) -> (!*TypeHeaps,!*VarHeap)
mark_specified_context [] spec_tc (type_heaps,var_heap)
= (type_heaps,var_heap)
......@@ -881,8 +901,13 @@ where
replace_TempQV_by_TAll cv_arg_types
= [if type.at_type=:TempQV _ {type & at_type=TAll} type \\ type<-cv_arg_types]
build_attribute_environment :: !LargeBitvect !Index !Index !{! CoercionTree} !*LargeBitvect !*AttributeEnv ![AttributeVar] ![AttrInequality] !*ErrorAdmin
-> (!*AttributeEnv,![AttributeVar],![AttrInequality],!*ErrorAdmin)
build_attribute_environment :: !LargeBitvect !Index !{!CoercionTree} !*AttributeEnv !*ErrorAdmin
-> (!*AttributeEnv,![AttributeVar],![AttrInequality],!*ErrorAdmin)
build_attribute_environment appears_in_lifted_part max_attr_nr coercions attr_env error
= build_attribute_environment appears_in_lifted_part 0 max_attr_nr coercions (bitvectCreate max_attr_nr) attr_env [] [] error
where
build_attribute_environment :: !LargeBitvect !Index !Index !{!CoercionTree} !*LargeBitvect !*AttributeEnv ![AttributeVar] ![AttrInequality] !*ErrorAdmin
-> (!*AttributeEnv,![AttributeVar],![AttrInequality],!*ErrorAdmin)
build_attribute_environment appears_in_lifted_part attr_group_index max_attr_nr coercions already_build_inequalities attr_env attr_vars inequalities error
| attr_group_index == max_attr_nr
= (attr_env, attr_vars, inequalities, error)
......@@ -935,66 +960,51 @@ where
is_new_inequality dem_var off_var [{ ai_demanded, ai_offered } : inequalities]
= (dem_var <> ai_demanded || off_var <> ai_offered) && is_new_inequality dem_var off_var inequalities
clean_up_expression_types :: ![ExprInfoPtr] !*ExpressionHeap !*CleanUpExprTypeState -> (!*ExpressionHeap,!*CleanUpExprTypeState)
clean_up_expression_types expr_ptrs expr_heap cuets
= foldSt clean_up_expression_type expr_ptrs (expr_heap, cuets)
where
clean_up_expression_type expr_ptr (expr_heap, cuets)
# (info, expr_heap) = readPtr expr_ptr expr_heap
= case info of
EI_CaseType case_type
# (case_type, cuets) = clean_up_expr_type case_type cuets
-> (expr_heap <:= (expr_ptr, EI_CaseType case_type), cuets)
EI_LetType let_type
# (let_type, cuets) = clean_up_expr_type let_type cuets
-> (expr_heap <:= (expr_ptr, EI_LetType let_type), cuets)
EI_DictionaryType dict_type
# (dict_type, cuets) = clean_up_expr_type dict_type cuets
-> (expr_heap <:= (expr_ptr, EI_DictionaryType dict_type), cuets)
EI_ContextWithVarContexts class_expressions var_contexts
# (var_contexts,cuets) = clean_up_var_contexts var_contexts cuets
-> (writePtr expr_ptr (EI_ContextWithVarContexts class_expressions var_contexts) expr_heap,cuets)
where
clean_up_var_contexts (VarContext arg_n type_contexts arg_atype var_contexts) cuets
# (type_contexts,cuets) = clean_up_expr_type type_contexts cuets
(arg_atype,cuets) = clean_up_expr_type arg_atype cuets
(var_contexts,cuets) = clean_up_var_contexts var_contexts cuets
= (VarContext arg_n type_contexts arg_atype var_contexts,cuets)
clean_up_var_contexts NoVarContexts cuets
= (NoVarContexts,cuets)
EI_CaseTypeWithContexts case_type constructor_contexts
# (case_type, cuets) = clean_up_expr_type case_type cuets
(constructor_contexts, cuets) = clean_up_constructor_contexts constructor_contexts cuets
-> (expr_heap <:= (expr_ptr, EI_CaseTypeWithContexts case_type constructor_contexts), cuets)
where
clean_up_constructor_contexts [(ds,type_contexts):constructor_contexts] cuets
# (type_contexts,cuets) = clean_up_type_contexts type_contexts cuets
(constructor_contexts,cuets) = clean_up_constructor_contexts constructor_contexts cuets
= ([(ds,type_contexts):constructor_contexts],cuets)
clean_up_constructor_contexts [] cuets
= ([],cuets)
clean_up_type_contexts [type_contexts=:{tc_types}:constructor_contexts] cuets
# (tc_types,cuets) = clean_up_expr_type tc_types cuets
(constructor_contexts,cuets) = clean_up_type_contexts constructor_contexts cuets
= ([{type_contexts & tc_types=tc_types}:constructor_contexts],cuets)
clean_up_type_contexts [] cuets
= ([],cuets)
check_type_of_start_rule is_start_rule {st_context,st_arity,st_args} cus_error
| is_start_rule
| isEmpty st_context
| st_arity > 0
| st_arity == 1
= case st_args of
[{at_type = TB BT_World} : _]
-> cus_error
_
-> startRuleError "argument of Start rule should have type World.\n" cus_error
= startRuleError "Start rule has too many arguments.\n" cus_error
= cus_error
= startRuleError "Start rule cannot be overloaded.\n" cus_error
= cus_error
clean_up_expression_types :: ![ExprInfoPtr] !*ExpressionHeap !*CleanUpExprTypeState -> (!*ExpressionHeap,!*CleanUpExprTypeState)
clean_up_expression_types expr_ptrs expr_heap cuets
= foldSt clean_up_expression_type expr_ptrs (expr_heap, cuets)
where
clean_up_expression_type expr_ptr (expr_heap, cuets)
# (info, expr_heap) = readPtr expr_ptr expr_heap
= case info of
EI_CaseType case_type
# (case_type, cuets) = clean_up_expr_type case_type cuets
-> (expr_heap <:= (expr_ptr, EI_CaseType case_type), cuets)
EI_LetType let_type
# (let_type, cuets) = clean_up_expr_type let_type cuets
-> (expr_heap <:= (expr_ptr, EI_LetType let_type), cuets)
EI_DictionaryType dict_type
# (dict_type, cuets) = clean_up_expr_type dict_type cuets
-> (expr_heap <:= (expr_ptr, EI_DictionaryType dict_type), cuets)
EI_ContextWithVarContexts class_expressions var_contexts
# (var_contexts,cuets) = clean_up_var_contexts var_contexts cuets
-> (writePtr expr_ptr (EI_ContextWithVarContexts class_expressions var_contexts) expr_heap,cuets)
where
clean_up_var_contexts (VarContext arg_n type_contexts arg_atype var_contexts) cuets
# (type_contexts,cuets) = clean_up_expr_type type_contexts cuets
(arg_atype,cuets) = clean_up_expr_type arg_atype cuets
(var_contexts,cuets) = clean_up_var_contexts var_contexts cuets
= (VarContext arg_n type_contexts arg_atype var_contexts,cuets)
clean_up_var_contexts NoVarContexts cuets
= (NoVarContexts,cuets)
EI_CaseTypeWithContexts case_type constructor_contexts
# (case_type, cuets) = clean_up_expr_type case_type cuets
(constructor_contexts, cuets) = clean_up_constructor_contexts constructor_contexts cuets
-> (expr_heap <:= (expr_ptr, EI_CaseTypeWithContexts case_type constructor_contexts), cuets)
where
clean_up_constructor_contexts [(ds,type_contexts):constructor_contexts] cuets
# (type_contexts,cuets) = clean_up_type_contexts type_contexts cuets
(constructor_contexts,cuets) = clean_up_constructor_contexts constructor_contexts cuets
= ([(ds,type_contexts):constructor_contexts],cuets)
clean_up_constructor_contexts [] cuets
= ([],cuets)
clean_up_type_contexts [type_contexts=:{tc_types}:constructor_contexts] cuets
# (tc_types,cuets) = clean_up_expr_type tc_types cuets
(constructor_contexts,cuets) = clean_up_type_contexts constructor_contexts cuets
= ([{type_contexts & tc_types=tc_types}:constructor_contexts],cuets)
clean_up_type_contexts [] cuets
= ([],cuets)
/*
In 'bindInstances t1 t2' type variables of t1 are bound to the corresponding subtypes of t2, provided that
......
Markdown is supported
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