Commit 0d6e1d22 authored by John van Groningen's avatar John van Groningen
Browse files

keep case_explicit, instead of setting case_explicit to False for all

Case expressions (including cases not usings dynamics) in functions
using dynamics.
parent 16397e68
......@@ -143,8 +143,8 @@ where
# (fun_body, ci) = convertDynamics {cinp_st_args = [], cinp_dynamic_representation = dynamic_representation,
cinp_subst_var = unify_subst_var} fun_body ci
= ({fun_defs & [fun] = { fun_def & fun_body = fun_body, fun_info = { fun_info & fi_local_vars = ci.ci_new_variables ++ fun_info.fi_local_vars }}},
{ ci & ci_new_variables = [] })
= ({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 = []})
class convertDynamics a :: !ConversionInput !a !*ConversionState -> (!a, !*ConversionState)
......@@ -154,16 +154,14 @@ instance convertDynamics [a] | convertDynamics a where
instance convertDynamics (Optional a) | convertDynamics a where
convertDynamics cinp (Yes x) ci
# (x, ci)
= convertDynamics cinp x ci
# (x, ci) = convertDynamics cinp x ci
= (Yes x, ci)
convertDynamics _ No ci
= (No, ci)
instance convertDynamics FunctionBody where
convertDynamics cinp (TransformedBody body) ci
# (body, ci)
= convertDynamics cinp body ci
# (body, ci) = convertDynamics cinp body ci
= (TransformedBody body, ci)
instance convertDynamics TransformedBody where
......@@ -233,14 +231,9 @@ instance convertDynamics TransformedBody where
, lb_dst = varToFreeVar subst 1
, lb_position = NoPos
}
# let_binds
= [let_bind_initial_subst : global_tpv_binds]
# let_binds = [let_bind_initial_subst : global_tpv_binds]
# (let_info_ptr, ci) = let_ptr (length let_binds) ci
# ci
= { ci &
ci_new_variables = [lb_dst \\ {lb_dst} <- let_binds] ++ ci.ci_new_variables
}
# ci = { ci & ci_new_variables = [lb_dst \\ {lb_dst} <- let_binds] ++ ci.ci_new_variables}
# rhs
= Let { let_strict_binds = [],
let_lazy_binds = let_binds,
......@@ -252,72 +245,55 @@ instance convertDynamics TransformedBody where
instance convertDynamics LetBind where
convertDynamics cinp binding=:{lb_src} ci
# (lb_src, ci)
= convertDynamics cinp lb_src ci
# (lb_src, ci) = convertDynamics cinp lb_src ci
= ({binding & lb_src = lb_src}, ci)
instance convertDynamics (Bind a b) | convertDynamics a where
convertDynamics cinp binding=:{bind_src} ci
# (bind_src, ci)
= convertDynamics cinp bind_src ci
# (bind_src, ci) = convertDynamics cinp bind_src ci
= ({binding & bind_src = bind_src}, ci)
instance convertDynamics Expression where
convertDynamics cinp (TypeCodeExpression tce) ci
# (dyn_type_code, ci)
= convertExprTypeCode cinp tce ci
# (dyn_type_code, ci) = convertExprTypeCode cinp tce ci
= (dyn_type_code, ci)
convertDynamics cinp (Var var) ci
# (info, ci_var_heap)
= readPtr var.var_info_ptr ci.ci_var_heap
# ci
= {ci & ci_var_heap = ci_var_heap}
# ci = {ci & ci_var_heap = ci_var_heap}
= case (info, ci) of
(VI_DynamicValueAlias value_var, ci)
-> (Var value_var, ci)
(_, ci)
-> (Var var, ci)
convertDynamics cinp (App app) ci
# (app, ci)
= convertDynamics cinp app ci
# (app, ci) = convertDynamics cinp app ci
= (App app, ci)
convertDynamics cinp (expr @ exprs) ci
# (expr, ci)
= convertDynamics cinp expr ci
(exprs, ci)
= convertDynamics cinp exprs ci
# (expr, ci) = convertDynamics cinp expr ci
(exprs, ci) = convertDynamics cinp exprs ci
= (expr @ exprs, ci)
convertDynamics cinp (Let letje) ci
# (letje, ci)
= convertDynamics cinp letje ci
# (letje, ci) = convertDynamics cinp letje ci
= (Let letje, ci)
convertDynamics cinp (Case kees) ci
# (kees, ci)
= convertDynamics cinp kees ci
# (kees, ci) = convertDynamics cinp kees ci
= (Case kees, ci)
convertDynamics cinp (Selection opt_symb expression selections) ci
# (expression,ci)
= convertDynamics cinp expression ci
# (selections,ci)
= convertDynamics cinp selections ci
# (expression,ci) = convertDynamics cinp expression ci
# (selections,ci) = convertDynamics cinp selections ci
= (Selection opt_symb expression selections, ci)
convertDynamics cinp (Update expression1 selections expression2) ci
# (expression1, ci)
= convertDynamics cinp expression1 ci
# (selections, ci)
= convertDynamics cinp selections ci
# (expression2, ci)
= convertDynamics cinp expression2 ci
# (expression1, ci) = convertDynamics cinp expression1 ci
# (selections, ci) = convertDynamics cinp selections ci
# (expression2, ci) = convertDynamics cinp expression2 ci
= (Update expression1 selections expression2, ci)
convertDynamics cinp (RecordUpdate cons_symbol expression expressions) ci
# (expression, ci)
= convertDynamics cinp expression ci
# (expressions, ci)
= convertDynamics cinp expressions ci
# (expression, ci) = convertDynamics cinp expression ci
# (expressions, ci) = convertDynamics cinp expressions ci
= (RecordUpdate cons_symbol expression expressions, ci)
convertDynamics cinp (TupleSelect definedSymbol int expression) ci
# (expression, ci)
= convertDynamics cinp expression ci
# (expression, ci) = convertDynamics cinp expression ci
= (TupleSelect definedSymbol int expression, ci)
convertDynamics _ be=:(BasicExpr _) ci
= (be, ci)
......@@ -326,8 +302,7 @@ instance convertDynamics Expression where
convertDynamics _ code_expr=:(ABCCodeExpr _ _) ci
= (code_expr, ci)
convertDynamics cinp (MatchExpr symb expression) ci
# (expression, ci)
= convertDynamics cinp expression ci
# (expression, ci) = convertDynamics cinp expression ci
= (MatchExpr symb expression, ci)
convertDynamics cinp (DynamicExpr dyno) ci
= convertDynamic cinp dyno ci
......@@ -338,76 +313,57 @@ instance convertDynamics Expression where
instance convertDynamics App where
convertDynamics cinp app=:{app_args} ci
# (app_args,ci)
= convertDynamics cinp app_args ci
# (app_args,ci) = convertDynamics cinp app_args ci
= ({app & app_args = app_args}, ci)
instance convertDynamics Let where
convertDynamics cinp letje=:{let_strict_binds, let_lazy_binds,
let_expr, let_info_ptr} ci
# (let_strict_binds, ci)
= convertDynamics cinp let_strict_binds ci
(let_lazy_binds, ci)
= convertDynamics cinp let_lazy_binds ci
(let_expr, ci)
= convertDynamics cinp let_expr ci
letje
= { letje & let_strict_binds = let_strict_binds,
let_lazy_binds = let_lazy_binds, let_expr = let_expr}
convertDynamics cinp letje=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr} ci
# (let_strict_binds, ci) = convertDynamics cinp let_strict_binds ci
(let_lazy_binds, ci) = convertDynamics cinp let_lazy_binds ci
(let_expr, ci) = convertDynamics cinp let_expr ci
letje = {letje & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr}
= (letje, ci)
instance convertDynamics Case where
convertDynamics cinp kees=:{case_expr, case_guards, case_default} ci
# (case_expr, ci)
= convertDynamics cinp case_expr ci
# (case_default, ci)
= convertDynamics cinp case_default ci
# kees
= {kees & case_expr=case_expr, case_default=case_default}
# (case_expr, ci) = convertDynamics cinp case_expr ci
# (case_default, ci) = convertDynamics cinp case_default ci
# kees = {kees & case_expr=case_expr, case_default=case_default}
= case case_guards of
DynamicPatterns alts
-> convertDynamicCase cinp kees ci
_
# (case_guards, ci)
= convertDynamics cinp case_guards ci
# kees
= {kees & case_explicit=False, case_guards=case_guards}
# (case_guards, ci) = convertDynamics cinp case_guards ci
# kees = {kees & case_guards=case_guards}
-> (kees, ci)
instance convertDynamics CasePatterns where
convertDynamics cinp (BasicPatterns type alts) ci
# (alts, ci)
= convertDynamics cinp alts ci
# (alts, ci) = convertDynamics cinp alts ci
= (BasicPatterns type alts, ci)
convertDynamics cinp (AlgebraicPatterns type alts) ci
# (alts, ci)
= convertDynamics cinp alts ci
# (alts, ci) = convertDynamics cinp alts ci
= (AlgebraicPatterns type alts, ci)
convertDynamics cinp (OverloadedListPatterns type decons alts) ci
# (alts, ci)
= convertDynamics cinp alts ci
# (alts, ci) = convertDynamics cinp alts ci
= (OverloadedListPatterns type decons alts, ci)
convertDynamic cinp=:{cinp_dynamic_representation={dr_type_ident}}
{dyn_expr, dyn_type_code} ci
# (dyn_expr, ci)
= convertDynamics cinp dyn_expr ci
# (dyn_expr, ci) = convertDynamics cinp dyn_expr ci
# (dyn_type_code, ci)
= convertExprTypeCode cinp dyn_type_code ci
= (App { app_symb = dr_type_ident,
app_args = [dyn_expr, dyn_type_code],
app_info_ptr = nilPtr }, ci)
convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dynamic_type}}
kees=:{case_guards=DynamicPatterns alts, case_info_ptr, case_default} ci
# (value_var, ci)
= newVariable "value" VI_Empty ci
# (type_var, ci)
= newVariable "type" VI_Empty ci
# ci
= {ci & ci_new_variables = [varToFreeVar value_var 1, varToFreeVar type_var 1 : ci.ci_new_variables ]}
# (value_var, ci) = newVariable "value" VI_Empty ci
# (type_var, ci) = newVariable "type" VI_Empty ci
# ci = {ci & ci_new_variables = [varToFreeVar value_var 1, varToFreeVar type_var 1 : ci.ci_new_variables ]}
# (result_type, ci)
= getResultType case_info_ptr ci
# (result_type, ci) = getResultType case_info_ptr ci
# (matches, ci)
= case convertDynamicAlts cinp kees type_var value_var result_type case_default alts ci of
(Yes matches, ci) -> (matches, ci)
......@@ -418,11 +374,8 @@ convertDynamicCase cinp=:{cinp_dynamic_representation={dr_dynamic_symbol, dr_dyn
, ap_expr = matches
, ap_position = position alts
}
# (case_info_ptr, ci)
= dummy_case_ptr result_type ci
# kees
= {kees & case_explicit=False, case_guards=AlgebraicPatterns dr_dynamic_type [match],
case_default=No, case_info_ptr = case_info_ptr}
# (case_info_ptr, ci) = dummy_case_ptr result_type ci
# kees = {kees & case_guards=AlgebraicPatterns dr_dynamic_type [match], case_default=No, case_info_ptr = case_info_ptr}
= (kees, ci)
convertDynamicAlts _ _ _ _ _ defoult [] ci
......@@ -434,51 +387,34 @@ convertDynamicAlts cinp kees type_var value_var result_type defoult [{dp_rhs, dp
# (unify_symb, ci)
= getSymbol PD_Dyn_unify SK_Function (extended_unify_and_coerce 3 4) /*3 was 2 */ ci
# unify_call
= App { app_symb = unify_symb, app_args = [ Var cinp.cinp_subst_var, Var type_var, type_code], app_info_ptr = nilPtr }
# unify_call = App {app_symb = unify_symb, app_args = [Var cinp.cinp_subst_var,Var type_var,type_code], app_info_ptr = nilPtr}
// FIXME, more precise types (not all TEs)
# (let_info_ptr, ci)
= let_ptr (/* 4 */ 3+length binds) ci
(unify_result_var, ci)
= newVariable "result" VI_Empty ci
unify_result_fv
= varToFreeVar unify_result_var 1
(unify_bool_var, ci)
= newVariable "unify_bool" VI_Empty ci
unify_bool_fv
= varToFreeVar unify_bool_var 1
(unify_subst_var, ci)
= newVariable "unify_subst" VI_Empty ci
unify_subst_fv
= varToFreeVar unify_subst_var 1
# (let_info_ptr, ci) = let_ptr (/* 4 */ 3+length binds) ci
(unify_result_var, ci) = newVariable "result" VI_Empty ci
unify_result_fv = varToFreeVar unify_result_var 1
(unify_bool_var, ci) = newVariable "unify_bool" VI_Empty ci
unify_bool_fv = varToFreeVar unify_bool_var 1
(unify_subst_var, ci) = newVariable "unify_subst" VI_Empty ci
unify_subst_fv = varToFreeVar unify_subst_var 1
# ci_var_heap = writePtr dp_var.fv_info_ptr (VI_DynamicValueAlias value_var) ci.ci_var_heap
# ci = {ci & ci_var_heap = ci_var_heap}
# (dp_rhs, ci)
= convertDynamics {cinp & cinp_subst_var=unify_subst_var} dp_rhs ci
# (dp_rhs, ci) = convertDynamics {cinp & cinp_subst_var=unify_subst_var} dp_rhs ci
# (case_info_ptr, ci)
= bool_case_ptr result_type ci
# case_guards
= BasicPatterns BT_Bool
[{bp_value = BVB True, bp_expr = dp_rhs, bp_position = dp_position}]
# (case_info_ptr, ci) = bool_case_ptr result_type ci
# case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = dp_position}]
# (case_default, ci)
= convertDynamicAlts cinp
kees type_var value_var result_type defoult alts ci
= convertDynamicAlts cinp kees type_var value_var result_type defoult alts ci
# kees
= {kees & case_info_ptr=case_info_ptr, case_guards=case_guards,
# kees = {kees & case_info_ptr=case_info_ptr, case_guards=case_guards,
case_default=case_default, case_explicit=False, case_expr=Var unify_bool_var}
# ci
= {ci & ci_new_variables = [unify_result_fv, unify_bool_fv, unify_subst_fv : ci.ci_new_variables ]}
# ci = {ci & ci_new_variables = [unify_result_fv, unify_bool_fv, unify_subst_fv : ci.ci_new_variables ]}
(twotuple, ci)
= getTupleSymbol 2 ci
(twotuple, ci) = getTupleSymbol 2 ci
letje
= { let_strict_binds = [{ lb_src = unify_call,
......@@ -495,7 +431,6 @@ convertDynamicAlts cinp kees type_var value_var result_type defoult [{dp_rhs, dp
= (Yes (Let letje), ci)
class position a :: a -> Position
instance position [a] | position a where
......@@ -510,26 +445,22 @@ instance position DynamicPattern where
instance convertDynamics BasicPattern where
convertDynamics cinp alt=:{bp_expr} ci
# (bp_expr, ci)
= convertDynamics cinp bp_expr ci
# (bp_expr, ci) = convertDynamics cinp bp_expr ci
= ({alt & bp_expr=bp_expr}, ci)
instance convertDynamics AlgebraicPattern where
convertDynamics cinp alt=:{ap_expr} ci
# (ap_expr, ci)
= convertDynamics cinp ap_expr ci
# (ap_expr, ci) = convertDynamics cinp ap_expr ci
= ({alt & ap_expr=ap_expr}, ci)
instance convertDynamics Selection where
convertDynamics cinp selection=:(RecordSelection _ _) ci
= (selection, ci)
convertDynamics cinp (ArraySelection selector expr_ptr expr) ci
# (expr, ci)
= convertDynamics cinp expr ci
# (expr, ci) = convertDynamics cinp expr ci
= (ArraySelection selector expr_ptr expr, ci)
convertDynamics cinp (DictionarySelection var selectors expr_ptr expr) ci
# (expr, ci)
= convertDynamics cinp expr ci
# (expr, ci) = convertDynamics cinp expr ci
= (DictionarySelection var selectors expr_ptr expr, ci)
convertExprTypeCode
......@@ -555,8 +486,7 @@ convertExprTypeCode cinp tce ci
convertPatternTypeCode :: !ConversionInput !TypeCodeExpression !*ConversionState
-> (!Expression, ![LetBind], !*ConversionState)
convertPatternTypeCode cinp tce ci
# (type_code, (_, binds, ci))
= convertTypeCode True cinp tce (False, [], ci)
# (type_code, (_, binds, ci)) = convertTypeCode True cinp tce (False, [], ci)
= (type_code, binds, ci)
convertTypeCode :: !Bool !ConversionInput !TypeCodeExpression (!Bool, ![LetBind], !*ConversionState)
......
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