Skip to content
GitLab
Commit 999a53ef authored by John van Groningen's avatar John van Groningen
Browse files

add pattern match test using =: in expressions, 

add constructors PE_Matches and IsConstructor in module syntax
parent 7d1e8173
Hide whitespace changes
Inline Side-by-side
frontend/checkFunctionBodies.icl
View file @ 999a53ef
......@@ -878,7 +878,45 @@ checkExpression free_vars (PE_TypeSignature array_kind expr) e_input e_state e_i
# expr = TypeSignature strict_array_type expr
*/
checkExpression free_vars (PE_Matches case_ident expr pattern position) e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
{es_fun_defs,es_var_heap,es_expr_heap} = e_state
ps = {ps_var_heap = es_var_heap,ps_fun_defs = es_fun_defs}
(pattern, (_/*var_env*/, _/*array_patterns*/), {ps_fun_defs,ps_var_heap}, e_info, cs)
= checkPattern pattern No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], []) ps e_info cs
| is_single_constructor_pattern pattern
= case pattern of
AP_Algebraic cons_symbol type_index args _
# is_cons_expr = IsConstructor expr cons_symbol (length args) {gi_module=cons_symbol.glob_module,gi_index=type_index} case_ident position
e_state & es_fun_defs=ps_fun_defs, es_var_heap = ps_var_heap, es_expr_heap = es_expr_heap
-> (is_cons_expr, free_vars, e_state, e_info, cs)
# fail_expr = Yes (No,BasicExpr (BVB False))
true_expr = BasicExpr (BVB True)
(guarded_expr, pattern_scheme, _/*pattern_variables*/, defaul, es_var_heap, es_expr_heap, _/*dynamics_in_patterns*/, cs)
= transform_pattern pattern NoPattern NoPattern [] fail_expr true_expr case_ident.id_name position ps_var_heap es_expr_heap [] cs
(case_expr, es_var_heap, es_expr_heap)
= build_and_share_case guarded_expr defaul expr case_ident cCaseExplicit es_var_heap es_expr_heap
e_state & es_fun_defs=ps_fun_defs, es_var_heap = es_var_heap, es_expr_heap = es_expr_heap
= (case_expr, free_vars, e_state, e_info, cs)
where
is_single_constructor_pattern (AP_Algebraic cons_symbol _ args No)
| cons_symbol.glob_module==cPredefinedModuleIndex
# pd_cons_index=cons_symbol.glob_object.ds_index+FirstConstructorPredefinedSymbolIndex
| pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedNilSymbol ||
pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_UnboxedTailStrictNilSymbol ||
pd_cons_index==PD_OverloadedConsSymbol || pd_cons_index==PD_OverloadedNilSymbol
= False
= all_wild_card_args args
= all_wild_card_args args
is_single_constructor_pattern _
= False
all_wild_card_args [AP_WildCard No : args]
= all_wild_card_args args
all_wild_card_args [_:_]
= False
all_wild_card_args []
= True
checkExpression free_vars expr e_input e_state e_info cs
= abort "checkExpression (checkFunctionBodies.icl)" // <<- expr
......
frontend/classify.icl
View file @ 999a53ef
......@@ -442,8 +442,6 @@ instance consumerRequirements Expression where
= consumerRequirements case_expr common_defs ai
consumerRequirements (BasicExpr _) _ ai
= (CPassive, False, ai)
consumerRequirements (MatchExpr _ expr) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (Selection _ expr selectors) common_defs ai
# (cc, _, ai) = consumerRequirements expr common_defs ai
ai = aiUnifyClassifications CActive cc ai
......@@ -460,6 +458,10 @@ instance consumerRequirements Expression where
= (CPassive, False, ai)
consumerRequirements (TupleSelect tuple_symbol arg_nr expr) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (MatchExpr _ expr) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (IsConstructor expr _ _ _ _ _) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (AnyCodeExpr _ _ _) _ ai=:{ai_cur_ref_counts}
#! s = size ai_cur_ref_counts
twos_array = n_twos_counts s
......@@ -1427,8 +1429,6 @@ count_locals (Case {case_expr,case_guards,case_default}) n
= count_case_locals case_guards (count_locals case_expr (count_optional_locals case_default n))
count_locals (BasicExpr _) n
= n
count_locals (MatchExpr _ expr) n
= count_locals expr n
count_locals (Selection _ expr selectors) n
= count_selector_locals selectors (count_locals expr n)
count_locals (Update expr1 selectors expr2) n
......@@ -1440,6 +1440,10 @@ count_locals (RecordUpdate _ expr exprs) n
= foldSt count_bind_locals exprs (count_locals expr n)
count_locals (TupleSelect _ _ expr) n
= count_locals expr n
count_locals (MatchExpr _ expr) n
= count_locals expr n
count_locals (IsConstructor expr _ _ _ _ _) n
= count_locals expr n
count_locals (AnyCodeExpr _ _ _) n
= n
count_locals (ABCCodeExpr _ _) n
......@@ -1749,6 +1753,8 @@ instance producerRequirements Expression where
= (False,prs)
producerRequirements (MatchExpr _ expr) prs
= producerRequirements expr prs
producerRequirements (IsConstructor expr _ _ _ _ _) prs
= producerRequirements expr prs
producerRequirements (DynamicExpr _) prs
= (False,prs)
producerRequirements (TypeCodeExpression _) prs
......
frontend/comparedefimp.icl
View file @ 999a53ef
......@@ -1126,6 +1126,10 @@ instance e_corresponds Expression where
(MatchExpr icl_cons_symbol icl_src_expr)
= e_corresponds dcl_cons_symbol icl_cons_symbol
o` e_corresponds dcl_src_expr icl_src_expr
e_corresponds (IsConstructor dcl_src_expr dcl_cons_symbol _ _ _ _)
(IsConstructor icl_src_expr icl_cons_symbol _ _ _ _)
= e_corresponds dcl_cons_symbol icl_cons_symbol
o` e_corresponds dcl_src_expr icl_src_expr
e_corresponds (FreeVar dcl) (FreeVar icl)
= e_corresponds dcl icl
e_corresponds (DynamicExpr dcl) (DynamicExpr icl)
......
frontend/convertDynamics.icl
View file @ 999a53ef
......@@ -3,7 +3,6 @@ implementation module convertDynamics
import syntax
from type_io_common import PredefinedModuleName
// Optional
extended_unify_and_coerce no yes :== no; // change also _unify and _coerce in StdDynamic
......@@ -286,13 +285,16 @@ instance convertDynamics Expression where
= (TupleSelect definedSymbol int expression, ci)
convertDynamics _ be=:(BasicExpr _) ci
= (be, ci)
convertDynamics cinp (MatchExpr symb expression) ci
# (expression, ci) = convertDynamics cinp expression ci
= (MatchExpr symb expression, ci)
convertDynamics cinp (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ci
# (expr, ci) = convertDynamics cinp expr ci
= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ci)
convertDynamics _ code_expr=:(AnyCodeExpr _ _ _) ci
= (code_expr, ci)
convertDynamics _ code_expr=:(ABCCodeExpr _ _) ci
= (code_expr, ci)
convertDynamics cinp (MatchExpr symb expression) ci
# (expression, ci) = convertDynamics cinp expression ci
= (MatchExpr symb expression, ci)
convertDynamics cinp (DynamicExpr dyno) ci
= convertDynamic cinp dyno ci
convertDynamics cinp EE ci
......@@ -324,7 +326,7 @@ instance convertDynamics Case where
_
# (case_guards, ci) = convertDynamics cinp case_guards ci
# kees & case_guards=case_guards
-> (kees, ci)
-> (kees, ci)
instance convertDynamics CasePatterns where
convertDynamics cinp (BasicPatterns type alts) ci
......
frontend/convertcases.icl
View file @ 999a53ef
......@@ -4,13 +4,11 @@ import syntax, compare_types, utilities, expand_types, general
from checksupport import ::Component(..),::ComponentMembers(..)
// exactZip fails when its arguments are of unequal length
exactZip` :: ![.a] ![.b] -> [(.a,.b)]
exactZip` [] []
= []
exactZip` [x:xs][y:ys]
exactZip :: ![.a] ![.b] -> [(.a,.b)]
exactZip [x:xs][y:ys]
= [(x,y) : exactZip xs ys]
exactZip
:== exactZip`
exactZip [] []
= []
getIdent :: (Optional Ident) Int -> Ident
getIdent (Yes ident) fun_nr
......@@ -238,8 +236,6 @@ where
= weightedRefCountOfCase rci case_expr case_info {rs & rcs_expr_heap = rcs_expr_heap}
weightedRefCount rci expr=:(BasicExpr _) rs
= rs
weightedRefCount rci (MatchExpr constructor expr) rs
= weightedRefCount rci expr rs
weightedRefCount rci (Selection opt_tuple expr selections) rs
= weightedRefCount rci (expr, selections) rs
weightedRefCount rci (Update expr1 selections expr2) rs
......@@ -248,6 +244,10 @@ where
= weightedRefCount rci (expr, exprs) rs
weightedRefCount rci (TupleSelect tuple_symbol arg_nr expr) rs
= weightedRefCount rci expr rs
weightedRefCount rci (MatchExpr constructor expr) rs
= weightedRefCount rci expr rs
weightedRefCount rci (IsConstructor expr _ _ _ _ _) rs
= weightedRefCount rci expr rs
weightedRefCount rci (AnyCodeExpr _ _ _) rs
= rs
weightedRefCount rci (ABCCodeExpr _ _) rs
......@@ -308,10 +308,8 @@ weightedRefCountOfCase rci=:{rci_depth} this_case=:{case_expr, case_guards, case
check_symbol {cii_main_dcl_module_n, cii_common_defs} {glob_module, glob_object={ds_index}} collected_imports var_heap
| glob_module <> cii_main_dcl_module_n
# {cons_type_ptr} = cii_common_defs.[glob_module].com_cons_defs.[ds_index]
(collected_imports, var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index})
cons_type_ptr (collected_imports, var_heap)
= (collected_imports, var_heap)
// otherwise
= checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index})
cons_type_ptr (collected_imports, var_heap)
= (collected_imports, var_heap)
weighted_ref_count_of_decons_expr rci (OverloadedListPatterns _ decons_exp _) rs
......@@ -380,6 +378,7 @@ checkImportOfDclFunction {cii_main_dcl_module_n, cii_dcl_functions} mod_index fu
= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
// otherwise
= rs
checkRecordSelector {cii_main_dcl_module_n, cii_common_defs} {glob_module, glob_object={ds_index}} rs=:{rcs_imports,rcs_var_heap}
| glob_module <> cii_main_dcl_module_n
# {com_selector_defs,com_cons_defs,com_type_defs} = cii_common_defs.[glob_module]
......@@ -495,9 +494,6 @@ where
= (fun_expr @ exprs, ds)
distributeLets di expr=:(BasicExpr _) ds
= (expr, ds)
distributeLets di (MatchExpr constructor expr) ds
# (expr, ds) = distributeLets di expr ds
= (MatchExpr constructor expr, ds)
distributeLets di (Selection opt_tuple expr selectors) ds
# (expr, ds) = distributeLets di expr ds
# (selectors, ds) = distributeLets di selectors ds
......@@ -528,7 +524,7 @@ where
// otherwise
= case let_expr of
Let inner_let=:{let_info_ptr=inner_let_info_ptr}
# (EI_LetType strict_inner_types, ds_expr_heap) = readPtr inner_let_info_ptr ds.ds_expr_heap
# (EI_LetType strict_inner_types, ds_expr_heap) = readPtr inner_let_info_ptr ds.ds_expr_heap
# (inner_let_info_ptr, ds_expr_heap)
= newPtr (EI_LetType ((take nr_of_strict_lets let_type)++strict_inner_types)) ds_expr_heap
-> (Let { inner_let & let_strict_binds = let_strict_binds++inner_let.let_strict_binds,
......@@ -558,6 +554,12 @@ where
= distributeLetsInLetExpression di fv_info_ptr lei { ds & ds_var_heap = ds_var_heap }
= { ds & ds_var_heap = ds_var_heap }
distributeLets di (MatchExpr constructor expr) ds
# (expr, ds) = distributeLets di expr ds
= (MatchExpr constructor expr, ds)
distributeLets di (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ds
# (expr, ds) = distributeLets di expr ds
= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ds)
distributeLets _ expr=:(TypeCodeExpression _) ds
= (expr, ds)
distributeLets _ (AnyCodeExpr in_params out_params code_expr) ds=:{ds_var_heap}
......@@ -589,11 +591,10 @@ where
rcc_default_variables = ref_counts_in_default,
rcc_pattern_variables = ref_counts_in_patterns }) = case_old_info
new_depth = di_depth + 1
new_di
= { di
& di_depth = new_depth
, di_explicit_case_depth = if case_explicit new_depth di_explicit_case_depth
}
new_di = { di
& di_depth = new_depth
, di_explicit_case_depth = if case_explicit new_depth di_explicit_case_depth
}
(local_lets, ds_var_heap) = mark_local_let_vars new_depth tot_ref_counts ds_var_heap
// -*-> ("ref_counts", case_expr, tot_ref_counts, ref_counts_in_patterns)
with
......@@ -1075,17 +1076,11 @@ nextAlts si=:{si_next_alt=Yes next_alt, si_force_next_alt} kees=:{case_info_ptr,
= findSplitCases {si & si_force_next_alt=jumps} case_default ss
| jumps && not (hasOption case_default)
// update the info for this case
# ss_expr_heap
= ss.ss_expr_heap <:= (case_info_ptr,
EI_CaseTypeAndSplits type {splits & sic_next_alt = Yes next_alt})
# ss_expr_heap = ss.ss_expr_heap <:= (case_info_ptr, EI_CaseTypeAndSplits type {splits & sic_next_alt = Yes next_alt})
// update the info for the outer case
# (EI_CaseTypeAndSplits type splits, ss_expr_heap)
= readPtr next_alt.na_case ss_expr_heap
split
= {sc_alt_nr = next_alt.na_alt_nr, sc_call = No}
ss_expr_heap
= ss_expr_heap <:= (next_alt.na_case,
EI_CaseTypeAndSplits type {splits & sic_splits = [split : splits.sic_splits]})
# (EI_CaseTypeAndSplits type splits, ss_expr_heap) = readPtr next_alt.na_case ss_expr_heap
split = {sc_alt_nr = next_alt.na_alt_nr, sc_call = No}
ss_expr_heap = ss_expr_heap <:= (next_alt.na_case, EI_CaseTypeAndSplits type {splits & sic_splits = [split : splits.sic_splits]})
= {ss & ss_expr_heap = ss_expr_heap}
= ss
where
......@@ -1111,10 +1106,7 @@ newFunctionWithType :: !(Optional Ident) !FunctionBody ![FreeVar] !SymbolType !I
newFunctionWithType opt_id fun_bodies local_vars fun_type group_index (cs_next_fun_nr, cs_new_functions, cs_fun_heap)
# (fun_def_ptr, cs_fun_heap) = newPtr FI_Empty cs_fun_heap
fun_id = getIdent opt_id cs_next_fun_nr
arity
= fun_type.st_arity
arity = fun_type.st_arity
fun_def =
{ fun_ident = fun_id
, fun_arity = arity
......@@ -1367,25 +1359,20 @@ instance split SplitCase where
= splitIt sc_alt_nr kees
# (case_type1, case_type2)
= splitIt sc_alt_nr case_type
# case_type_and_splits2
= EI_CaseTypeAndSplits case_type2 {sic_splits = [], sic_next_alt = No, sic_case_kind = CaseKindUnknown}
# (case_info_ptr2, cs_expr_heap)
= newPtr case_type_and_splits2 cs_expr_heap
# kees2
= {kees2 & case_info_ptr = case_info_ptr2}
# kees2 = {kees2 & case_info_ptr = case_info_ptr2}
# (call, cs)
= convertNonRootCase ci kees2 {cs & cs_expr_heap = cs_expr_heap}
# kees1
= {kees1 & case_default = Yes call}
# kees1 = {kees1 & case_default = Yes call}
# (EI_CaseTypeAndSplits _ splits1, cs_expr_heap)
= readPtr kees.case_info_ptr cs.cs_expr_heap
# case_type_and_splits1
= EI_CaseTypeAndSplits case_type1 {splits1 & sic_splits = [{split & sc_call = Yes call} : splits1.sic_splits]}
# cs_expr_heap
= cs_expr_heap <:= (kees.case_info_ptr, case_type_and_splits1)
# cs_expr_heap = cs_expr_heap <:= (kees.case_info_ptr, case_type_and_splits1)
= (kees1, case_type1, {cs & cs_expr_heap = cs_expr_heap})
class splitIt a :: CaseAltNr a -> (a, a)
......@@ -1482,8 +1469,6 @@ convertRootCasesCasePatterns ci (BasicPatterns bt patterns) _ cs
= convertRootCases ci patterns cs
= (BasicPatterns bt patterns, cs)
convertRootCasesCasePatterns ci (AlgebraicPatterns gi patterns) arg_types cs
| length patterns <> length arg_types
= abort ("convertRootCasesCasePatterns error number of cases " +++ toString (length patterns) +++ " <> " +++ toString (length arg_types)) <<- arg_types
# (patterns, cs)
= convertRootCasesAlgebraicPatterns ci (exactZip patterns arg_types) cs
= (AlgebraicPatterns gi patterns, cs)
......@@ -1519,7 +1504,7 @@ instance convertRootCases BasicPattern where
= convertRootCases ci bp_expr cs
= ({pattern & bp_expr=bp_expr}, cs)
class convertCases a :: !ConvertInfo !a !*ConvertState -> (!a, !*ConvertState)
class convertCases a :: !ConvertInfo !a !*ConvertState -> (!a, !*ConvertState)
instance convertCases [a] | convertCases a
where
......@@ -1566,9 +1551,6 @@ where
convertCases ci (Let lad) cs
# (lad, cs) = convertCases ci lad cs
= (Let lad, cs)
convertCases ci (MatchExpr constructor expr) cs
# (expr, cs) = convertCases ci expr cs
= (MatchExpr constructor expr, cs)
convertCases ci (Selection is_unique expr selectors) cs
# (expr, cs) = convertCases ci expr cs
(selectors, cs) = convertCases ci selectors cs
......@@ -1592,6 +1574,68 @@ where
{ss_var_heap=cs.cs_var_heap,ss_expr_heap = cs.cs_expr_heap}
cs = {cs & cs_var_heap=ss_var_heap, cs_expr_heap = ss_expr_heap}
= convertNonRootCase ci case_expr cs
convertCases ci (MatchExpr constructor expr) cs
# (expr, cs) = convertCases ci expr cs
= (MatchExpr constructor expr, cs)
convertCases ci=:{ci_common_defs} is_cons_expr=:(IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) cs
# (expr, cs=:{cs_var_heap,cs_expr_heap}) = convertCases ci expr cs
(new_info_ptr, cs_var_heap) = newPtr VI_LocalVar cs_var_heap
var_id = {id_name = "_x", id_info = nilPtr}
case_var = Var {var_ident = var_id, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr}
case_free_var = { fv_def_level = NotALevel, fv_ident = var_id, fv_info_ptr = new_info_ptr, fv_count = 0}
fail_expr = BasicExpr (BVB False)
true_expr = BasicExpr (BVB True)
(var_args,cs_var_heap) = make_free_vars cons_arity cs_var_heap
pattern = {ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = true_expr, ap_position = position}
patterns = AlgebraicPatterns {glob_module=global_type_index.gi_module,glob_object=global_type_index.gi_index} [pattern]
(case_expr_ptr, cs_expr_heap) = newPtr EI_Empty cs_expr_heap
case_expr = Case {case_expr = case_var, case_guards = patterns, case_default = Yes fail_expr, case_ident = No,
case_explicit = False, case_info_ptr = case_expr_ptr, case_default_pos = NoPos}
cs & cs_var_heap=cs_var_heap, cs_expr_heap=cs_expr_heap
bool_type = {at_attribute = TA_None, at_type = TB BT_Bool}
algebraic_type = new_vars_in_algebraic_type ci_common_defs.[cons_symbol.glob_module].com_cons_defs.[cons_symbol.glob_object.ds_index].cons_type.st_result
(fun_ident,cs) = new_case_function (Yes case_ident) bool_type case_expr [(case_free_var,algebraic_type)] [] ci.ci_group_index cs
= (App {app_symb=fun_ident, app_args=[expr], app_info_ptr=nilPtr}, cs)
where
make_free_vars :: !Int !*VarHeap -> (![FreeVar],!*VarHeap)
make_free_vars n_args var_heap
| n_args>0
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
(free_vars,var_heap) = make_free_vars (n_args-1) var_heap
= ([{fv_ident = {id_name = "_x", id_info = nilPtr}, fv_info_ptr = new_info_ptr, fv_def_level = NotALevel, fv_count = 0} : free_vars], var_heap)
= ([],var_heap)
new_vars_in_algebraic_type {at_attribute,at_type=TV tv}
| no_attribute_var at_attribute
= {at_attribute=at_attribute, at_type=TV {tv & tv_info_ptr=nilPtr}}
= {at_attribute=new_vars_in_attribute_var at_attribute, at_type=TV {tv & tv_info_ptr=nilPtr}}
new_vars_in_algebraic_type {at_attribute,at_type=TA type_symbol type_args}
# type_args = new_vars_in_algebraic_type_args type_args
| no_attribute_var at_attribute
= {at_attribute=at_attribute, at_type=TA type_symbol type_args}
= {at_attribute=new_vars_in_attribute_var at_attribute, at_type=TA type_symbol type_args}
no_attribute_var TA_Unique = True
no_attribute_var TA_None = True
no_attribute_var TA_Multi = True
no_attribute_var TA_Anonymous = True
no_attribute_var TA_MultiOfPropagatingConsVar = True
no_attribute_var _ = False
new_vars_in_attribute_var (TA_Var attr_var)
= TA_Anonymous
new_vars_in_attribute_var (TA_RootVar attr_var)
= TA_Anonymous
new_vars_in_algebraic_type_args [type_arg:type_args]
= [new_vars_in_algebraic_type type_arg:new_vars_in_algebraic_type_args type_args]
new_vars_in_algebraic_type_args []
= []
convertCases ci (FailExpr ident) cs
# (failExpr, cs)
= convertNonRootFail ci ident cs
......@@ -1617,7 +1661,7 @@ convertNonRootFail ci=:{ci_group_index, ci_common_defs} ident cs
, at_type = TV {tv_ident = { id_name = "a", id_info = nilPtr }, tv_info_ptr = nilPtr}
}
# (fun_ident, cs)
= new_case_function (Yes ident) result_type (FailExpr ident) [] [] ci_group_index ci_common_defs cs
= new_case_function (Yes ident) result_type (FailExpr ident) [] [] ci_group_index cs
= (App { app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr }, cs)
convertNonRootCase ci=:{ci_bound_vars, ci_group_index, ci_common_defs} kees=:{ case_expr, case_ident, case_info_ptr} cs
......@@ -1700,12 +1744,14 @@ where
case_is_degenerate _
= (False, undef)
copy_case_expr :: [(FreeVar,AType)] Expression *VarHeap -> ([Expression],[(FreeVar,AType)],[FreeVar],Expression,[VarInfo],*VarHeap)
copy_case_expr bound_vars guards_and_default var_heap
# (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values bound_vars [] var_heap
(expr, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy guards_and_default { cp_free_vars = [], cp_var_heap = var_heap, cp_local_vars = [] }
(bound_vars, free_typed_vars, var_heap) = retrieve_variables cp_free_vars cp_var_heap
= (bound_vars, free_typed_vars, cp_local_vars, expr, old_fv_info_ptr_values,var_heap)
copy_case_expr_and_use_new_var :: [(FreeVar,AType)] BoundVar VarInfoPtr Expression *VarHeap -> (Bool,[Expression],[(FreeVar,AType)],[FreeVar],Expression,[VarInfo],*VarHeap)
copy_case_expr_and_use_new_var bound_vars {var_ident,var_info_ptr} new_info_ptr guards_and_default var_heap
# (old_fv_info_ptr_values,var_heap) = store_VI_BoundVar_in_bound_vars_and_save_old_values bound_vars [] var_heap
# (var_info, var_heap) = readPtr var_info_ptr var_heap
......@@ -1738,7 +1784,7 @@ where
new_case_function_and_restore_old_fv_info_ptr_values opt_id result_type rhs free_vars local_vars
bound_vars old_fv_info_ptr_values group_index common_defs cs
# (fun_ident,cs) = new_case_function opt_id result_type rhs free_vars local_vars group_index common_defs cs
# (fun_ident,cs) = new_case_function opt_id result_type rhs free_vars local_vars group_index cs
# cs_var_heap=restore_old_fv_info_ptr_values old_fv_info_ptr_values bound_vars cs.cs_var_heap
= (fun_ident,{ cs & cs_var_heap = cs_var_heap});
......@@ -1748,12 +1794,12 @@ restore_old_fv_info_ptr_values [old_fv_info_ptr_value:old_fv_info_ptr_values] [(
restore_old_fv_info_ptr_values [] bound_vars var_heap
= var_heap
new_case_function opt_id result_type rhs free_vars local_vars group_index common_defs cs=:{cs_expr_heap}
new_case_function opt_id result_type rhs free_vars local_vars group_index cs=:{cs_expr_heap}
# body = TransformedBody {tb_args=[var \\ (var, _) <- free_vars], tb_rhs=rhs}
(_,type)
= removeAnnotations
{ st_vars = []
, st_args = [ type \\ (_, type) <- free_vars]
, st_args = [type \\ (_, type) <- free_vars]
, st_args_strictness=NotStrict
, st_arity = length free_vars
, st_result = result_type
......@@ -1761,8 +1807,6 @@ new_case_function opt_id result_type rhs free_vars local_vars group_index common
, st_attr_vars = []
, st_attr_env = []
}
// (body, cs)
// = convertCasesInBody body (Yes type) group_index common_defs cs
# (fun_ident, (cs_next_fun_nr, cs_new_functions, cs_fun_heap))
= newFunctionWithType opt_id body local_vars type group_index
(cs.cs_next_fun_nr, cs.cs_new_functions, cs.cs_fun_heap)
......@@ -1832,9 +1876,6 @@ where
= (Conditional cond, cp_info)
copy expr=:(BasicExpr _) cp_info
= (expr, cp_info)
copy (MatchExpr constructor expr) cp_info
# (expr, cp_info) = copy expr cp_info
= (MatchExpr constructor expr, cp_info)
copy (Selection is_unique expr selectors) cp_info
# (expr, cp_info) = copy expr cp_info
(selectors, cp_info) = copy selectors cp_info
......@@ -1851,6 +1892,12 @@ where
copy (TupleSelect tuple_symbol arg_nr expr) cp_info
# (expr, cp_info) = copy expr cp_info
= (TupleSelect tuple_symbol arg_nr expr, cp_info)
copy (MatchExpr constructor expr) cp_info
# (expr, cp_info) = copy expr cp_info
= (MatchExpr constructor expr, cp_info)
copy (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) cp_info
# (expr, cp_info) = copy expr cp_info
= ((IsConstructor expr cons_symbol cons_arity global_type_index case_ident position), cp_info)
copy fail=:(FailExpr _) cp_info
= (fail, cp_info)
copy EE cp_info
......@@ -1962,7 +2009,6 @@ where
(-*->) infixl
(-*->) a b :== a // ---> b
//import RWSDebug
(->>) infixl
(->>) a b :== a // ---> b
(<<-) infixl
......
frontend/explicitimports.icl
View file @ 999a53ef
......@@ -661,20 +661,23 @@ instance check_completeness Expression where
= ccs
check_completeness (ABCCodeExpr _ _) _ ccs
= ccs
check_completeness (Update expr1 selections expr2) cci ccs
= ( (check_completeness expr1 cci)
o (check_completeness selections cci)
o (check_completeness expr2) cci
) ccs
check_completeness (MatchExpr {glob_module,glob_object={ds_ident,ds_index}} expression) cci ccs
= check_completeness expression cci
(check_whether_ident_is_imported ds_ident glob_module ds_index STE_Constructor cci ccs)
check_completeness (IsConstructor expr {glob_module,glob_object={ds_ident,ds_index}} _ _ _ _) cci ccs
= check_completeness expr cci
(check_whether_ident_is_imported ds_ident glob_module ds_index STE_Constructor cci ccs)
check_completeness (FreeVar _) _ ccs
= ccs
check_completeness (DynamicExpr dynamicExpr) cci ccs
= check_completeness dynamicExpr cci ccs
check_completeness EE _ ccs
= ccs
check_completeness (Update expr1 selections expr2) cci ccs
= ( (check_completeness expr1 cci)
o (check_completeness selections cci)
o (check_completeness expr2) cci
) ccs
check_completeness expr _ _
= abort "explicitimports:check_completeness (Expression) does not match" //<<- expr
......
frontend/generics1.icl
View file @ 999a53ef
......@@ -1272,7 +1272,7 @@ where
#! gencase = {gencase & gc_kind = kind}
#! type_index = index_OBJECT_CONS_FIELD_type gencase.gc_type gs.gs_predefs
| type_index>=0
| type_index>=0
# ({gc_body = GCB_FunIndex fun_index}) = gencase
gen_info_ptr = gen_def.gen_info_ptr
......@@ -3820,7 +3820,6 @@ where
curryGenericArgType :: !SymbolType !String !*TypeHeaps
-> (!SymbolType, !*TypeHeaps)
curryGenericArgType st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_var_name th=:{th_attrs}
#! (atype, attr_env, attr_vars, attr_store, th_attrs)
= buildCurriedType st_args st_result TA_Multi st_attr_env st_attr_vars attr_var_name 1 th_attrs
......@@ -4414,7 +4413,10 @@ foldExpr f expr=:(Conditional {if_cond,if_then,if_else}) st
# st = foldExpr f if_then st
# st = foldOptional (foldExpr f) if_else st
= st
foldExpr f expr=:(MatchExpr _ expr1) st
foldExpr f expr=:(MatchExpr _ expr1) st
# st = f expr st
= foldExpr f expr1 st
foldExpr f expr=:(IsConstructor expr1 _ _ _ _ _) st
# st = f expr st
= foldExpr f expr1 st
foldExpr f expr=:(DynamicExpr {dyn_expr}) st
......@@ -4543,7 +4545,7 @@ zipWith f _ _ = abort "zipWith: lists of different length\n"
zipWithSt f l1 l2 st
:== zipWithSt l1 l2 st
where
zipWithSt [] [] st
zipWithSt [] [] st
= ([], st)
zipWithSt [x:xs] [y:ys] st
# (z, st) = f x y st
......