Newer
Older
import syntax, transform, utilities, convertcases /* MV ... */, compilerSwitches /* ... MV */
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 pp;
APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== yes
import type_io;
:: *ConversionInfo =
{ 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_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
}
:: ConversionInput =
{ cinp_glob_type_inst :: !{! GlobalTCType}
, cinp_group_index :: !Int
}
:: OpenedDynamic =
{ opened_dynamic_expr :: Expression
, opened_dynamic_type :: Expression
}
:: DefaultExpression :== Optional (BoundVar, [IndirectionVar]) //DefaultRecord
:: BoundVariables :== [TypedVariable]
pl [] = ""
pl [x:xs] = x +++ " , " +++ (pl xs)
//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] !*TypeHeaps -> (.Bool,.File,!*TypeHeaps)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules type_heaps
# write_type_info_state2
= { WriteTypeInfoState |
wtis_type_heaps = type_heaps
, wtis_n_type_vars = 0
};
# (j,tcl_file)
= fposition tcl_file
// | True
// = abort ("TypeVar " +++ toString j)
#! (tcl_file,write_type_info_state)
= write_type_info common_defs tcl_file write_type_info_state2
#! (tcl_file,write_type_info_state)
= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
#! (type_heaps,_)
= f write_type_info_state //!type_heaps;
#! tcl_file
= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
#! tcl_file
= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
= (True,tcl_file,type_heaps)
where
f write_type_info_state=:{wtis_type_heaps}
= (wtis_type_heaps,{write_type_info_state & wtis_type_heaps = abort "convertDynamics.icl"});
//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String]
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File))
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules
# (tcl_file,type_heaps)
= case tcl_file of
No
-> (No,type_heaps)
# (ok,tcl_file,type_heaps)
= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules type_heaps
| not ok
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> (Yes tcl_file,type_heaps)
# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
#! (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) /*(pds_module == (-1) || pds_def == (-1))*/ of
True
# arity = 2
// get tuple arity 2 constructor
# ({pds_module, pds_def, pds_ident}, predefined_symbols) = predefined_symbols![GetTupleConsIndex arity]
# twoTuple_symb = { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity }
// get tuple, type and value selectors
# ({pds_def, pds_ident}, predefined_symbols) = predefined_symbols![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}
, symb_arity = rt_constructor.ds_arity
}
// 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 No 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 No 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)
= get_module_id_app predefined_symbols
# 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}))
= convert_groups 0 groups global_type_instances (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_module_id_symbol = App module_symb,
ci_internal_type_id = module_id_app,
ci_module_id = No })
(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
= (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)
where
convert_groups group_nr groups global_type_instances 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_function group_nr global_type_instances fun (fun_defs, ci)
# (fun_def, fun_defs) = fun_defs![fun]
{fun_body, fun_type, fun_info} = fun_def
| isEmpty fun_info.fi_dynamics
= (fun_defs, ci)
# ci
= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False }
# (fun_body, 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_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 = [] })
// MV ..
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
// .. MV
(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'"
// MV ..
bindVarsToTypes2 st_context vars types typed_vars common_defs
:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
// .. MV
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)
instance convertDynamics Expression
where
convertDynamics :: !ConversionInput !BoundVariables !DefaultExpression !Expression !*ConversionInfo -> (!Expression, !*ConversionInfo)
convertDynamics cinp bound_vars default_expr (Var var) ci
= (Var var, ci)
convertDynamics cinp bound_vars default_expr (App appje=:{app_args}) ci
# (app_args,ci) = convertDynamics cinp bound_vars default_expr app_args ci
= (App {appje & app_args = app_args}, ci)
convertDynamics cinp bound_vars default_expr (expr @ exprs) ci
# (expr, ci) = convertDynamics cinp bound_vars default_expr expr ci
(exprs, ci) = convertDynamics cinp bound_vars default_expr exprs ci
= (expr @ exprs, ci)
convertDynamics cinp bound_vars default_expr (Let letje=:{let_strict_binds, let_lazy_binds, let_expr,let_info_ptr}) ci
# (let_types, ci) = determine_let_types let_info_ptr ci
// MW0 bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
bound_vars = bindVarsToTypes [ bind.lb_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
(let_strict_binds, ci) = convertDynamics cinp bound_vars default_expr let_strict_binds ci
(let_lazy_binds, ci) = convertDynamics cinp bound_vars default_expr let_lazy_binds ci
(let_expr, ci) = convertDynamics cinp bound_vars default_expr let_expr ci
= (Let { letje & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr}, ci)
where
determine_let_types let_info_ptr ci=:{ci_expr_heap}
# (EI_LetType let_types, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap
= (let_types, { ci & ci_expr_heap = ci_expr_heap })
convertDynamics cinp bound_vars default_expr (Case keesje=:{case_expr, case_guards, case_default, case_info_ptr}) ci
# (case_expr, ci) = convertDynamics cinp bound_vars default_expr case_expr ci
(case_default, ci) = convertDynamics cinp bound_vars default_expr case_default ci
(this_case_default, nested_case_default, ci) = determine_defaults case_default default_expr ci
(EI_CaseType {ct_cons_types, ct_result_type}, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap
ci = { ci & ci_expr_heap = ci_expr_heap }
= case case_guards of
(AlgebraicPatterns type algebraic_patterns)
Martijn Vervoort
committed
// MV DEFAULT ...
| not (isNo this_case_default) && any (\algebraic_pattern -> is_case_without_default algebraic_pattern) algebraic_patterns
// a default to be moved inwards and a root positioned case not having a default
//
// Example:
// loadandrun2 :: ![(!Dynamic, !Dynamic)] !*World -> *World
// loadandrun2 [(f :: BatchProcess i o, input :: i)] world = abort "alt BatchProcess"
// loadandrun2 [(f :: InteractiveProcess i o, input :: i)] world = abort "alt InteractiveProcess"
// loadandrun2 _ _ = abort "Loader: process and input do not match"
//
# (Yes old_case_default) = this_case_default
Sjaak Smetsers
committed
// # (let_info_ptr, ci) = let_ptr ci
Martijn Vervoort
committed
# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_annotation=AN_None,at_type=TE}) ci
# default_fv = varToFreeVar default_var 1
# ci
= { ci & ci_new_variables = [default_fv : ci.ci_new_variables]}
# let_bind = {
lb_src = old_case_default
, lb_dst = default_fv
, lb_position = NoPos }
# (new_case_default, nested_case_default, ci)
= determine_defaults (Yes (Var default_var)) default_expr ci
# algebraic_patterns
= map (patch_defaults new_case_default) algebraic_patterns
# (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
(zip2 algebraic_patterns ct_cons_types) ci
Sjaak Smetsers
committed
/* Sjaak */
# (let_info_ptr, ci) = let_ptr 1 ci
Martijn Vervoort
committed
# letje
= Let {
let_strict_binds = []
, let_lazy_binds = [let_bind]
, let_expr = Case {keesje & case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = new_case_default }
, let_info_ptr = let_info_ptr
, let_expr_position = NoPos
}
-> (letje,ci)
# (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
(zip2 algebraic_patterns ct_cons_types) ci
-> (Case {keesje & case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = this_case_default}, ci)
// ... MV DEFAULT
(BasicPatterns type basic_patterns)
# (basic_patterns, ci) = convertDynamics cinp bound_vars nested_case_default basic_patterns ci
-> (Case {keesje & case_expr = case_expr, case_guards = BasicPatterns type basic_patterns, case_default = this_case_default}, ci)
(OverloadedListPatterns type decons_expr algebraic_patterns)
# (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
(zip2 algebraic_patterns ct_cons_types) ci
-> (Case {keesje & case_expr = case_expr, case_guards = OverloadedListPatterns type decons_expr algebraic_patterns, case_default = this_case_default}, ci)
(DynamicPatterns dynamic_patterns)
# keesje = {keesje & case_expr = case_expr, case_default = this_case_default}
-> convertDynamicPatterns cinp bound_vars keesje ci
NoPattern
-> (Case {keesje & case_expr = case_expr, case_guards = NoPattern, case_default = this_case_default}, ci)
_
-> abort "unexpected value in convertDynamics: 'convertDynamics.CasePatterns'"
Martijn Vervoort
committed
// MV DEFAULT ...
where
is_case_without_default {ap_expr=Case {case_default=No}} = True
is_case_without_default _ = False
patch_defaults this_case_default ap=:{ap_expr=Case keesje=:{case_default=No}}
= { ap & ap_expr = Case {keesje & case_default = this_case_default} }
patch_defaults _ expr
= expr
// ... MV DEFAULT
convertDynamics cinp bound_vars default_expr (Selection opt_symb expression selections) ci
# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
= (Selection opt_symb expression selections, ci)
convertDynamics cinp bound_vars default_expr (Update expression1 selections expression2) ci
# (expression1,ci) = convertDynamics cinp bound_vars default_expr expression1 ci
# (expression2,ci) = convertDynamics cinp bound_vars default_expr expression2 ci
= (Update expression1 selections expression2, ci)
convertDynamics cinp bound_vars default_expr (RecordUpdate cons_symbol expression expressions) ci
# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
# (expressions,ci) = convertDynamics cinp bound_vars default_expr expressions ci
= (RecordUpdate cons_symbol expression expressions, ci)
convertDynamics cinp bound_vars default_expr (TupleSelect definedSymbol int expression) ci
# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
= (TupleSelect definedSymbol int expression, ci)
convertDynamics _ _ _ (BasicExpr basicValue basicType) ci
= (BasicExpr basicValue basicType, ci)
convertDynamics _ _ _ (AnyCodeExpr codeBinding1 codeBinding2 strings) ci
= (AnyCodeExpr codeBinding1 codeBinding2 strings, ci)
convertDynamics _ _ _ (ABCCodeExpr strings bool) ci
= (ABCCodeExpr strings bool, ci)
convertDynamics cinp bound_vars default_expr (MatchExpr opt_symb symb expression) ci
# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
= (MatchExpr opt_symb symb expression, ci)
/* Sjaak ... */
convertDynamics cinp bound_vars default_expr (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_type_code}) ci=:{ci_symb_ident}
# (dyn_expr, ci) = convertDynamics cinp bound_vars default_expr dyn_expr ci
(_,dyn_type_code, _, _, ci) = convertTypecode2 cinp dyn_type_code False [] [] {ci & ci_module_id = No}
# (dyn_type_code,ci)
= build_type_identification dyn_type_code ci
= (App { app_symb = ci_symb_ident,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr }, ci)
/* ... Sjaak */
/* WAS ...
convertDynamics cinp bound_vars default_expr (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_uni_vars, dyn_type_code}) ci=:{ci_symb_ident}
# (let_binds, ci) = createVariables dyn_uni_vars [] ci
(dyn_expr, ci) = convertDynamics cinp bound_vars default_expr dyn_expr ci
(_,dyn_type_code,_,_,ci) = convertTypecode2 cinp dyn_type_code False [] [] ci
[] -> (App { app_symb = ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident, //twoTuple_symb,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr }, ci)
Sjaak Smetsers
committed
/* Sjaak */
_ # (let_info_ptr, ci) = let_ptr (length let_binds) ci
-> ( Let { let_strict_binds = [],
let_lazy_binds = let_binds,
let_expr = App { app_symb = ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr },
let_info_ptr = let_info_ptr,
let_expr_position = NoPos}, ci)
convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
convertDynamics cinp bound_vars default_expr EE ci
= (EE, ci)
convertDynamics cinp bound_vars default_expr expression ci
= abort "unexpected value in convertDynamics: 'convertDynamics.Expression'"
// 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}
= (dyn_type_code,ci)
build_type_identification dyn_type_code ci=:{ci_module_id=Yes let_bind}
# (let_info_ptr, ci) = let_ptr 1 ci
# letje
= Let { let_strict_binds = [],
let_lazy_binds = [let_bind],
let_expr = dyn_type_code,
let_info_ptr = let_info_ptr,
let_expr_position = NoPos
}
= (letje,ci)
//convertTypecode :: !ConversionInput TypeCodeExpression !*ConversionInfo -> (Expression,!*ConversionInfo)
/*
replace all references in a type code expression which refer to an argument i.e. the argument contains a
type to their placeholders. Return is a list of (placeholder,argument) list. Each tuple is used later as
arguments to the coerce relation. This should be optional
/* Sjaak ... */
convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args binds placeholders_and_tc_args ci
# (let_binds, ci) = createVariables uni_vars [] ci
Sjaak Smetsers
committed
(let_info_ptr, ci) = let_ptr (length let_binds) ci
(e, type_code_expr, binds, placeholders_and_tc_args, ci) = convertTypecode2 cinp type_code False [] [] ci
= (e, Let { let_strict_binds = [],
let_lazy_binds = let_binds,
let_expr = type_code_expr,
let_info_ptr = let_info_ptr,
let_expr_position = NoPos}, binds, placeholders_and_tc_args, ci)
/* ... Sjaak */
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
#! cinp_st_args
= filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args
| isEmpty cinp_st_args
#! (e,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
= (False,e,binds,placeholders_and_tc_args,ci)
/*
** the TCE_VAR is a TC argument and it is not part of a larger type expression. It
** later suffices to generate a coerce instead of an application. This is an
** optimization.
*/
= (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci)
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
#! cinp_st_args
= filter (\{fv_info_ptr} -> fv_info_ptr == var_info_ptr) cinp_st_args
| isEmpty cinp_st_args
#! (e,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
= (False,e,binds,placeholders_and_tc_args,ci)
/*
** the TCE_VAR is a TC argument and it is not part of a larger type expression. It
** later suffices to generate a coerce instead of an application. This is an
** optimization.
*/
= (True,Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args,ci)
// = convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci
convertTypecode2 cinp t replace_tc_args binds placeholders_and_tc_args ci
#! (e,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp t replace_tc_args binds placeholders_and_tc_args ci
= (False,e,binds,placeholders_and_tc_args,ci)
convertTypecode cinp TCE_Empty replace_tc_args binds placeholders_and_tc_args ci
= (EE,binds,placeholders_and_tc_args,ci)
convertTypecode cinp=:{cinp_st_args} (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci=:{ci_placeholders_and_tc_args,ci_var_heap}
| not replace_tc_args
= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
// check if tc_arg has already been replaced by a placeholder
#! ci_placeholder_and_tc_arg
= filter (\(_,tc_args_ptr) -> tc_args_ptr == var_info_ptr) ci_placeholders_and_tc_args
| not (isEmpty ci_placeholder_and_tc_arg)
// an tc-arg has been found, add to the list of indirections to be restored and replace it by its placeholder
#! placeholder_var
= (fst (hd ci_placeholder_and_tc_arg));
#! ci_var_heap
= adjust_ref_count placeholder_var.var_info_ptr ci.ci_var_heap
= (Var {var_name = v_tc_placeholder_ident, var_info_ptr = placeholder_var.var_info_ptr, var_expr_ptr = nilPtr},binds,
[(placeholder_var/*.var_info_ptr*/,var_info_ptr):placeholders_and_tc_args],{ci & ci_var_heap = ci_var_heap} );
//placeholders_and_tc_args, ci)
= (Var {var_name = a_ij_var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
where
adjust_ref_count var_info_ptr var_heap
# (VI_Indirection ref_count, var_heap) = readPtr var_info_ptr var_heap
= var_heap <:= (var_info_ptr, VI_Indirection (inc ref_count))
// 1st component of tuple is true iff:
// 1. The type is a TCE_Var or TCE_TypeTerm
// 2. It is also a argument of the function
// Thus a tc argument variable.
// This forms a special case: instead of an unify, a coerce can be generated
convertTypecode cinp (TCE_TypeTerm var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
/*
** TCE_Var and TCE_TypeTerm are not equivalent. A TCE_TypeTerm is used for an argument which contains
** a type representation. A TCE_Var is an existential quantified type variable. In previous phases no
** clear distinction is made. It should be possible to generate the proper type code expression for
** these two but it would involve changing a lot of small things.
*/
= convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci=:{ci_internal_type_id}
# (typecons_symb, ci) = getSymbol PD_TypeConsSymbol SK_Constructor (USE_DummyModuleName 3 2) ci
constructor = get_constructor cinp.cinp_glob_type_inst index
(typecode_exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci
# (ci_internal_type_id,ci)
= get_module_id ci
= (App {app_symb = typecons_symb,
app_args = USE_DummyModuleName [constructor , ci_internal_type_id, typecode_exprs] [constructor , typecode_exprs] ,
where
get_module_id ci=:{ci_module_id=Yes {lb_dst}}
= (Var (freeVarToVar lb_dst),ci)
get_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_dst = dst_fv
, lb_position = NoPos
}
# ci
= { ci &
ci_new_variables = [ dst_fv : ci.ci_new_variables ]
, ci_module_id = Yes let_bind
}
= (Var dst,ci)
convertTypecode cinp (TCE_Selector selections var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
#! (var,binds,placeholders_and_tc_args,ci)
= convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
= (Selection No var selections,binds,placeholders_and_tc_args,ci)
//convertTypecodes :: !ConversionInput [TypeCodeExpression] !*ConversionInfo -> (Expression,!*ConversionInfo)
convertTypecodes _ [] replace_tc_args binds placeholders_and_tc_args ci
# (nil_symb, ci) = getSymbol PD_NilSymbol SK_Constructor 0 ci
= (App { app_symb = nil_symb,
app_args = [],
app_info_ptr = nilPtr},binds,placeholders_and_tc_args, ci)
convertTypecodes cinp [typecode_expr : typecode_exprs] replace_tc_args binds placeholders_and_tc_args ci
# (cons_symb, ci) = getSymbol PD_ConsSymbol SK_Constructor 2 ci
# (expr,binds,placeholders_and_tc_args, ci) = convertTypecode cinp typecode_expr replace_tc_args binds placeholders_and_tc_args ci
# (exprs,binds,placeholders_and_tc_args,ci) = convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci
= (App { app_symb = cons_symb,
app_args = [expr , exprs],
app_info_ptr = nilPtr}, binds,placeholders_and_tc_args, ci)
determine_defaults :: (Optional Expression) DefaultExpression !*ConversionInfo -> (Optional Expression, DefaultExpression, !*ConversionInfo)
/***
determine_defaults :: case_default default_expr varheap -> (this_case_default, nested_case_default, var_heap)
this_case_default = IF this case has no default, but there is a surrounding default
THEN that is now the default and its reference count must be increased.
ELSE it keeps this default
nested_case_default = IF this case has no default
THEN the default_expr remains default in the nested cases.
ELSE nested cases get this default. This is semantically already the case, so nothing has to be changed.
// the case itself has no default but it has a surrounding default
/*
1st = default of current case
2nd = directly surrounding default
*/
determine_defaults No default_expr=:(Yes (var=:{var_info_ptr}, indirection_var_list)) ci=:{ci_var_heap}
#! var_info = sreadPtr var_info_ptr ci_var_heap
# (expression, ci) = toExpression default_expr {ci & ci_var_heap = ci_var_heap}
= case var_info of
VI_Default ref_count
-> (expression, default_expr, {ci & ci_var_heap = ci.ci_var_heap <:= (var_info_ptr, VI_Default (inc ref_count))} )
_
-> (expression, default_expr, ci )
determine_defaults case_default _ ci
= (case_default, No, ci)
add_dynamic_bound_vars :: ![DynamicPattern] BoundVariables -> BoundVariables
add_dynamic_bound_vars [] bound_vars = bound_vars
add_dynamic_bound_vars [{dp_var, dp_type_patterns_vars} : patterns] bound_vars
= add_dynamic_bound_vars patterns (foldSt bind_info_ptr dp_type_patterns_vars [ {tv_free_var = dp_var, tv_type = empty_attributed_type } : bound_vars ])
bind_info_ptr var_info_ptr bound_vars
= [{ tv_free_var = {fv_def_level = NotALevel, fv_name = a_ij_var_name, fv_info_ptr = var_info_ptr, fv_count = 0}, tv_type = empty_attributed_type } : bound_vars]
open_dynamic :: Expression !*ConversionInfo -> (OpenedDynamic, LetBind, !*ConversionInfo)
open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field}
# (twotuple, ci) = getTupleSymbol 2 ci
(dynamicType_var, ci) = newVariable "dt" VI_Empty ci
dynamicType_fv = varToFreeVar dynamicType_var 1
// sel_type = Selection No dynamic_expr [RecordSelection type_defined_symbol sd_type_field_nr]
// sel_value = Selection No dynamic_expr [RecordSelection value_defined_symbol sd_value_field_nr]
= ( { opened_dynamic_expr = ci_sel_value_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 0 dynamic_expr) sel_value*/, opened_dynamic_type = Var dynamicType_var },
// RecordSelection !(Global DefinedSymbol) !Int
// MW0 { bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv },
{ lb_src = ci_sel_type_field dynamic_expr /*USE_TUPLES (TupleSelect twotuple 1 dynamic_expr) sel_type*/, lb_dst = dynamicType_fv, lb_position = NoPos },
{ ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
/**************************************************************************************************/
convertDynamicPatterns :: !ConversionInput !BoundVariables !Case *ConversionInfo -> (Expression, *ConversionInfo)
convertDynamicPatterns cinp bound_vars {case_guards = DynamicPatterns [], case_default} ci
= case case_default of
(Yes expr) -> (expr, ci)
No -> abort "unexpected value in convertDynamics: 'convertDynamicPatterns'"
convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = DynamicPatterns patterns, case_default, case_info_ptr}
ci=:{ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args,ci_generated_global_tc_placeholders}
# (opened_dynamic, dt_bind, ci) = open_dynamic case_expr ci
(ind_0, ci) = newVariable "ind_0" (VI_Indirection 0) ci
(c_1, ci) = newVariable "c_1!" (VI_Default 0) ci
new_default = newDefault c_1 ind_0
(result_type, ci) = getResultType case_info_ptr ci
#! // TC PLACEHOLDERS...
(tc_binds,(bound_vars,ci))
= case ci_generated_global_tc_placeholders of
True -> ([],(bound_vars,ci))
_
#! (tc_binds,(bound_vars,ci))
= mapSt f cinp_st_args (bound_vars,ci)
#! ci
= { ci & ci_generated_global_tc_placeholders = True}
-> (tc_binds,(bound_vars,ci))
// ...TC PLACEHOLDERS
#
// MW0 bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
bound_vars = addToBoundVars (freeVarToVar dt_bind.lb_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
(addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
(binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
# ci
= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
# (tc_binds,ci)
= foldSt remove_non_used_arg tc_binds ([],ci)
Sjaak Smetsers
committed
/* Sjaak */
(let_info_ptr, ci) = let_ptr (length binds + length tc_binds + 1) ci
// MW0 = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci)
= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr,
let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ci)
// MW0 remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo)
remove_non_used_arg :: LetBind ([LetBind],*ConversionInfo) -> ([LetBind],*ConversionInfo)
remove_non_used_arg tc_bind=:{lb_dst={fv_info_ptr}} (l,ci=:{ci_var_heap})
# (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
| ref_count > 0
#! tc_bind
= { tc_bind & lb_dst = { tc_bind.lb_dst & fv_count = ref_count} }
= ([tc_bind:l],{ci & ci_var_heap = ci_var_heap})
= (l,{ci & ci_var_heap = ci_var_heap})
// too many new variables are created because also non-tc args are included; should be improved in the future
f st_arg (bound_vars,ci=:{ci_placeholders_and_tc_args})
// create placeholder variable for arg
#! v
= VI_Indirection 0
#! (placeholder_var, ci)
= newVariable v_tc_placeholder v ci //---> st_arg
#! (bind,ci)
= create_variable v_tc_placeholder_ident_global placeholder_var.var_info_ptr ci
// associate newly create placeholder variable with its tc
#! ci
= { ci &
ci_placeholders_and_tc_args = [(placeholder_var,st_arg.fv_info_ptr):ci_placeholders_and_tc_args]
}
#! bound_vars2
= addToBoundVars placeholder_var empty_attributed_type bound_vars
= (bind,(bound_vars2,ci));
where
// MW0 create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
create_variable var_name var_info_ptr ci
# (placeholder_symb, ci) = getSymbol PD_variablePlaceholder SK_Constructor 3 ci
cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}
cyclic_fv = varToFreeVar cyclic_var 1
// MW0 = ({ bind_src = App { app_symb = placeholder_symb,
= ({ lb_src = App { app_symb = placeholder_symb,
app_args = [Var cyclic_var, Var cyclic_var],
app_info_ptr = nilPtr },
// MW0 bind_dst = varToFreeVar cyclic_var 1
lb_dst = varToFreeVar cyclic_var 1,
lb_position = NoPos
},
{ ci & ci_new_variables = [ cyclic_fv : ci.ci_new_variables ]} /*ci*/)
add_coercions [] _ _ bound_vars dp_rhs ci
= (bound_vars,dp_rhs,ci)
add_coercions [({var_info_ptr=a_ij},a_ij_tc):rest] this_default q bound_vars dp_rhs ci=:{ci_module_id_symbol}
// extra
# a_ij_var = {var_name = a_ij_var_name, var_info_ptr = a_ij, var_expr_ptr = nilPtr}
# a_ij_tc_var = {var_name = a_aij_tc_var_name, var_info_ptr = a_ij_tc, var_expr_ptr = nilPtr}
// indirections
# (ind_i, ci) = newVariable "ind_1" (VI_Indirection (if (isNo this_default) 0 1)) ci
(c_inc_i, ci) = newVariable "c_!" (VI_Indirection 1) ci
new_default = newDefault c_inc_i ind_i
#
(coerce_symb, ci) = getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
(twotuple, ci) = getTupleSymbol 2 ci
Sjaak Smetsers
committed
//Sjaak (case_info_ptr, ci) = case_ptr ci
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
(coerce_result_var, ci) = newVariable "result" VI_Empty ci
coerce_result_fv = varToFreeVar coerce_result_var 1
(coerce_bool_var, ci) = newVariable "coerce_bool" VI_Empty ci
coerce_bool_fv = varToFreeVar coerce_bool_var 1
# (let_binds, ci) = bind_indirection_var ind_i coerce_result_var twotuple ci
ind_i_fv = varToFreeVar ind_i 1
c_inc_i_fv = varToFreeVar c_inc_i 1
ci = { ci & ci_new_variables = [ c_inc_i_fv,ind_i_fv : ci.ci_new_variables ] }
#! new_default2 = newDefault c_inc_i ind_i
# (default_expr, ci)
= case (isNo this_default) of
False
-> toExpression new_default2 ci
True
-> (No,ci)
// extra
# (bound_vars,new_dp_rhs,ci)
= add_coercions rest (if (isNo this_default) No new_default2) q bound_vars dp_rhs ci
#! (opt_expr,ci)
= toExpression this_default ci
#! app_args2 = extended_unify_and_coerce [Var a_ij_var, Var a_ij_tc_var] [Var a_ij_var, Var a_ij_tc_var, ci_module_id_symbol ]
Sjaak Smetsers
committed
/* Sjaak ... */
Sjaak Smetsers
committed
# let_lazy_binds = (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
{ lb_src = App { app_symb = coerce_symb, app_args = app_args2, app_info_ptr = nilPtr },
lb_dst = coerce_result_fv, lb_position = NoPos }
{ lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/,
lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
Sjaak Smetsers
committed
]
(let_info_ptr, ci) = let_ptr (length let_lazy_binds) ci
(case_info_ptr, ci) = bool_case_ptr ci
/* ... Sjaak */
# let_expr
= Let {
let_strict_binds = []
, let_lazy_binds = let_lazy_binds
, let_expr =
Case { case_expr = Var coerce_bool_var,
case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = new_dp_rhs, bp_position = NoPos }],
case_default = default_expr,
case_ident = No,
case_info_ptr = case_info_ptr,
Ronny Wichers Schreur
committed
// RWS ...
case_explicit = False,
// ... RWS
case_default_pos= NoPos } // MW4++
, let_info_ptr = let_info_ptr
, let_expr_position = NoPos // MW0++
}
// dp_rhs
= (bound_vars,let_expr,{ ci & ci_new_variables = [coerce_result_fv, coerce_bool_fv : ci.ci_new_variables]}) //let_expr,ci)
where
opt (Yes x) = x
convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
/// MW0 -> (Env Expression FreeVar, Expression, *ConversionInfo)
-> ([LetBind], Expression, *ConversionInfo)
convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default
[{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci=:{ci_module_id_symbol}
ind_var = getIndirectionVar this_default
this_default = if (isEmpty patterns && (isNo last_default)) No this_default
/*** convert the elements of this pattern ***/
(a_ij_binds, ci) = createVariables dp_type_patterns_vars [] ci
(generate_coerce,type_code,_,martijn, ci) = convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */ /* WAS: a_ij_binds*/ [] [] {ci & ci_module_id = No} // ci
# (type_code,ci)
= build_type_identification type_code ci
// collect ...
# (is_last_dynamic_pattern,dp_rhs)
= isLastDynamicPattern dp_rhs;
# ci
= foldSt add_tcs martijn ci
// ... collect
#
// walks through the patterns of the next alternative
(dp_rhs, ci) = convertDynamics cinp bound_vars this_default dp_rhs ci
// collect ...
#! (ci_old_used_tcs,ci)
= ci!ci_used_tcs;
# ci
= { ci & ci_used_tcs = [] }
// ... collect
/*** recursively convert the other patterns in the other alternatives ***/
#! (binds, ci) = convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci
// collect ...
# ci
= { ci & ci_used_tcs = ci_old_used_tcs }
# ci_used_tcs
= ci_old_used_tcs
#! (dp_rhs,ci)
= case ((is_last_dynamic_pattern) /*&& (not generate_coerce)*/) of
True
// last dynamic pattern of the group of dynamic pattern so coercions must be generated.
#! (ci_placeholders_and_tc_args,ci)
= ci!ci_placeholders_and_tc_args
#! used_ci_placeholders_and_tc_args
= filter (\(_,ci_placeholders_and_tc_arg) -> isMember ci_placeholders_and_tc_arg ci_used_tcs) ci_placeholders_and_tc_args
#! (bound_vars,dp_rhs,ci)
= add_coercions used_ci_placeholders_and_tc_args this_default binds bound_vars dp_rhs ci
-> (dp_rhs,ci)
False
-> (dp_rhs,ci)
// ... collect
#
/*** generate the expression ***/
(unify_symb, ci) = getSymbol (if generate_coerce PD_coerce PD_unify ) SK_Function (extended_unify_and_coerce 2 3) /*3 was 2 */ ci
(twotuple, ci) = getTupleSymbol 2 ci
Sjaak Smetsers
committed
//Sjaak (case_info_ptr, ci) = case_ptr ci
(default_expr, ci) = toExpression this_default ci
(unify_result_var, ci) = newVariable "result" VI_Empty ci
unify_result_fv = varToFreeVar unify_result_var 1
(unify_bool_var, ci) = newVariable (if generate_coerce "coerce_bool" "unify_bool") VI_Empty ci
unify_bool_fv = varToFreeVar unify_bool_var 1
(let_binds, ci) = bind_indirection_var ind_var unify_result_var twotuple ci
a_ij_binds = add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds
// sel_type = Selection No (Var unify_result_var) [RecordSelection type_defined_symbol sd_type_field_nr]
/*
// TIJDELIJK...
# (ci=:{ci_predef_symb})
= ci;
# ({pds_module, pds_def, pds_ident}, ci_predef_symb) = ci_predef_symb![PD_ModuleConsSymbol]
# module_symb1 = { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 0 }
# ci
= { ci & ci_predef_symb = ci_predef_symb };
# module_symb =
{ app_symb = module_symb1
, app_args = []
, app_info_ptr = nilPtr
}
# module_symb =
App module_symb
// ...TIJDELIJK
*/
Sjaak Smetsers
committed
/* Sjaak ... */
Martijn Vervoort
committed
(let_info_ptr, ci) = let_ptr (2 + length let_binds) ci
Sjaak Smetsers
committed
(case_info_ptr, ci) = bool_case_ptr ci
/* ... Sjaak */
app_args2 = extended_unify_and_coerce [opened_dynamic.opened_dynamic_type, type_code] [opened_dynamic.opened_dynamic_type, type_code, ci_module_id_symbol ]
let_lazy_binds = [{ lb_src = App { app_symb = unify_symb, app_args = app_args2, app_info_ptr = nilPtr },
lb_dst = unify_result_fv, lb_position = NoPos },
{ lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var unify_result_var) /*) sel_type*/,
lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds
],
let_expr = Case { case_expr = Var unify_bool_var,
case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
case_default = default_expr,
case_ident = No,
case_info_ptr = case_info_ptr,
Ronny Wichers Schreur
committed
// RWS ...
case_explicit = False,
// ... RWS
case_default_pos= NoPos }, // MW4++
let_info_ptr = let_info_ptr,
let_expr_position = NoPos }
= (a_ij_binds ++ binds, let_expr, { ci & ci_new_variables = [unify_result_fv, unify_bool_fv : ci.ci_new_variables]})
// MW0 add_x_i_bind bind_src bind_dst=:{fv_count} binds
add_x_i_bind lb_src lb_dst=:{fv_count} binds
// MW0 = [ { bind_src = bind_src, bind_dst = bind_dst } : binds ]
= [ { lb_src = lb_src, lb_dst = lb_dst, lb_position = NoPos } : binds ]
isLastDynamicPattern dp_rhs=:(Case keesje=:{case_guards=DynamicPatterns _})
= (False,dp_rhs);
isLastDynamicPattern dp_rhs
= (True,dp_rhs);
add_tcs (_,tc) ci=:{ci_used_tcs}
| isMember tc ci_used_tcs
= ci;
= {ci & ci_used_tcs = [tc:ci_used_tcs]}
convert_other_patterns :: ConversionInput BoundVariables DefaultExpression Int OpenedDynamic AType !(Optional Expression) ![DynamicPattern] !*ConversionInfo
// MW0 -> (Env Expression FreeVar, *ConversionInfo)
-> ([LetBind], *ConversionInfo)
convert_other_patterns _ _ _ _ _ _ No [] ci
// The last_default is the default used when there are no pattern left
convert_other_patterns cinp bound_vars this_default _ _ result_type (Yes last_default_expr) [] ci
# c_i = getVariable1 this_default
(c_bind, ci) = generateBinding cinp bound_vars c_i last_default_expr result_type ci
= ([c_bind], ci)
convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci
# (ind_i, ci) = newVariable ("ind_"+++toString (pattern_number)) (VI_Indirection 0) ci
(c_inc_i, ci) = newVariable ("c_"+++toString (inc pattern_number)) (VI_Default 0) ci
new_default = newDefault c_inc_i ind_i
bound_vars = addToBoundVars ind_i empty_attributed_type (addToBoundVars c_inc_i result_type bound_vars)
(binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default (inc pattern_number) opened_dynamic result_type last_default patterns ci
(c_bind, ci) = generateBinding cinp bound_vars c_i expr result_type ci