Commit e4ea68cd authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏢
Browse files

major rewrite dynamics

parent e5c806d3
......@@ -916,7 +916,7 @@ convertSelector moduleIndex selectorDefs is_strict {fs_index}
declareDynamicTemp :: PredefinedSymbols -> BackEnder
declareDynamicTemp predefs
= appBackEnd (BEDeclareDynamicTypeSymbol predefs.[PD_StdDynamic].pds_def predefs.[PD_DynamicTemp].pds_def)
= appBackEnd (BEDeclareDynamicTypeSymbol predefs.[PD_StdDynamic].pds_def predefs.[PD_Dyn_DynamicTemp].pds_def)
predefineSymbols :: DclModule PredefinedSymbols -> BackEnder
predefineSymbols {dcl_common} predefs
......@@ -1693,7 +1693,8 @@ convertRootExpr aliasDummyId (Case kees=:{case_expr, case_guards}) main_dcl_modu
Yes ident
-> DefaultCaseFail ident
_
-> abort "backendconvert:defaultCase, case without id"
-> DefaultCaseFail {id_name="kees_be", id_info=nilPtr}
// -> abort "backendconvert:defaultCase, case without id"
// otherwise
= DefaultCaseNone
convertRootExpr _ (FailExpr fail_ident) _
......@@ -1826,6 +1827,8 @@ where
= beFunctionSymbol glob_object glob_module
convertSymbol {symb_kind=SK_LocalMacroFunction glob_object}
= beFunctionSymbol glob_object main_dcl_module_n
convertSymbol {symb_kind=SK_GeneratedCaseFunction _ index}
= beFunctionSymbol index main_dcl_module_n
convertSymbol {symb_kind=SK_GeneratedFunction _ index}
= beFunctionSymbol index main_dcl_module_n
convertSymbol {symb_kind=SK_GeneratedCaseFunction _ index}
......
......@@ -2453,7 +2453,8 @@ check_module2 mod_name mod_modification_time mod_imported_objects mod_imports mo
(x_main_dcl_module,cs) = cs!cs_x.x_main_dcl_module_n
cs = cs
<=< adjustPredefSymbol PD_ModuleConsSymbol x_main_dcl_module STE_Constructor
<=< adjustPredefSymbol PD_ModuleConsSymbol x_main_dcl_module STE_Constructor
(dcl_modules, icl_functions,macro_defs,hp_expression_heap, cs)
= checkExplicitImportCompleteness imports.si_explicit dcl_modules icl_functions macro_defs heaps.hp_expression_heap cs
......@@ -3387,19 +3388,19 @@ where
# (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdDynamic]
| pre_mod.pds_def == mod_index
= (class_members, class_instances, fun_types, { cs & cs_predef_symbols = cs_predef_symbols}
<=< adjustPredefSymbol PD_TypeObjectType mod_index STE_Type
<=< adjustPredefSymbol PD_TypeConsSymbol mod_index STE_Constructor
<=< adjustPredefSymbol PD_PV_Placeholder mod_index STE_Constructor
<=< adjustPredefSymbol PD_UPV_Placeholder mod_index STE_Constructor
<=< adjustPredefSymbol PD_UV_Placeholder mod_index STE_Constructor
<=< adjustPredefSymbol PD_unify mod_index STE_DclFunction
<=< adjustPredefSymbol PD_coerce mod_index STE_DclFunction
<=< adjustPredefSymbol PD_undo_indirections mod_index STE_DclFunction
<=< adjustPredefSymbol PD_DynamicTemp mod_index STE_Type
<=< adjustPredefSymbol PD_DynamicType mod_index (STE_Field unused)
<=< adjustPredefSymbol PD_DynamicValue mod_index (STE_Field unused)
<=< adjustPredefSymbol PD_TypeID mod_index STE_Type
<=< adjustPredefSymbol PD_ModuleID mod_index STE_Constructor)
<=< adjustPredefSymbol PD_Dyn_DynamicTemp mod_index STE_Type
<=< adjustPredefSymbol PD_Dyn_Type mod_index STE_Type
<=< adjustPredefSymbol PD_Dyn_TypeScheme mod_index STE_Constructor
<=< adjustPredefSymbol PD_Dyn_TypeApp mod_index STE_Constructor
<=< adjustPredefSymbol PD_Dyn_TypeVar mod_index STE_Constructor
<=< adjustPredefSymbol PD_Dyn_TypePatternVar mod_index STE_Constructor
<=< adjustPredefSymbol PD_Dyn_ModuleID mod_index STE_Constructor
<=< adjustPredefSymbol PD_Dyn_Unifier mod_index STE_Type
<=< adjustPredefSymbol PD_Dyn_unify mod_index STE_DclFunction
<=< adjustPredefSymbol PD_Dyn_initial_unifier mod_index STE_DclFunction
<=< adjustPredefSymbol PD_Dyn_normalise mod_index STE_DclFunction
<=< adjustPredefSymbol PD_Dyn_bind_global_type_pattern_var mod_index STE_DclFunction)
# (pre_mod, cs_predef_symbols) = cs_predef_symbols![PD_StdGeneric]
# type_bimap = predefined_idents.[PD_TypeBimap]
| pre_mod.pds_def == mod_index
......
......@@ -7,7 +7,7 @@ switch_import_syntax one_point_three two_point_zero :== two_point_zero
SwitchPreprocessor preprocessor no_preprocessor :== preprocessor
SwitchGenerics on off :== off
SwitchGenerics on off :== on
SwitchGenericInfo on off :== on
// MV...
......@@ -16,5 +16,5 @@ SwitchGenericInfo on off :== on
USE_DummyModuleName yes no :== yes
switch_dynamics on off :== off; // to turn dynamics on or off
switch_dynamics on off :== on; // to turn dynamics on or off
// ...MV
......@@ -7,7 +7,7 @@ switch_import_syntax one_point_three two_point_zero :== two_point_zero
SwitchPreprocessor preprocessor no_preprocessor :== preprocessor
SwitchGenerics on off :== off
SwitchGenerics on off :== on
SwitchGenericInfo on off :== on
// MV...
......@@ -16,5 +16,5 @@ SwitchGenericInfo on off :== on
USE_DummyModuleName yes no :== yes
switch_dynamics on off :== off; // to turn dynamics on or off
switch_dynamics on off :== on; // to turn dynamics on or off
// ...MV
......@@ -3,16 +3,8 @@
*/
definition module convertDynamics
import syntax, transform, convertcases
import syntax, transform
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule /* TD */ [String]
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, Optional *File)
/*
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Group} !*{#FunDef} !*PredefinedSymbols
!*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap)
*/
get_module_id_app :: !*PredefinedSymbols -> (App,Expression,!*PredefinedSymbols)
/*
module owner: Martijn Vervoort
module owner: Ronny Wichers Schreur
*/
implementation module convertDynamics
import syntax, transform, utilities, convertcases, compilerSwitches, trans
import syntax, transform, utilities, convertcases, compilerSwitches
// import RWSDebug
from type_io_common import PredefinedModuleName
// Optional
USE_TUPLES tuple b :== b; // change also StdDynamic.icl and recompile all applications
extended_unify_and_coerce no yes :== no; // change also _unify and _coerce in StdDynamic
import type_io;
import type_io;
//import pp;
/*2.0
from type_io_common import class toString (..),instance toString GlobalTCType;
0.2*/
:: *ConversionInfo =
:: *ConversionState =
{ ci_predef_symb :: !*PredefinedSymbols
, ci_var_heap :: !*VarHeap
, ci_expr_heap :: !*ExpressionHeap
, ci_new_variables :: ![FreeVar]
, ci_new_functions :: ![FunctionInfoPtr]
, ci_fun_heap :: !*FunctionHeap
, ci_next_fun_nr :: !Index
, ci_type_pattern_var_count :: !Int
// data needed to generate coercions
, ci_placeholders_and_tc_args :: [(!BoundVar,Ptr VarInfo)]
, ci_generated_global_tc_placeholders :: !Bool
, ci_used_tcs :: [Ptr VarInfo]
, ci_symb_ident :: SymbIdent
, ci_sel_type_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol))
, ci_sel_value_field :: Expression -> Expression //Optional (!Int,!(Global DefinedSymbol))
, ci_module_id_symbol :: Expression
, ci_internal_type_id :: Expression
, ci_module_id :: Optional LetBind
, ci_type_id :: !Optional TypeSymbIdent
, ci_module_id_symbol :: Expression
, ci_module_id_var :: Optional LetBind
, ci_type_constructor_used_in_dynamic_patterns :: !*{#Bool}
}
:: DynamicRepresentation =
{ dr_type_ident :: SymbIdent
, dr_dynamic_type :: Global Index
, dr_dynamic_symbol :: Global DefinedSymbol
}
:: ConversionInput =
{ cinp_glob_type_inst :: !{! GlobalTCType}
, cinp_group_index :: !Int
, cinp_dynamic_representation :: DynamicRepresentation
, cinp_st_args :: ![FreeVar]
, cinp_subst_var :: !BoundVar
}
:: OpenedDynamic =
{ opened_dynamic_expr :: Expression
, opened_dynamic_type :: Expression
}
:: DefaultExpression :== Optional (BoundVar, [IndirectionVar]) //DefaultRecord
:: BoundVariables :== [TypedVariable]
:: IndirectionVar :== BoundVar
pl [] = ""
pl [x:xs] = x +++ " , " +++ (pl xs)
F :: !a .b -> .b
F a b = b
......@@ -132,111 +115,35 @@ f (Yes tcl_file)
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional *File) {# DclModule} !IclModule [String]
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, (Optional *File))
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file dcl_mods icl_mod directly_imported_dcl_modules
# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
= case (pds_module == (-1) || pds_def == (-1)) of
True
-> (undef,undef,undef,predefined_symbols)
_
-> case (USE_TUPLES True False) of
True
# arity = 2
// get tuple arity 2 constructor
# ({pds_module, pds_def}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity]
# pds_ident = predefined_idents.[GetTupleConsIndex arity]
# twoTuple_symb = { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def} }
// get tuple, type and value selectors
# ({pds_def}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity]
# pds_ident = predefined_idents.[GetTupleConsIndex arity]
# twotuple = {ds_ident = pds_ident, ds_arity = arity, ds_index = pds_def}
# type_selector = TupleSelect twotuple 1
# value_selector = TupleSelect twotuple 0
-> (twoTuple_symb,value_selector,type_selector,predefined_symbols)
False
# arity = 2
# ({pds_module=pds_module1, pds_def=pds_def1} , predefined_symbols) = predefined_symbols![PD_DynamicTemp]
# {td_rhs=RecordType {rt_constructor,rt_fields}} = common_defs.[pds_module1].com_type_defs.[pds_def1]
# dynamic_temp_symb_ident
= { SymbIdent |
symb_name = rt_constructor.ds_ident
, symb_kind = SK_Constructor {glob_module = pds_module1, glob_object = rt_constructor.ds_index}
}
// type field
# ({pds_module=pds_module2, pds_def=pds_def2} , predefined_symbols) = predefined_symbols![PD_DynamicType]
# {sd_field,sd_field_nr}
= common_defs.[pds_module2].com_selector_defs.[pds_def2]
#! type_defined_symbol
= { Global |
glob_object = { DefinedSymbol |
ds_ident = sd_field
, ds_arity = 0
, ds_index = pds_def2
}
, glob_module = pds_module2
}
#! ci_sel_type_field
= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection type_defined_symbol sd_field_nr])
// value field
# ({pds_module=pds_module3, pds_def=pds_def3} , predefined_symbols) = predefined_symbols![PD_DynamicValue]
# {sd_field=sd_field3,sd_field_nr=sd_field_nr3}
= common_defs.[pds_module3].com_selector_defs.[pds_def3]
#! value_defined_symbol
= { Global |
glob_object = { DefinedSymbol |
ds_ident = sd_field3
, ds_arity = 0
, ds_index = pds_def3
}
, glob_module = pds_module3
}
#! ci_sel_value_field
= (\dynamic_expr -> Selection NormalSelector dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3])
-> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols)
# (module_symb,module_id_app,predefined_symbols)
#! (dynamic_representation,predefined_symbols)
= create_dynamic_and_selector_idents common_defs predefined_symbols
/*
# (module_symb,module_id,predefined_symbols)
= get_module_id_app predefined_symbols
# ({pds_module=pds_type_id_module, pds_def=pds_type_id_def} , predefined_symbols) = predefined_symbols![PD_TypeID]
# ci_type_id
= case (pds_type_id_module == NoIndex || pds_type_id_def == NoIndex) of
True
-> No
_
# {td_name} = common_defs.[pds_type_id_module].com_type_defs.[pds_type_id_def]
# ci_type_id
= {
type_name = td_name
, type_arity = 0
, type_index = { glob_object = pds_type_id_def, glob_module = pds_type_id_module}
, type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }
};
-> Yes ci_type_id
# type_id
= { type_name = common_defs.[pds_type_id_module].com_type_defs.[pds_type_id_def].td_name
, type_arity = 0
, type_index = { glob_object = pds_type_id_def, glob_module = pds_type_id_module}
, type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }
}
*/
# type_id = undef
# (module_symb,module_id,predefined_symbols)
= get_module_id_app predefined_symbols
#! nr_of_funs = size fun_defs
#! s_global_type_instances = size global_type_instances
# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
# (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_fun_heap, ci_new_functions, ci_type_constructor_used_in_dynamic_patterns}))
= convert_groups 0 groups global_type_instances (fun_defs, {
# (groups, (fun_defs, {ci_predef_symb, ci_var_heap, ci_expr_heap, ci_type_constructor_used_in_dynamic_patterns}))
= convert_groups 0 groups global_type_instances type_id module_id dynamic_representation (fun_defs, {
ci_predef_symb = predefined_symbols, ci_var_heap = var_heap, ci_expr_heap = expr_heap,
ci_new_functions = [], ci_new_variables = [], ci_fun_heap = newHeap, ci_next_fun_nr = nr_of_funs, ci_placeholders_and_tc_args = [],
ci_generated_global_tc_placeholders = False,
ci_used_tcs = [],ci_symb_ident = dynamic_temp_symb_ident , ci_sel_type_field = ci_sel_type_field, ci_sel_value_field = ci_sel_value_field,
ci_new_variables = [],
ci_type_pattern_var_count = 0,
ci_module_id_symbol = App module_symb,
ci_internal_type_id = module_id_app,
ci_module_id = No,
ci_type_id = ci_type_id,
ci_module_id_var = No,
ci_type_constructor_used_in_dynamic_patterns = createArray s_global_type_instances False
})
(groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
// store type info
# (tcl_file,type_heaps,ci_predef_symb)
......@@ -256,16 +163,15 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> (Yes tcl_file,type_heaps,ci_predef_symb)
= (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
= (groups, fun_defs, ci_predef_symb, imported_types, [], ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
where
convert_groups group_nr groups global_type_instances fun_defs_and_ci
convert_groups group_nr groups global_type_instances type_id module_id dynamic_representation fun_defs_and_ci
| group_nr == size groups
= (groups, fun_defs_and_ci)
# (group, groups) = groups![group_nr]
= convert_groups (inc group_nr) groups global_type_instances (foldSt (convert_function group_nr global_type_instances) group.group_members fun_defs_and_ci)
= convert_groups (inc group_nr) groups global_type_instances type_id module_id dynamic_representation (foldSt (convert_function group_nr global_type_instances type_id module_id dynamic_representation) group.group_members fun_defs_and_ci)
convert_function group_nr global_type_instances fun (fun_defs, ci)
convert_function group_nr global_type_instances type_id module_id dynamic_representation fun (fun_defs, ci)
# (fun_def, fun_defs) = fun_defs![fun]
{fun_body, fun_type, fun_info} = fun_def
| isEmpty fun_info.fi_dynamics
......@@ -275,874 +181,596 @@ where
// of its use. In some very specific cases, the let generated here is superfluous.
# (TransformedBody fun_body=:{tb_rhs})
= fun_body
# (_,ci)
= get_module_idN ci
# (tb_rhs,ci)
= build_type_identification tb_rhs ci
# (tb_rhs, ci)
= share_module_identification tb_rhs module_id ci
# fun_body
= {fun_body & tb_rhs = tb_rhs}
# fun_body
= TransformedBody fun_body
# ci
= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False }
# (TransformedBody fun_body=:{tb_rhs}, ci) = convert_dynamics_in_body {cinp_st_args = [], cinp_glob_type_inst = global_type_instances, cinp_group_index = group_nr} fun_body fun_type ci
# fun_body
= TransformedBody fun_body
# (unify_subst_var, ci)
= newVariable "unify_subst" VI_Empty ci
# ci
= {ci & ci_type_pattern_var_count = 0}
# (fun_body, ci) = convertDynamics {cinp_st_args = [], cinp_dynamic_representation = dynamic_representation,
cinp_glob_type_inst = global_type_instances,
cinp_subst_var = unify_subst_var} fun_body ci
= ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}},
{ ci & ci_new_variables = [] })
where
get_module_idN ci=:{ci_internal_type_id}
share_module_identification rhs module_id ci
# (dst=:{var_info_ptr},ci)
= newVariable "module_id" VI_Empty ci
# dst_fv
= varToFreeVar dst 1
# let_bind
= { lb_src = ci_internal_type_id
= { lb_src = module_id
, lb_dst = dst_fv
, lb_position = NoPos
}
# ci
= { ci &
ci_new_variables = [ dst_fv : ci.ci_new_variables ]
, ci_module_id = Yes let_bind
, ci_module_id_var = Yes let_bind
}
= (Var dst,ci)
// identification of types generated by the compiler. If there is no TypeConsSymbol, then
// no identification is necessary.
build_type_identification dyn_type_code ci=:{ci_module_id=No}
= abort "no ptr"; //(dyn_type_code,ci)
build_type_identification dyn_type_code ci=:{ci_module_id=Yes let_bind}
# (let_info_ptr, ci) = typed_let_ptr ci
# letje
# (let_info_ptr, ci) = let_ptr2 [toAType TE] ci
# rhs
= Let { let_strict_binds = [],
let_lazy_binds = [let_bind],
let_expr = dyn_type_code,
let_expr = rhs,
let_info_ptr = let_info_ptr,
let_expr_position = NoPos
}
= (letje,ci)
convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_context, st_args}) ci
# vars_with_types = bindVarsToTypes2 st_context tb_args st_args [] common_defs
(tb_rhs, ci) = convertDynamics {global_type_instances & cinp_st_args = tb_args} vars_with_types No tb_rhs ci
= (TransformedBody {tb_args = tb_args,tb_rhs = tb_rhs}, ci)
convert_dynamics_in_body global_type_instances other fun_type ci
= abort "unexpected value in 'convert dynamics.convert_dynamics_in_body'"
bindVarsToTypes2 st_context vars types typed_vars common_defs
:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
bindVarsToTypes vars types typed_vars
= fold2St bind_var_to_type vars types typed_vars
where
bind_var_to_type var type typed_vars
= [{tv_free_var = var, tv_type = type } : typed_vars]
class convertDynamics a :: !ConversionInput !BoundVariables !DefaultExpression !a !*ConversionInfo -> (!a, !*ConversionInfo)
instance convertDynamics [a] | convertDynamics a
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression ![a] !*ConversionInfo -> (![a], !*ConversionInfo) | convertDynamics a
convertDynamics cinp bound_vars default_expr xs ci = mapSt (convertDynamics cinp bound_vars default_expr) xs ci
instance convertDynamics (Optional a) | convertDynamics a
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Optional a) !*ConversionInfo -> (!Optional a, !*ConversionInfo) | convertDynamics a
convertDynamics cinp bound_vars default_expr (Yes x) ci
# (x, ci) = convertDynamics cinp bound_vars default_expr x ci
= (Yes x, ci)
convertDynamics _ _ _ No ci
= (No, ci)
instance convertDynamics LetBind
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !LetBind !*ConversionInfo -> (!LetBind, !*ConversionInfo)
convertDynamics cinp bound_vars default_expr binding=:{lb_src} ci
# (lb_src, ci) = convertDynamics cinp bound_vars default_expr lb_src ci
= ({binding & lb_src = lb_src}, ci)
instance convertDynamics (Bind a b) | convertDynamics a
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !(Bind a b) !*ConversionInfo -> (!Bind a b, !*ConversionInfo) | convertDynamics a
convertDynamics cinp bound_vars default_expr binding=:{bind_src} ci
# (bind_src, ci) = convertDynamics cinp bound_vars default_expr bind_src ci
= ({binding & bind_src = bind_src}, ci)
convertDynamicsOfAlgebraicPattern :: !ConversionInput !BoundVariables !DefaultExpression !(!AlgebraicPattern,[AType]) !*ConversionInfo -> (!AlgebraicPattern,!*ConversionInfo)
convertDynamicsOfAlgebraicPattern cinp bound_vars default_expr (algebraic_pattern=:{ap_vars, ap_expr}, arg_types_of_conses) ci
# (ap_expr, ci) = convertDynamics cinp (bindVarsToTypes ap_vars arg_types_of_conses bound_vars) default_expr ap_expr ci
= ({algebraic_pattern & ap_expr = ap_expr}, ci)
instance convertDynamics BasicPattern
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !BasicPattern !*ConversionInfo -> (!BasicPattern, !*ConversionInfo)
convertDynamics cinp bound_vars default_expr basic_pattern=:{bp_expr} ci
# (bp_expr, ci) = convertDynamics cinp bound_vars default_expr bp_expr ci
= ({basic_pattern & bp_expr = bp_expr}, ci)
= (rhs, ci)
class convertDynamics a :: !ConversionInput !a !*ConversionState -> (!a, !*ConversionState)
instance convertDynamics [a] | convertDynamics a where
convertDynamics cinp xs ci
= mapSt (convertDynamics cinp) xs ci
instance convertDynamics (Optional a) | convertDynamics a where
convertDynamics cinp (Yes x) ci
# (x, ci)
= convertDynamics cinp x ci
= (Yes x, ci)
convertDynamics _ No ci
= (No, ci)
instance convertDynamics FunctionBody where
convertDynamics cinp (TransformedBody body) ci
# (body, ci)
= convertDynamics cinp body ci
= (TransformedBody body, ci)
instance convertDynamics TransformedBody where
convertDynamics cinp body=:{tb_args,tb_rhs} ci=:{ci_var_heap}
// this actually marks all arguments as type terms (also the regular arguments
// and dictionaries)
# ci_var_heap
= foldSt mark_var tb_args ci_var_heap
# (tb_rhs, ci)
= convertDynamics cinp tb_rhs {ci & ci_var_heap = ci_var_heap}
# (global_tpvs, subst, ci)
= foldSt collect_global_type_pattern_var tb_args ([], cinp.cinp_subst_var, ci)
# (tb_rhs, ci)
= share_init_subst subst global_tpvs tb_rhs ci
= ({body & tb_rhs = tb_rhs}, ci)
where
mark_var :: FreeVar *VarHeap -> *VarHeap
mark_var {fv_info_ptr} var_heap
= writePtr fv_info_ptr (VI_TypeCodeVariable TCI_TypeTerm) var_heap
collect_global_type_pattern_var :: FreeVar ([LetBind], BoundVar, *ConversionState) -> ([LetBind], BoundVar, *ConversionState)
collect_global_type_pattern_var {fv_info_ptr} (l, subst, ci)
# (var_info, ci_var_heap)
= readPtr fv_info_ptr ci.ci_var_heap
# ci
= {ci & ci_var_heap = ci_var_heap}
= case var_info of
VI_TypeCodeVariable (TCI_TypeVar tpv)
# (bind_global_tpv_symb, ci)
= getSymbol PD_Dyn_bind_global_type_pattern_var SK_Function 3 ci
# type_code
= {var_name = a_ij_var_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
# (unify_subst_var, ci)
= newVariable "gtpv_subst" VI_Empty ci
unify_subst_fv
= varToFreeVar unify_subst_var 1
# let_bind
= { lb_src = App { app_symb = bind_global_tpv_symb,
app_args = [tpv, Var type_code, Var unify_subst_var],
app_info_ptr = nilPtr }
, lb_dst = varToFreeVar subst 1
, lb_position = NoPos
}
-> ([let_bind:l], unify_subst_var, ci)
_
-> (l, subst, ci)
share_init_subst :: BoundVar [LetBind] Expression *ConversionState
-> (Expression, *ConversionState)
share_init_subst subst global_tpv_binds rhs ci=:{ci_type_pattern_var_count}
# (initial_unifier_symb, ci)
= getSymbol PD_Dyn_initial_unifier SK_Function 1 ci