Skip to content
GitLab
Commit a3520ae5 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏘
Browse files

removed comments that marked various patches

parent 6f0c29de
Hide whitespace changes
Inline Side-by-side
frontend/convertDynamics.icl
View file @ a3520ae5
...@@ -3,14 +3,12 @@ ...@@ -3,14 +3,12 @@
*/ */
implementation module convertDynamics implementation module convertDynamics
import syntax, transform, utilities, convertcases /* MV ... */, compilerSwitches /* ... MV */ import syntax, transform, utilities, convertcases, compilerSwitches
from type_io_common import PredefinedModuleName from type_io_common import PredefinedModuleName
// Optional // Optional
USE_TUPLES tuple b :== b; // change also StdDynamic.icl and recompile all applications 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 extended_unify_and_coerce no yes :== no; // change also _unify and _coerce in StdDynamic
//import pp;
import type_io; import type_io;
//import pp; //import pp;
...@@ -105,10 +103,9 @@ f (Yes tcl_file) ...@@ -105,10 +103,9 @@ f (Yes tcl_file)
= tcl_file; = tcl_file;
0.2*/ 0.2*/
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String] convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap (Optional !*File) {# DclModule} !IclModule [String]
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File)) -> (!*{! 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 /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules 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
// TD ...
# (tcl_file,type_heaps,predefined_symbols) # (tcl_file,type_heaps,predefined_symbols)
= case tcl_file of = case tcl_file of
No No
...@@ -121,13 +118,10 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ ...@@ -121,13 +118,10 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
(Yes tcl_file) (Yes tcl_file)
//3.1 //3.1
# (ok,tcl_file,type_heaps,predefined_symbols) # (ok,tcl_file,type_heaps,predefined_symbols)
= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules type_heaps predefined_symbols = write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file directly_imported_dcl_modules type_heaps predefined_symbols
| not ok | not ok
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file" -> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> (Yes tcl_file,type_heaps,predefined_symbols) -> (Yes tcl_file,type_heaps,predefined_symbols)
// ... TD
# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic] # ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols) #! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
= case (pds_module == (-1) || pds_def == (-1)) of = case (pds_module == (-1) || pds_def == (-1)) of
...@@ -135,7 +129,7 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ ...@@ -135,7 +129,7 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
-> (undef,undef,undef,predefined_symbols) -> (undef,undef,undef,predefined_symbols)
_ _
-> case (USE_TUPLES True False) /*(pds_module == (-1) || pds_def == (-1))*/ of -> case (USE_TUPLES True False) of
True True
# arity = 2 # arity = 2
// get tuple arity 2 constructor // get tuple arity 2 constructor
...@@ -200,7 +194,6 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ ...@@ -200,7 +194,6 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
# (module_symb,module_id_app,predefined_symbols) # (module_symb,module_id_app,predefined_symbols)
= get_module_id_app predefined_symbols = get_module_id_app predefined_symbols
// new...
# ({pds_module=pds_type_id_module, pds_def=pds_type_id_def} , predefined_symbols) = predefined_symbols![PD_TypeID] # ({pds_module=pds_type_id_module, pds_def=pds_type_id_def} , predefined_symbols) = predefined_symbols![PD_TypeID]
# ci_type_id # ci_type_id
= case (pds_type_id_module == NoIndex || pds_type_id_def == NoIndex) of = case (pds_type_id_module == NoIndex || pds_type_id_def == NoIndex) of
...@@ -216,7 +209,6 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ ...@@ -216,7 +209,6 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
, type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True } , type_prop = { tsp_sign = BottomSignClass, tsp_propagation = NoPropClass, tsp_coercible = True }
}; };
-> Yes ci_type_id -> Yes ci_type_id
// ...new
#! nr_of_funs = size fun_defs #! nr_of_funs = size fun_defs
# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs } # imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
...@@ -261,7 +253,7 @@ where ...@@ -261,7 +253,7 @@ where
= TransformedBody fun_body = TransformedBody fun_body
# ci # ci
= { ci & ci_used_tcs = [], ci_generated_global_tc_placeholders = False } //, ci_module_id = No } = { 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 # (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 # fun_body
...@@ -304,19 +296,15 @@ where ...@@ -304,19 +296,15 @@ where
= (letje,ci) = (letje,ci)
// MV ..
convert_dynamics_in_body global_type_instances (TransformedBody {tb_args,tb_rhs}) (Yes {st_context, st_args}) 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 # 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 (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) = (TransformedBody {tb_args = tb_args,tb_rhs = tb_rhs}, ci)
convert_dynamics_in_body global_type_instances other fun_type ci convert_dynamics_in_body global_type_instances other fun_type ci
= abort "unexpected value in 'convert dynamics.convert_dynamics_in_body'" = abort "unexpected value in 'convert dynamics.convert_dynamics_in_body'"
// MV ..
bindVarsToTypes2 st_context vars types typed_vars common_defs bindVarsToTypes2 st_context vars types typed_vars common_defs
:== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars :== bindVarsToTypes vars (addTypesOfDictionaries common_defs st_context types) typed_vars
// .. MV
bindVarsToTypes vars types typed_vars bindVarsToTypes vars types typed_vars
= fold2St bind_var_to_type vars types typed_vars = fold2St bind_var_to_type vars types typed_vars
where where
...@@ -380,7 +368,6 @@ where ...@@ -380,7 +368,6 @@ where
= (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 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 # (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 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_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_lazy_binds, ci) = convertDynamics cinp bound_vars default_expr let_lazy_binds ci
...@@ -399,7 +386,6 @@ where ...@@ -399,7 +386,6 @@ where
ci = { ci & ci_expr_heap = ci_expr_heap } ci = { ci & ci_expr_heap = ci_expr_heap }
= case case_guards of = case case_guards of
(AlgebraicPatterns type algebraic_patterns) (AlgebraicPatterns type algebraic_patterns)
// MV DEFAULT ...
| not (isNo this_case_default) && any (\algebraic_pattern -> is_case_without_default algebraic_pattern) algebraic_patterns | 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 // a default to be moved inwards and a root positioned case not having a default
// //
...@@ -410,7 +396,6 @@ where ...@@ -410,7 +396,6 @@ where
// loadandrun2 _ _ = abort "Loader: process and input do not match" // loadandrun2 _ _ = abort "Loader: process and input do not match"
// //
# (Yes old_case_default) = this_case_default # (Yes old_case_default) = this_case_default
// # (let_info_ptr, ci) = let_ptr ci
# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_type=TE}) ci # (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_type=TE}) ci
# default_fv = varToFreeVar default_var 1 # default_fv = varToFreeVar default_var 1
# ci # ci
...@@ -425,7 +410,6 @@ where ...@@ -425,7 +410,6 @@ where
= map (patch_defaults new_case_default) algebraic_patterns = map (patch_defaults new_case_default) algebraic_patterns
# (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default) # (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
(zip2 algebraic_patterns ct_cons_types) ci (zip2 algebraic_patterns ct_cons_types) ci
/* Sjaak */
# (let_info_ptr, ci) = let_ptr 1 ci # (let_info_ptr, ci) = let_ptr 1 ci
# letje # letje
= Let { = Let {
...@@ -440,7 +424,6 @@ where ...@@ -440,7 +424,6 @@ where
# (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default) # (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
(zip2 algebraic_patterns ct_cons_types) ci (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) -> (Case {keesje & case_expr = case_expr, case_guards = AlgebraicPatterns type algebraic_patterns, case_default = this_case_default}, ci)
// ... MV DEFAULT
(BasicPatterns type basic_patterns) (BasicPatterns type basic_patterns)
# (basic_patterns, ci) = convertDynamics cinp bound_vars nested_case_default basic_patterns ci # (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) -> (Case {keesje & case_expr = case_expr, case_guards = BasicPatterns type basic_patterns, case_default = this_case_default}, ci)
...@@ -455,7 +438,6 @@ where ...@@ -455,7 +438,6 @@ where
-> (Case {keesje & case_expr = case_expr, case_guards = NoPattern, case_default = this_case_default}, ci) -> (Case {keesje & case_expr = case_expr, case_guards = NoPattern, case_default = this_case_default}, ci)
_ _
-> abort "unexpected value in convertDynamics: 'convertDynamics.CasePatterns'" -> abort "unexpected value in convertDynamics: 'convertDynamics.CasePatterns'"
// MV DEFAULT ...
where where
is_case_without_default {ap_expr=Case {case_default=No}} = True is_case_without_default {ap_expr=Case {case_default=No}} = True
is_case_without_default _ = False is_case_without_default _ = False
...@@ -464,7 +446,6 @@ where ...@@ -464,7 +446,6 @@ where
= { ap & ap_expr = Case {keesje & case_default = this_case_default} } = { ap & ap_expr = Case {keesje & case_default = this_case_default} }
patch_defaults _ expr patch_defaults _ expr
= expr = expr
// ... MV DEFAULT
convertDynamics cinp bound_vars default_expr (Selection opt_symb expression selections) ci convertDynamics cinp bound_vars default_expr (Selection opt_symb expression selections) ci
# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
...@@ -489,34 +470,12 @@ where ...@@ -489,34 +470,12 @@ where
convertDynamics cinp bound_vars default_expr (MatchExpr symb expression) ci convertDynamics cinp bound_vars default_expr (MatchExpr symb expression) ci
# (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci # (expression,ci) = convertDynamics cinp bound_vars default_expr expression ci
= (MatchExpr symb expression, ci) = (MatchExpr symb expression, ci)
/* Sjaak ... */
convertDynamics cinp bound_vars default_expr (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_type_code}) ci=:{ci_symb_ident} 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_expr, ci) = convertDynamics cinp bound_vars default_expr dyn_expr ci
(_,dyn_type_code, _, _, ci) = convertTypecode2 cinp dyn_type_code False PD_UV_Placeholder [] [] ci (_,dyn_type_code, _, _, ci) = convertTypecode2 cinp dyn_type_code False PD_UV_Placeholder [] [] ci
= (App { app_symb = ci_symb_ident, = (App { app_symb = ci_symb_ident,
app_args = [dyn_expr, dyn_type_code], app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr }, ci) 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
= case let_binds of
[] -> (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 */
_ # (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 convertDynamics cinp bound_vars default_expr (TypeCodeExpression type_code) ci
= abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci = abort "convertDynamics cinp bound_vars default_expr (TypeCodeExpression" //convertTypecode cinp type_code ci
convertDynamics cinp bound_vars default_expr EE ci convertDynamics cinp bound_vars default_expr EE ci
...@@ -532,7 +491,6 @@ where ...@@ -532,7 +491,6 @@ where
*/ */
/* Sjaak ... */
convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
# (let_binds, ci) = createUniversalVariables uni_placeholder uni_vars [] ci # (let_binds, ci) = createUniversalVariables uni_placeholder uni_vars [] ci
(let_info_ptr, ci) = let_ptr (length let_binds) ci (let_info_ptr, ci) = let_ptr (length let_binds) ci
...@@ -542,7 +500,6 @@ convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args uni_place ...@@ -542,7 +500,6 @@ convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args uni_place
let_expr = type_code_expr, let_expr = type_code_expr,
let_info_ptr = let_info_ptr, let_info_ptr = let_info_ptr,
let_expr_position = NoPos}, binds, placeholders_and_tc_args, ci) let_expr_position = NoPos}, binds, placeholders_and_tc_args, ci)
/* ... Sjaak */
// ci_placeholders_and_tc_args // ci_placeholders_and_tc_args
convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci convertTypecode2 cinp=:{cinp_st_args} t=:(TCE_Var var_info_ptr) replace_tc_args uni_placeholder binds placeholders_and_tc_args ci
...@@ -702,12 +659,8 @@ open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field} ...@@ -702,12 +659,8 @@ open_dynamic dynamic_expr ci=:{ci_sel_type_field, ci_sel_value_field}
# (twotuple, ci) = getTupleSymbol 2 ci # (twotuple, ci) = getTupleSymbol 2 ci
(dynamicType_var, ci) = newVariable "dt" VI_Empty ci (dynamicType_var, ci) = newVariable "dt" VI_Empty ci
dynamicType_fv = varToFreeVar dynamicType_var 1 dynamicType_fv = varToFreeVar dynamicType_var 1
// sel_type = Selection No dynamic_expr [RecordSelection type_defined_symbol sd_type_field_nr] = ( { opened_dynamic_expr = ci_sel_value_field dynamic_expr, opened_dynamic_type = Var dynamicType_var },
// sel_value = Selection No dynamic_expr [RecordSelection value_defined_symbol sd_value_field_nr] { lb_src = ci_sel_type_field dynamic_expr, lb_dst = dynamicType_fv, lb_position = NoPos },
= ( { 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 ]}) { ci & ci_new_variables = [ dynamicType_fv : ci.ci_new_variables ]})
/**************************************************************************************************/ /**************************************************************************************************/
...@@ -724,8 +677,7 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = ...@@ -724,8 +677,7 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
new_default = newDefault c_1 ind_0 new_default = newDefault c_1 ind_0
(result_type, ci) = getResultType case_info_ptr ci (result_type, ci) = getResultType case_info_ptr ci
#! // TC PLACEHOLDERS... #! (tc_binds,(bound_vars,ci))
(tc_binds,(bound_vars,ci))
= case ci_generated_global_tc_placeholders of = case ci_generated_global_tc_placeholders of
True -> ([],(bound_vars,ci)) True -> ([],(bound_vars,ci))
_ _
...@@ -734,11 +686,9 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = ...@@ -734,11 +686,9 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
#! ci #! ci
= { ci & ci_generated_global_tc_placeholders = True} = { ci & ci_generated_global_tc_placeholders = True}
-> (tc_binds,(bound_vars,ci)) -> (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 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))) (addToBoundVars c_1 result_type (add_dynamic_bound_vars patterns bound_vars)))
...@@ -748,14 +698,11 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards = ...@@ -748,14 +698,11 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args} = { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
# (tc_binds,ci) # (tc_binds,ci)
= foldSt remove_non_used_arg tc_binds ([],ci) = foldSt remove_non_used_arg tc_binds ([],ci)
/* Sjaak */
(let_info_ptr, ci) = let_ptr (length binds + length tc_binds + 1) ci (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 {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) let_info_ptr = let_info_ptr, let_expr_position = NoPos }, ci)
where where
// 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 :: LetBind ([LetBind],*ConversionInfo) -> ([LetBind],*ConversionInfo)
remove_non_used_arg tc_bind=:{lb_dst={fv_info_ptr}} (l,ci=:{ci_var_heap}) 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 # (VI_Indirection ref_count, ci_var_heap) = readPtr fv_info_ptr ci_var_heap
...@@ -787,17 +734,14 @@ where ...@@ -787,17 +734,14 @@ where
= addToBoundVars placeholder_var empty_attributed_type bound_vars = addToBoundVars placeholder_var empty_attributed_type bound_vars
= (bind,(bound_vars2,ci)); = (bind,(bound_vars2,ci));
where where
// MW0 create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo) create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (LetBind, !*ConversionInfo)
create_variable var_name var_info_ptr ci create_variable var_name var_info_ptr ci
# (placeholder_symb, ci) = getSymbol PD_PV_Placeholder SK_Constructor 2 ci # (placeholder_symb, ci) = getSymbol PD_PV_Placeholder SK_Constructor 2 ci
cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} cyclic_var = {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr}
cyclic_fv = varToFreeVar cyclic_var 1 cyclic_fv = varToFreeVar cyclic_var 1
// MW0 = ({ bind_src = App { app_symb = placeholder_symb,
= ({ lb_src = App { app_symb = placeholder_symb, = ({ lb_src = App { app_symb = placeholder_symb,
app_args = [Var cyclic_var, Var cyclic_var], app_args = [Var cyclic_var, Var cyclic_var],
app_info_ptr = nilPtr }, app_info_ptr = nilPtr },
// MW0 bind_dst = varToFreeVar cyclic_var 1
lb_dst = varToFreeVar cyclic_var 1, lb_dst = varToFreeVar cyclic_var 1,
lb_position = NoPos lb_position = NoPos
}, },
...@@ -818,8 +762,6 @@ where ...@@ -818,8 +762,6 @@ where
# #
(coerce_symb, ci) = getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci (coerce_symb, ci) = getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
(twotuple, ci) = getTupleSymbol 2 ci (twotuple, ci) = getTupleSymbol 2 ci
//Sjaak (case_info_ptr, ci) = case_ptr ci
(coerce_result_var, ci) = newVariable "result" VI_Empty ci (coerce_result_var, ci) = newVariable "result" VI_Empty ci
coerce_result_fv = varToFreeVar coerce_result_var 1 coerce_result_fv = varToFreeVar coerce_result_var 1
(coerce_bool_var, ci) = newVariable "coerce_bool" VI_Empty ci (coerce_bool_var, ci) = newVariable "coerce_bool" VI_Empty ci
...@@ -848,18 +790,15 @@ where ...@@ -848,18 +790,15 @@ where
= toExpression this_default 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 ] #! 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 ... */
# let_lazy_binds = (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [ # 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_src = App { app_symb = coerce_symb, app_args = app_args2, app_info_ptr = nilPtr },
lb_dst = coerce_result_fv, lb_position = NoPos } lb_dst = coerce_result_fv, lb_position = NoPos }
, ,
{ lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/, { lb_src = TupleSelect twotuple 0 (Var coerce_result_var),
lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
] ]
(let_info_ptr, ci) = let_ptr (length let_lazy_binds) ci (let_info_ptr, ci) = let_ptr (length let_lazy_binds) ci
(case_info_ptr, ci) = bool_case_ptr result_type ci (case_info_ptr, ci) = bool_case_ptr result_type ci
/* ... Sjaak */
# let_expr # let_expr
= Let { = Let {
...@@ -871,12 +810,10 @@ where ...@@ -871,12 +810,10 @@ where
case_default = default_expr, case_default = default_expr,
case_ident = No, case_ident = No,
case_info_ptr = case_info_ptr, case_info_ptr = case_info_ptr,
// RWS ...
case_explicit = False, case_explicit = False,
// ... RWS case_default_pos= NoPos }
case_default_pos= NoPos } // MW4++
, let_info_ptr = let_info_ptr , let_info_ptr = let_info_ptr
, let_expr_position = NoPos // MW0++ , let_expr_position = NoPos
} }
// dp_rhs // dp_rhs
...@@ -885,7 +822,6 @@ where ...@@ -885,7 +822,6 @@ where
opt (Yes x) = x opt (Yes x) = x
convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo convert_dynamic_pattern :: !ConversionInput !BoundVariables DefaultExpression Int OpenedDynamic AType (Optional Expression) ![DynamicPattern] *ConversionInfo
/// MW0 -> (Env Expression FreeVar, Expression, *ConversionInfo)
-> ([LetBind], Expression, *ConversionInfo) -> ([LetBind], Expression, *ConversionInfo)
convert_dynamic_pattern cinp bound_vars this_default pattern_number opened_dynamic result_type last_default 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} [{ dp_var, dp_type_patterns_vars, dp_type_code, dp_rhs } : patterns] ci=:{ci_module_id_symbol}
...@@ -900,30 +836,25 @@ where ...@@ -900,30 +836,25 @@ where
(a_ij_binds, ci) = createTypePatternVariables dp_type_patterns_vars [] ci (a_ij_binds, ci) = createTypePatternVariables 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*/ PD_UPV_Placeholder [] [] ci //{ci & ci_module_id = No} // 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*/ PD_UPV_Placeholder [] [] ci //{ci & ci_module_id = No} // ci
// collect ...
# (is_last_dynamic_pattern,dp_rhs) # (is_last_dynamic_pattern,dp_rhs)
= isLastDynamicPattern dp_rhs; = isLastDynamicPattern dp_rhs;
# ci # ci
= foldSt add_tcs martijn ci = foldSt add_tcs martijn ci
// ... collect
# #
// walks through the patterns of the next alternative // walks through the patterns of the next alternative
(dp_rhs, ci) = convertDynamics cinp bound_vars this_default dp_rhs ci (dp_rhs, ci) = convertDynamics cinp bound_vars this_default dp_rhs ci
// collect ...
#! (ci_old_used_tcs,ci) #! (ci_old_used_tcs,ci)
= ci!ci_used_tcs; = ci!ci_used_tcs;
# ci # ci
= { ci & ci_used_tcs = [] } = { ci & ci_used_tcs = [] }
// ... collect
/*** recursively convert the other patterns in the other alternatives ***/ /*** 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 #! (binds, ci) = convert_other_patterns cinp bound_vars this_default pattern_number opened_dynamic result_type last_default patterns ci
// collect ...
# ci # ci
= { ci & ci_used_tcs = ci_old_used_tcs } = { ci & ci_used_tcs = ci_old_used_tcs }
# ci_used_tcs # ci_used_tcs
...@@ -943,12 +874,10 @@ where ...@@ -943,12 +874,10 @@ where
-> (dp_rhs,ci) -> (dp_rhs,ci)
False False
-> (dp_rhs,ci) -> (dp_rhs,ci)
// ... collect
# #
/*** generate the expression ***/ /*** 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 (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 (twotuple, ci) = getTupleSymbol 2 ci
//Sjaak (case_info_ptr, ci) = case_ptr ci
(default_expr, ci) = toExpression this_default ci (default_expr, ci) = toExpression this_default ci
// was coercions // was coercions
...@@ -960,20 +889,16 @@ where ...@@ -960,20 +889,16 @@ where
(let_binds, ci) = bind_indirection_var ind_var unify_result_var twotuple ci (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 a_ij_binds = add_x_i_bind opened_dynamic.opened_dynamic_expr dp_var a_ij_binds