Commit dabb1854 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Bug fixes: default cases and (more or less) correct types for generated case...

Bug fixes: default cases and (more or less) correct types for generated case and let expressions in the conversion of dynamics
parent a2b1a621
......@@ -317,7 +317,7 @@ where
// loadandrun2 _ _ = abort "Loader: process and input do not match"
//
# (Yes old_case_default) = this_case_default
# (let_info_ptr, ci) = let_ptr ci
// # (let_info_ptr, ci) = let_ptr ci
# (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
......@@ -332,6 +332,8 @@ where
= 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 */
# (let_info_ptr, ci) = let_ptr 1 ci
# letje
= Let {
let_strict_binds = []
......@@ -408,7 +410,8 @@ where
[] -> (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)
_ # (let_info_ptr, ci) = let_ptr 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,
......@@ -438,7 +441,7 @@ where
/* 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
(let_info_ptr, ci) = let_ptr ci
(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,
......@@ -642,12 +645,12 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
// c_1 ind_0
(binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
(let_info_ptr, ci) = let_ptr 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 */
(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,
......@@ -716,8 +719,7 @@ where
#
(coerce_symb, ci) = getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
(twotuple, ci) = getTupleSymbol 2 ci
(let_info_ptr, ci) = let_ptr ci
(case_info_ptr, ci) = case_ptr ci
//Sjaak (case_info_ptr, ci) = case_ptr ci
(coerce_result_var, ci) = newVariable "result" VI_Empty ci
coerce_result_fv = varToFreeVar coerce_result_var 1
......@@ -747,26 +749,25 @@ where
= 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 ... */
# let_expr
= Let {
let_strict_binds = []
// MW0 , let_lazy_binds = (if (isNo this_default) [] [ {bind_src = opt opt_expr , bind_dst = c_inc_i_fv }]) ++ [
// MW0 { bind_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr },
// MW0 bind_dst = coerce_result_fv }
, 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_dst = coerce_result_fv, lb_position = NoPos }
,
// MW0 { bind_src = TupleSelect twotuple 0 (Var coerce_result_var),
// MW0 bind_dst = coerce_bool_fv } : let_binds
{ lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/,
lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
],
let_expr =
Case { case_expr = Var coerce_bool_var,
// MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
]
(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,
......@@ -849,8 +850,7 @@ where
/*** 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
(let_info_ptr, ci) = let_ptr ci
(case_info_ptr, ci) = case_ptr ci
//Sjaak (case_info_ptr, ci) = case_ptr ci
(default_expr, ci) = toExpression this_default ci
// was coercions
......@@ -885,21 +885,20 @@ where
App module_symb
// ...TIJDELIJK
*/
/* Sjaak ... */
(let_info_ptr, ci) = let_ptr 2 ci
(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_expr = Let { let_strict_binds = [],
// MW0 let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr },
// MW0 bind_dst = unify_result_fv },
// MW0 { bind_src = TupleSelect twotuple 0 (Var unify_result_var),
// MW0 bind_dst = unify_bool_fv } : let_binds
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,
// MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
case_default = default_expr,
case_ident = No,
......@@ -908,7 +907,6 @@ where
case_explicit = False,
// ... RWS
case_default_pos= NoPos }, // MW4++
// MW0 let_info_ptr = let_info_ptr }
let_info_ptr = let_info_ptr,
let_expr_position = NoPos }
......@@ -1177,6 +1175,9 @@ v_tc_placeholder :== "tc_placeholder"
a_aij_tc_var_name :== { id_name = "a_ij_tc", id_info = nilPtr }
/* Sjaak ...
WAS
case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
case_ptr ci=:{ci_expr_heap}
# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType { ct_pattern_type = empty_attributed_type,
......@@ -1189,9 +1190,28 @@ let_ptr ci=:{ci_expr_heap}
# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType (repeat empty_attributed_type)) ci_expr_heap
= (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap})
REPLACED BY:
Sjaak ... */
bool_case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
bool_case_ptr ci=:{ci_expr_heap}
# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType { ct_pattern_type = toAType (TB BT_Bool),
ct_result_type = empty_attributed_type,
ct_cons_types = [[toAType (TB BT_Bool)]]}) ci_expr_heap
= (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap})
let_ptr :: !Int !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
let_ptr nr_of_binds ci=:{ci_expr_heap}
# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType (repeatn nr_of_binds empty_attributed_type)) ci_expr_heap
= (expr_info_ptr, {ci & ci_expr_heap = ci_expr_heap})
/* Sjaak ... */
toAType :: Type -> AType
toAType type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }
empty_attributed_type :: AType
empty_attributed_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }
empty_attributed_type = toAType TE
/* ... Sjaak */
isNo :: (Optional a) -> Bool
......
......@@ -6,13 +6,13 @@ import syntax, Heap, typesupport, check, overloading, unitype, utilities //, RWS
NotASelector :== -1
class refMark expr :: ![[FreeVar]] !Int !expr !*VarHeap -> *VarHeap
class refMark expr :: ![[FreeVar]] !Int !(Optional Expression) !expr !*VarHeap -> *VarHeap
instance refMark [a] | refMark a
where
refMark free_vars sel list var_heap
= foldSt (refMark free_vars sel) list var_heap
refMark free_vars sel _ list var_heap
= foldSt (refMark free_vars sel No) list var_heap
collectAllSelections [] cum_sels
= cum_sels
......@@ -34,7 +34,6 @@ where
save_occurrence {fv_name,fv_info_ptr} var_heap
# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap
= var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = RC_Unused, occ_previous = [occ_ref_count : occ_previous] } )
adjustRefCount sel RC_Unused var_expr_ptr
| sel == NotASelector
......@@ -77,7 +76,7 @@ refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr va
= case var_occ.occ_bind of // ---> ("refMarkOfVariable", var_name,occ_ref_count,var_occ.occ_ref_count) of
OB_OpenLet let_expr
# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
-> refMark free_vars sel let_expr var_heap
-> refMark free_vars sel No let_expr var_heap
OB_Pattern used_pattern_vars occ_bind
-> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }))
_
......@@ -86,33 +85,40 @@ refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr va
instance refMark BoundVar
where
refMark free_vars sel {var_name,var_expr_ptr,var_info_ptr} var_heap
refMark free_vars sel _ {var_name,var_expr_ptr,var_info_ptr} var_heap
# (var_occ, var_heap) = readPtr var_info_ptr var_heap
= refMarkOfVariable free_vars sel var_occ var_name var_info_ptr var_expr_ptr var_heap
combineDefaults outer_default No explicit
| explicit
= No
= outer_default
combineDefaults outer_default this_default explicit
= this_default
instance refMark Expression
where
refMark free_vars sel (Var var) var_heap
= refMark free_vars sel var var_heap
refMark free_vars sel (App {app_args}) var_heap
= refMark free_vars NotASelector app_args var_heap
refMark free_vars sel (fun @ args) var_heap
= refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap)
refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
refMark free_vars sel _ (Var var) var_heap
= refMark free_vars sel No var var_heap
refMark free_vars sel _ (App {app_args}) var_heap
= refMark free_vars NotASelector No app_args var_heap
refMark free_vars sel _ (fun @ args) var_heap
= refMark free_vars NotASelector No args (refMark free_vars NotASelector No fun var_heap)
refMark free_vars sel def (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
| isEmpty let_lazy_binds
# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ] : free_vars]
# (observing, var_heap) = binds_are_observing let_strict_binds var_heap
| observing
# var_heap = saveOccurrences free_vars var_heap
var_heap = refMark new_free_vars NotASelector let_strict_binds var_heap
var_heap = refMark new_free_vars NotASelector No let_strict_binds var_heap
var_heap = saveOccurrences new_free_vars var_heap
var_heap = refMark new_free_vars sel let_expr var_heap
var_heap = refMark new_free_vars sel def let_expr var_heap
= let_combine free_vars var_heap
= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap)
= refMark new_free_vars sel def let_expr (refMark new_free_vars NotASelector No let_strict_binds var_heap)
# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars]
var_heap = foldSt bind_variable let_strict_binds var_heap
var_heap = foldSt bind_variable let_lazy_binds var_heap
= refMark new_free_vars sel let_expr var_heap
= refMark new_free_vars sel def let_expr var_heap
where
binds_are_observing binds var_heap
......@@ -135,26 +141,26 @@ where
# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src })
refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap
= refMarkOfCase free_vars sel case_expr case_guards case_default var_heap
refMark free_vars sel (Selection _ expr selectors) var_heap
= refMark free_vars (field_number selectors) expr var_heap
refMark free_vars sel def (Case {case_expr,case_guards,case_default,case_explicit}) var_heap
= refMarkOfCase free_vars sel case_expr case_guards case_explicit (combineDefaults def case_default case_explicit) var_heap
refMark free_vars sel _ (Selection _ expr selectors) var_heap
= refMark free_vars (field_number selectors) No expr var_heap
where
field_number [ RecordSelection _ field_nr : _ ]
= field_nr
field_number _
= NotASelector
refMark free_vars sel (Update expr1 selectors expr2) var_heap
# var_heap = refMark free_vars NotASelector expr1 var_heap
var_heap = refMark free_vars NotASelector selectors var_heap
= refMark free_vars NotASelector expr2 var_heap
refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap
refMark free_vars sel _ (Update expr1 selectors expr2) var_heap
# var_heap = refMark free_vars NotASelector No expr1 var_heap
var_heap = refMark free_vars NotASelector No selectors var_heap
= refMark free_vars NotASelector No expr2 var_heap
refMark free_vars sel _ (RecordUpdate cons_symbol expression expressions) var_heap
= ref_mark_of_record_expression free_vars expression expressions var_heap
where
ref_mark_of_record_expression free_vars (Var var) fields var_heap
= ref_mark_of_fields 0 free_vars fields var var_heap
ref_mark_of_record_expression free_vars expression fields var_heap
# var_heap = refMark free_vars NotASelector expression var_heap
# var_heap = refMark free_vars NotASelector No expression var_heap
= foldSt (ref_mark_of_field free_vars) fields var_heap
ref_mark_of_fields field_nr free_vars [] var var_heap
......@@ -164,19 +170,19 @@ where
var_heap = refMarkOfVariable free_vars field_nr var_occ var_name var_info_ptr expr_ptr var_heap
= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap
ref_mark_of_fields field_nr free_vars [{bind_src} : fields] var var_heap
# var_heap = refMark free_vars NotASelector bind_src var_heap
# var_heap = refMark free_vars NotASelector No bind_src var_heap
= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap
ref_mark_of_field free_vars {bind_src} var_heap
= refMark free_vars NotASelector bind_src var_heap
= refMark free_vars NotASelector No bind_src var_heap
refMark free_vars sel (TupleSelect _ arg_nr expr) var_heap
= refMark free_vars arg_nr expr var_heap
refMark free_vars sel (MatchExpr _ _ expr) var_heap
= refMark free_vars sel expr var_heap
refMark free_vars sel EE var_heap
refMark free_vars sel _ (TupleSelect _ arg_nr expr) var_heap
= refMark free_vars arg_nr No expr var_heap
refMark free_vars sel _ (MatchExpr _ _ expr) var_heap
= refMark free_vars sel No expr var_heap
refMark free_vars sel _ EE var_heap
= var_heap
refMark _ _ _ var_heap
refMark _ _ _ _ var_heap
= var_heap
......@@ -185,21 +191,15 @@ isUsed _ = True
instance refMark LetBind
where
refMark free_vars sel {lb_src} var_heap
= refMark free_vars NotASelector lb_src var_heap
refMark free_vars sel _ {lb_src} var_heap
= refMark free_vars NotASelector No lb_src var_heap
/* MW0 not necessary anymore
instance refMark (Bind a b) | refMark a
where
refMark free_vars sel {bind_src} var_heap
= refMark free_vars NotASelector bind_src var_heap
*/
instance refMark Selection
where
refMark free_vars _ (ArraySelection _ _ index_expr) var_heap
= refMark free_vars NotASelector index_expr var_heap
refMark free_vars _ _ var_heap
refMark free_vars _ _ (ArraySelection _ _ index_expr) var_heap
= refMark free_vars NotASelector No index_expr var_heap
refMark free_vars _ _ _ var_heap
= var_heap
collectUsedFreeVariables free_vars var_heap
......@@ -257,26 +257,28 @@ where
_
-> var_heap
refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) defaul var_heap
= ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) explicit defaul var_heap
= ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap
where
ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns defaul var_heap
ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns explicit defaul var_heap
# (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap
= case occ_bind of
OB_Empty
-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
OB_OpenLet let_expr
# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
var_heap = refMark free_vars sel let_expr var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
var_heap = refMark free_vars sel No let_expr var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
OB_LockedLet _
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns defaul var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
OB_Pattern vars ob
-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap
= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns explicit defaul var_heap
ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused}
free_vars sel patterns case_default var_heap
# var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_default var_heap
free_vars sel patterns case_explicit case_default var_heap
# var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap
(VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
= case var_occ.occ_ref_count of
RC_Unused
......@@ -286,33 +288,44 @@ where
-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ &
occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }})
ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr
var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel patterns case_default var_heap
var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel patterns case_explicit case_default var_heap
# var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]),
rcu_uniquely = [], rcu_selectively = [] }}
var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ )
= ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_default var_heap
= ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap
ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_default var_heap
# var_heap = refMark free_vars NotASelector expr var_heap
= ref_mark_of_patterns True free_vars sel No patterns case_default var_heap
ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_explicit case_default var_heap
# var_heap = refMark free_vars NotASelector No expr var_heap
= ref_mark_of_patterns True free_vars sel No patterns case_explicit case_default var_heap
ref_mark_of_patterns with_composite_pattern free_vars sel opt_pattern_var patterns case_default var_heap
ref_mark_of_patterns with_composite_pattern free_vars sel opt_pattern_var patterns case_explicit case_default var_heap
# (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
(with_pattern_bindings, pattern_depth, used_lets, var_heap)
= foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets) patterns (False, 0, [], var_heap)
= foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets (propagateDefault case_explicit case_default))
patterns (False, 0, [], var_heap)
= refMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars sel case_default used_lets var_heap
ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets {ap_vars,ap_expr}
ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def {ap_vars,ap_expr}
(with_pattern_bindings, pattern_depth, used_lets, var_heap)
# pattern_depth = inc pattern_depth
var_heap = saveOccurrences free_vars var_heap
used_pattern_vars = collectPatternsVariables ap_vars
var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap
var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel ap_expr var_heap
var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap
var_heap = restore_binding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap
(used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
var_heap = clear_local_vars used_pattern_vars var_heap
= (with_pattern_bindings || not (isEmpty used_pattern_vars), pattern_depth, used_lets, var_heap)
clear_local_vars vars var_heap
= foldSt clear_occurrence vars var_heap
where
clear_occurrence ({fv_name,fv_info_ptr},_) var_heap
# (var_info, var_heap) = readPtr fv_info_ptr var_heap
= case var_info of
VI_Occurrence occ
-> var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_previous = [], occ_bind = OB_Empty })
bind_optional_pattern_variable _ [] var_heap
= var_heap
bind_optional_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap
......@@ -330,41 +343,47 @@ where
restore_binding_of_pattern_variable _ used_pattern_vars var_heap
= var_heap
refMarkOfCase free_vars sel expr (BasicPatterns type patterns) defaul var_heap
# var_heap = refMark free_vars NotASelector expr var_heap
refMarkOfCase free_vars sel expr (BasicPatterns type patterns) explicit defaul var_heap
# var_heap = refMark free_vars NotASelector No expr var_heap
(local_lets, var_heap) = collectLocalLetVars free_vars var_heap
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets (propagateDefault explicit defaul))
patterns (0, [], var_heap)
= refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap
// ---> ("refMarkOfCase", expr, [ (bp_value, bp_expr) \\ {bp_value, bp_expr} <- patterns])
where
ref_mark_of_basic_pattern free_vars sel local_lets {bp_expr} (pattern_depth, used_lets, var_heap)
ref_mark_of_basic_pattern free_vars sel local_lets def {bp_expr} (pattern_depth, used_lets, var_heap)
# pattern_depth = inc pattern_depth
var_heap = saveOccurrences free_vars var_heap
var_heap = refMark free_vars sel bp_expr var_heap
var_heap = refMark free_vars sel def bp_expr var_heap
(used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
= (pattern_depth, used_lets, var_heap)
refMarkOfCase free_vars sel expr (DynamicPatterns patterns) defaul var_heap
refMarkOfCase free_vars sel expr (DynamicPatterns patterns) explicit defaul var_heap
# var_heap = saveOccurrences free_vars var_heap
var_heap = refMark free_vars NotASelector expr var_heap
var_heap = refMark free_vars NotASelector No expr var_heap
(used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap
var_heap = parCombine free_vars var_heap
(local_lets, var_heap) = collectLocalLetVars free_vars var_heap
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets (propagateDefault explicit defaul)) patterns (0, [], var_heap)
= refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap
where
ref_mark_of_dynamic_pattern free_vars sel local_lets {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap)
ref_mark_of_dynamic_pattern free_vars sel local_lets def {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap)
# pattern_depth = inc pattern_depth
var_heap = saveOccurrences free_vars var_heap
used_pattern_vars = collectPatternsVariables [dp_var]
var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel dp_rhs var_heap
var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def dp_rhs var_heap
(used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
= (pattern_depth, used_lets, var_heap)
propagateDefault case_explicit case_default
| case_explicit
= No
= case_default
refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap
# pattern_depth = inc pattern_depth
var_heap = saveOccurrences free_vars var_heap
var_heap = refMark free_vars sel expr var_heap
var_heap = refMark free_vars sel No expr var_heap
var_heap = setUsedLetVars used_lets var_heap
= caseCombine do_par_combine free_vars var_heap pattern_depth
refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap
......@@ -494,7 +513,7 @@ where
coercion_env subst type_def_infos var_heap expr_heap error
# variables = tb_args ++ fi_local_vars
(subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap
var_heap = refMark [tb_args] NotASelector tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap
var_heap = refMark [tb_args] NotASelector No tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb)) var_heap
position = newPosition fun_symb fun_pos
(coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap
(setErrorAdmin position error)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment