diff options
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 40 | ||||
| -rw-r--r-- | frontend/classify.icl | 14 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 4 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 12 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 164 | ||||
| -rw-r--r-- | frontend/explicitimports.icl | 13 | ||||
| -rw-r--r-- | frontend/generics1.icl | 10 | ||||
| -rw-r--r-- | frontend/overloading.icl | 7 | ||||
| -rw-r--r-- | frontend/parse.icl | 343 | ||||
| -rw-r--r-- | frontend/partition.icl | 3 | ||||
| -rw-r--r-- | frontend/postparse.icl | 9 | ||||
| -rw-r--r-- | frontend/refmark.icl | 4 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 6 | ||||
| -rw-r--r-- | frontend/syntax.icl | 10 | ||||
| -rw-r--r-- | frontend/trans.icl | 14 | ||||
| -rw-r--r-- | frontend/transform.icl | 24 | ||||
| -rw-r--r-- | frontend/type.icl | 13 | ||||
| -rw-r--r-- | frontend/unitype.icl | 11 |
18 files changed, 556 insertions, 145 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 0a16d03..83fc6f2 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -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 diff --git a/frontend/classify.icl b/frontend/classify.icl index 0d04014..db6c189 100644 --- a/frontend/classify.icl +++ b/frontend/classify.icl @@ -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 diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index d91decb..3b82ebb 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -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) diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 9bfe503..801e1ac 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -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 diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 610407a..9b40ba0 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -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 diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl index 9f07158..d405ccd 100644 --- a/frontend/explicitimports.icl +++ b/frontend/explicitimports.icl @@ -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 diff --git a/frontend/generics1.icl b/frontend/generics1.icl index 5730220..9292e0a 100644 --- a/frontend/generics1.icl +++ b/frontend/generics1.icl @@ -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 diff --git a/frontend/overloading.icl b/frontend/overloading.icl index ed3e286..03419a1 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -1515,15 +1515,18 @@ where (EI_TypeOfDynamic type_code, ui_symbol_heap) = readPtr dyn_info_ptr ui.ui_symbol_heap ui = { ui & ui_symbol_heap = ui_symbol_heap } = (DynamicExpr { dyn & dyn_expr = dyn_expr, dyn_type_code = type_code }, ui) + updateExpression group_index (TupleSelect symbol argn_nr expr) ui + # (expr, ui) = updateExpression group_index expr ui + = (TupleSelect symbol argn_nr expr, ui) updateExpression group_index (MatchExpr cons_symbol=:{glob_object={ds_arity}} expr) ui | ds_arity <> -2 # (expr, ui) = updateExpression group_index expr ui = (MatchExpr cons_symbol expr, ui) // newtype constructor = updateExpression group_index expr ui - updateExpression group_index (TupleSelect symbol argn_nr expr) ui + updateExpression group_index (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ui # (expr, ui) = updateExpression group_index expr ui - = (TupleSelect symbol argn_nr expr, ui) + = (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ui) updateExpression group_index (TypeSignature _ expr) ui = updateExpression group_index expr ui updateExpression group_index expr=:(Var {var_info_ptr}) ui diff --git a/frontend/parse.icl b/frontend/parse.icl index b34ef74..721a66a 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -2734,6 +2734,15 @@ wantExpression pState _ -> wantExpressionT token pState +wantPatternWithoutDefinitions :: !ParseState -> (!ParsedExpr, !ParseState) +wantPatternWithoutDefinitions pState + # (token, pState) = nextToken FunctionContext pState + = case token of + CharListToken charList // To produce a better error message + -> charListError charList pState + _ + -> wantPatternWithoutDefinitionsT token pState + charListError charList pState = (PE_Empty, parseError "Expression" No ("List brackets, [ and ], around charlist '"+charList+"'") pState) @@ -2801,6 +2810,14 @@ where = (combineExpressions expr exprs, pState) = (PE_Empty, parseError "LHS expression" (Yes token) "<expression>" pState) +wantPatternWithoutDefinitionsT :: !Token !ParseState -> (!ParsedExpr, !ParseState) +wantPatternWithoutDefinitionsT token pState + # (succ, expr, pState) = trySimplePatternWithoutDefinitionsT token pState + | succ + # (exprs, pState) = parseList trySimplePatternWithoutDefinitions pState + = (combineExpressions expr exprs, pState) + = (PE_Empty, parseError "pattern" (Yes token) "<pattern>" pState) + combineExpressions expr [] = expr combineExpressions expr exprs @@ -2816,6 +2833,11 @@ trySimplePattern pState # (token, pState) = nextToken FunctionContext pState = trySimplePatternT token pState +trySimplePatternWithoutDefinitions :: !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimplePatternWithoutDefinitions pState + # (token, pState) = nextToken FunctionContext pState + = trySimplePatternWithoutDefinitionsT token pState + tryExtendedSimpleExpression :: !ParseState -> (!Bool, !ParsedExpr, !ParseState) tryExtendedSimpleExpression pState # (token, pState) = nextToken FunctionContext pState @@ -2832,30 +2854,75 @@ where extend_expr_with_selectors :: !ParsedExpr !ParseState -> (!ParsedExpr, !ParseState) extend_expr_with_selectors exp pState # (token, pState) = nextToken FunctionContext pState - | token == DotToken - # (token, pState) = nextToken FunctionContext pState - (selectors, pState) = wantSelectors token pState - = (PE_Selection ParsedNormalSelector exp selectors, pState) - | token == ExclamationToken - # (token, pState) = nextToken FunctionContext pState + = case token of + DotToken + # (token, pState) = nextToken FunctionContext pState + (selectors, token, pState) = wantSelectors token pState + exp = PE_Selection ParsedNormalSelector exp selectors + -> case token of + DefinesColonToken + -> parse_matches_expression exp pState + _ + -> (exp, tokenBack pState) + ExclamationToken + # (token, pState) = nextToken FunctionContext pState // JVG added for strict lists: - | token==SquareCloseToken - = (exp, tokenBack (tokenBack pState)) + | token==SquareCloseToken + -> (exp, tokenBack (tokenBack pState)) // - # (selectors, pState) = wantSelectors token pState - = (PE_Selection (ParsedUniqueSelector False) exp selectors, pState) - | otherwise - = (exp, tokenBack pState) + # (selectors, token, pState) = wantSelectors token pState + exp = PE_Selection (ParsedUniqueSelector False) exp selectors + -> case token of + DefinesColonToken + -> parse_matches_expression exp pState + _ + -> (exp, tokenBack pState) + DefinesColonToken + -> parse_matches_expression exp pState + _ + -> (exp, tokenBack pState) -wantSelectors :: Token *ParseState -> *(![ParsedSelection], !*ParseState) + parse_matches_expression exp pState + # (token, pState) = nextToken FunctionContext pState + = case token of + IdentToken name + | not (isLowerCaseName name) + # (id, pState) = stringToIdent name IC_Expression pState + (pattern_args,pState) = parse_wild_cards pState + pattern = if (isEmpty pattern_args) (PE_Ident id) (PE_List [PE_Ident id:pattern_args]) + -> matches_expression exp pattern pState + // to do: qualified ident + _ + # (succ, pattern, pState) = trySimplePatternWithoutDefinitionsT token pState + | succ + -> matches_expression exp pattern pState + # pState = parseError "pattern" (Yes token) "<pattern>" pState + -> matches_expression exp PE_Empty pState + + parse_wild_cards pState + # (token, pState) = nextToken FunctionContext pState + = case token of + WildCardToken + # (pattern_args,pState) = parse_wild_cards pState + -> ([PE_WildCard:pattern_args],pState) + _ + -> ([],tokenBack pState); + + matches_expression exp pattern pState + # (case_ident, pState) = internalIdent "_c" pState + (fname,linenr,pState) = getFileAndLineNr pState + position = LinePos fname linenr + = (PE_Matches case_ident exp pattern position, pState) + +wantSelectors :: Token *ParseState -> *(![ParsedSelection], !Token, !*ParseState) wantSelectors token pState # (selector, pState) = want_selector token pState (token, pState) = nextToken FunctionContext pState | token == DotToken # (token, pState) = nextToken FunctionContext pState - (selectors, pState) = wantSelectors token pState - = (selector ++ selectors, pState) - = (selector, tokenBack pState) + (selectors, token, pState) = wantSelectors token pState + = (selector ++ selectors, token, pState) + = (selector, token, pState) where want_selector :: !Token !*ParseState -> *(![ParsedSelection], !*ParseState) want_selector SquareOpenToken pState @@ -2960,6 +3027,57 @@ trySimplePatternT WildCardToken pState trySimplePatternT token pState = (False, PE_Empty, tokenBack pState) +trySimplePatternWithoutDefinitionsT :: !Token !ParseState -> (!Bool, !ParsedExpr, !ParseState) +trySimplePatternWithoutDefinitionsT (IdentToken name) pState + | not (isLowerCaseName name) + # (id, pState) = stringToIdent name IC_Expression pState + = (True, PE_Ident id, pState) +trySimplePatternWithoutDefinitionsT SquareOpenToken pState + # (list_expr, pState) = wantListPatternWithoutDefinitions pState + = (True, list_expr, pState) +trySimplePatternWithoutDefinitionsT OpenToken pState + # (args=:[exp:exps], pState) = want_pattern_list pState + pState = wantToken FunctionContext "pattern list" CloseToken pState + | isEmpty exps + = case exp of + PE_Ident id + -> (True, PE_List [exp], pState) + _ + -> (True, exp, pState) + = (True, PE_Tuple args, pState) +where + want_pattern_list pState + # (expr, pState) = wantPatternWithoutDefinitions pState + (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (exprs, pState) = want_pattern_list pState + = ([expr : exprs], pState) + = ([expr], tokenBack pState) +trySimplePatternWithoutDefinitionsT CurlyOpenToken pState + # (rec_or_aray_exp, pState) = wantRecordPatternWithoutDefinitions pState + = (True, rec_or_aray_exp, pState) +trySimplePatternWithoutDefinitionsT (IntToken int_string) pState + # (ok,int) = string_to_int int_string + | ok + = (True, PE_Basic (BVInt int), pState) + = (True, PE_Basic (BVI int_string), pState) +trySimplePatternWithoutDefinitionsT (StringToken string) pState + = (True, PE_Basic (BVS string), pState) +trySimplePatternWithoutDefinitionsT (BoolToken bool) pState + = (True, PE_Basic (BVB bool), pState) +trySimplePatternWithoutDefinitionsT (CharToken char) pState + = (True, PE_Basic (BVC char), pState) +trySimplePatternWithoutDefinitionsT (RealToken real) pState + = (True, PE_Basic (BVR real), pState) +trySimplePatternWithoutDefinitionsT (QualifiedIdentToken module_name ident_name) pState + | not (isLowerCaseName ident_name) + # (module_id, pState) = stringToQualifiedModuleIdent module_name ident_name IC_Expression pState + = (True, PE_QualifiedIdent module_id ident_name, pState) +trySimplePatternWithoutDefinitionsT WildCardToken pState + = (True, PE_WildCard, pState) +trySimplePatternWithoutDefinitionsT token pState + = (False, PE_Empty, tokenBack pState) + trySimpleExpressionT :: !Token !ParseState -> (!Bool, !ParsedExpr, !ParseState) trySimpleExpressionT (IdentToken name) pState # (id, pState) = stringToIdent name IC_Expression pState @@ -3081,27 +3199,109 @@ where trySimpleNonLhsExpressionT token pState = (False, PE_Empty, tokenBack pState) +wantListPatternWithoutDefinitions :: !ParseState -> (ParsedExpr, !ParseState) +wantListPatternWithoutDefinitions pState + # pState=appScanState setNoNewOffsideForSeqLetBit pState + # (token, pState) = nextToken FunctionContext pState + # pState=appScanState clearNoNewOffsideForSeqLetBit pState + # (head_strictness,token,pState) = want_head_strictness token pState + | token==ExclamationToken && (head_strictness<>HeadOverloaded && head_strictness<>HeadUnboxedAndTailStrict) + # (token, pState) = nextToken FunctionContext pState + | token==SquareCloseToken + = (makeTailStrictNilExpression head_strictness cIsAPattern,pState) + = (PE_Empty,parseError "list" (Yes token) (toString SquareCloseToken) pState) + | token==SquareCloseToken + | head_strictness==HeadUnboxedAndTailStrict + = (makeTailStrictNilExpression HeadUnboxed cIsAPattern,pState) + | head_strictness==HeadStrict + # (tail_strict,pState) = is_tail_strict_list_or_nil pState + | tail_strict + = (makeTailStrictNilExpression HeadLazy cIsAPattern,pState) + = (makeNilExpression head_strictness cIsAPattern,pState) + = (makeNilExpression head_strictness cIsAPattern,pState) + | head_strictness==HeadUnboxedAndTailStrict + = (PE_Empty,parseError "list" (Yes token) (toString SquareCloseToken) pState) + | head_strictness==HeadLazy && (case token of (IdentToken "!!") -> True; _ -> False) + # (next_token,pState) = nextToken FunctionContext pState + | next_token==SquareCloseToken + = (makeTailStrictNilExpression HeadStrict cIsAPattern,pState) + = want_LGraphExpr token [] head_strictness (tokenBack pState) + = want_LGraphExpr token [] head_strictness pState + where + want_LGraphExpr token acc head_strictness pState + = case token of + CharListToken chars + -> want_list (add_chars (fromString chars) acc) pState + _ # (exp, pState) = wantPatternWithoutDefinitionsT token pState + -> want_list [exp: acc] pState + where + want_list acc pState + # (token, pState) = nextToken FunctionContext pState + = case token of + SquareCloseToken + # nil_expr = makeNilExpression head_strictness cIsAPattern + -> (gen_pattern_cons_nodes acc nil_expr head_strictness,pState) + ExclamationToken + | head_strictness<>HeadOverloaded + # (token, pState) = nextToken FunctionContext pState + | token==SquareCloseToken + # nil_expr = makeTailStrictNilExpression head_strictness cIsAPattern + -> (gen_pattern_tail_strict_cons_nodes acc nil_expr head_strictness,pState) + -> (PE_Empty,parseError "list" (Yes token) (toString SquareCloseToken) pState) + CommaToken + # (token, pState) = nextToken FunctionContext pState + -> want_LGraphExpr token acc head_strictness pState + ColonToken + # (exp, pState) = wantPatternWithoutDefinitions pState + # (token,pState) = nextToken FunctionContext pState + | token==SquareCloseToken + -> (gen_pattern_cons_nodes acc exp head_strictness,pState) + | token==ExclamationToken && head_strictness<>HeadOverloaded + # pState = wantToken FunctionContext "list" SquareCloseToken pState + -> (gen_pattern_tail_strict_cons_nodes acc exp head_strictness,pState) + | token==ColonToken // to allow [1:2:[]] etc. + -> want_list [exp:acc] (tokenBack pState) + # pState = parseError "list" (Yes token) "] or :" pState + -> (gen_pattern_cons_nodes acc exp head_strictness,pState) + DotDotToken + -> (PE_Empty, parseError "want list expression" No "No dot dot expression in a pattern" pState) + DoubleBackSlashToken + -> (PE_Empty, parseError "want list expression" No "No \\\\ expression in a pattern" pState) + _ + # nil_expr = makeNilExpression head_strictness cIsAPattern + pState = parseError "list" (Yes token) "list element separator" pState + -> (gen_pattern_cons_nodes acc nil_expr head_strictness,pState) + +gen_pattern_cons_nodes [] exp head_strictness + = exp +gen_pattern_cons_nodes l exp head_strictness + = gen_pattern_cons_nodes l exp +where + cons_ident_exp = makeConsIdentExpression head_strictness cIsAPattern + + gen_pattern_cons_nodes [e:r] exp + = gen_pattern_cons_nodes r (PE_List [cons_ident_exp,e,exp]) + gen_pattern_cons_nodes [] exp + = exp + +gen_pattern_tail_strict_cons_nodes [] exp head_strictness + = exp +gen_pattern_tail_strict_cons_nodes r exp head_strictness + = gen_pattern_tail_strict_cons_nodes r exp +where + tail_strict_cons_ident_exp = makeTailStrictConsIdentExpression head_strictness cIsAPattern + + gen_pattern_tail_strict_cons_nodes [e:r] exp + = gen_pattern_tail_strict_cons_nodes r (PE_List [tail_strict_cons_ident_exp,e,exp]) + gen_pattern_tail_strict_cons_nodes [] exp + = exp + wantListExp :: !Bool !ParseState -> (ParsedExpr, !ParseState) wantListExp is_pattern pState # pState=appScanState setNoNewOffsideForSeqLetBit pState # (token, pState) = nextToken FunctionContext pState # pState=appScanState clearNoNewOffsideForSeqLetBit pState # (head_strictness,token,pState) = want_head_strictness token pState - with - want_head_strictness :: Token *ParseState -> *(!Int,!Token,!*ParseState) - want_head_strictness ExclamationToken pState - # (token,pState) = nextToken FunctionContext pState - = (HeadStrict,token,pState) - want_head_strictness (SeqLetToken strict) pState - # (token,pState) = nextToken FunctionContext pState - | strict - = (HeadUnboxedAndTailStrict,token,pState); - = (HeadUnboxed,token,pState) - want_head_strictness BarToken pState - # (token,pState) = nextToken FunctionContext pState - = (HeadOverloaded,token,pState) - want_head_strictness token pState - = (HeadLazy,token,pState) | token==ExclamationToken && (head_strictness<>HeadOverloaded && head_strictness<>HeadUnboxedAndTailStrict) # (token, pState) = nextToken FunctionContext pState | token==SquareCloseToken @@ -3129,13 +3329,6 @@ wantListExp is_pattern pState = case token of CharListToken chars -> want_list (add_chars (fromString chars) acc) pState - with - add_chars [] acc = acc - add_chars ['\\',c1,c2,c3:r] acc - | c1>='0' && c1<='7' - = add_chars r [PE_Basic (BVC (toString ['\'','\\',c1,c2,c3,'\''])): acc] - add_chars ['\\',c:r] acc = add_chars r [PE_Basic (BVC (toString ['\'','\\',c,'\''])): acc] - add_chars [c:r] acc = add_chars r [PE_Basic (BVC (toString ['\'',c,'\''])): acc] _ # (exp, pState) = (if is_pattern (wantPatternT token) (wantExpressionT token)) pState -> want_list [exp: acc] pState where @@ -3273,7 +3466,7 @@ wantListExp is_pattern pState = gen_cons_nodes r (PE_List [cons_ident_exp,e,exp]) gen_cons_nodes [] exp = exp - + gen_tail_strict_cons_nodes [] exp = exp gen_tail_strict_cons_nodes r exp @@ -3286,6 +3479,28 @@ wantListExp is_pattern pState gen_tail_strict_cons_nodes [] exp = exp +want_head_strictness :: Token *ParseState -> *(!Int,!Token,!*ParseState) +want_head_strictness ExclamationToken pState + # (token,pState) = nextToken FunctionContext pState + = (HeadStrict,token,pState) +want_head_strictness (SeqLetToken strict) pState + # (token,pState) = nextToken FunctionContext pState + | strict + = (HeadUnboxedAndTailStrict,token,pState); + = (HeadUnboxed,token,pState) +want_head_strictness BarToken pState + # (token,pState) = nextToken FunctionContext pState + = (HeadOverloaded,token,pState) +want_head_strictness token pState + = (HeadLazy,token,pState) + +add_chars [] acc = acc +add_chars ['\\',c1,c2,c3:r] acc + | c1>='0' && c1<='7' + = add_chars r [PE_Basic (BVC (toString ['\'','\\',c1,c2,c3,'\''])): acc] +add_chars ['\\',c:r] acc = add_chars r [PE_Basic (BVC (toString ['\'','\\',c,'\''])): acc] +add_chars [c:r] acc = add_chars r [PE_Basic (BVC (toString ['\'',c,'\''])): acc] + makeNilExpression :: Int Bool -> ParsedExpr makeNilExpression head_strictness is_pattern # pre_def_nil_index= if (head_strictness==HeadLazy) @@ -3644,8 +3859,7 @@ where want_update :: Token ParseState -> (NestedUpdate, ParseState) want_update token pState - # (selectors, pState) = wantSelectors token pState - (token, pState) = nextToken FunctionContext pState + # (selectors, token, pState) = wantSelectors token pState | token == EqualToken # (expr, pState) = wantExpression pState = ({nu_selectors = selectors, nu_update_expr = expr}, pState) @@ -3892,6 +4106,53 @@ where (token, pState) = nextToken FunctionContext pState = want_update type expr token pState +wantRecordPatternWithoutDefinitions :: !ParseState -> (ParsedExpr, !ParseState) +wantRecordPatternWithoutDefinitions pState + # (token, pState) = nextToken FunctionContext pState + | token == CurlyCloseToken + = (PE_Empty, parseError "record pattern" No "Array denotation not" pState) + = want_record_pattern_without_definitions token pState +where + want_record_pattern_without_definitions (IdentToken name) pState + | isUpperCaseName name + # pState = wantToken FunctionContext "record pattern" BarToken pState + (type_id, pState) = stringToIdent name IC_Type pState + (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments_without_definitions token pState + = (PE_Record PE_Empty (RecordNameIdent type_id) fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + want_record_pattern_without_definitions (QualifiedIdentToken module_name record_name) pState + | isUpperCaseName record_name + # pState = wantToken FunctionContext "record pattern" BarToken pState + (module_id, pState) = stringToQualifiedModuleIdent module_name record_name IC_Type pState + (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments_without_definitions token pState + = (PE_Record PE_Empty (RecordNameQualifiedIdent module_id record_name) fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + want_record_pattern_without_definitions token pState + # (fields, pState) = want_field_assignments_without_definitions token pState + = (PE_Record PE_Empty NoRecordName fields, wantToken FunctionContext "record pattern" CurlyCloseToken pState) + + want_field_assignments_without_definitions token=:(IdentToken field_name) pState + | isLowerCaseName field_name + # (field_id, pState) = stringToIdent field_name IC_Selector pState + = want_more_field_assignments_without_definitions (FieldName field_id) pState + want_field_assignments_without_definitions token=:(QualifiedIdentToken module_name field_name) pState + | isLowerCaseName field_name + # (module_id, pState) = stringToIdent module_name (IC_Module NoQualifiedIdents) pState + = want_more_field_assignments_without_definitions (QualifiedFieldName module_id field_name) pState + want_field_assignments_without_definitions token pState + = ([], parseError "record field assignments" (Yes token) "field name" pState) + + want_more_field_assignments_without_definitions field_name_or_qualified_field_name pState + # pState = wantToken FunctionContext "record pattern" EqualToken pState + # (field_expr, pState) = wantPattern pState + field = {bind_src = field_expr, bind_dst = field_name_or_qualified_field_name} + # (token, pState) = nextToken FunctionContext pState + | token == CommaToken + # (token, pState) = nextToken FunctionContext pState + (fields, pState) = want_field_assignments_without_definitions token pState + = ([field : fields], pState) + = ([field ], tokenBack pState) + want_update :: !OptionalRecordName !ParsedExpr !Token !ParseState -> (!ParsedExpr, !ParseState) want_update type expr token pState # (expr, pState) = want_update_without_curly_close type expr token pState diff --git a/frontend/partition.icl b/frontend/partition.icl index 25f2ef3..f10ccc3 100644 --- a/frontend/partition.icl +++ b/frontend/partition.icl @@ -207,7 +207,6 @@ where , pi_collect`` :: !.CollectState } -//:: Marks :== {# Int} :: Marks :== {# Mark} :: Mark = { m_fun :: !Int, m_mark :: !Int} @@ -426,6 +425,8 @@ where = fc_state find_calls fc_info (MatchExpr _ expr) fc_state = find_calls fc_info expr fc_state + find_calls fc_info (IsConstructor expr _ _ _ _ _) fc_state + = find_calls fc_info expr fc_state find_calls fc_info EE fc_state = fc_state find_calls fc_info (NoBind _) fc_state diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 1e38490..c384ca8 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -35,7 +35,7 @@ exprToExprWithLocalDefs expr , ewl_locals = LocalParsedDefs [] , ewl_position= NoPos } - + prefixAndPositionToIdent :: !String !LineAndColumn !*CollectAdmin -> (!Ident, !*CollectAdmin) prefixAndPositionToIdent prefix {lc_line, lc_column} ca=:{ca_hash_table} # ({boxed_ident=ident}, ca_hash_table) = putIdentInHashTable (prefix +++ ";" +++ toString lc_line +++ ";" +++ toString lc_column) IC_Expression ca_hash_table @@ -159,6 +159,9 @@ where = collectFunctions (transformSequence sequence) icl_module ca collectFunctions (PE_ArrayDenot array_kind exprs) icl_module ca = collectFunctions (transformArrayDenot array_kind exprs) icl_module ca + collectFunctions (PE_Matches case_ident expr pattern position) icl_module ca + # (expr, ca) = collectFunctions expr icl_module ca + = (PE_Matches case_ident expr pattern position, ca) collectFunctions (PE_Dynamic exprs opt_dyn_type) icl_module ca # (exprs, ca) = collectFunctions exprs icl_module ca = (PE_Dynamic exprs opt_dyn_type, ca) @@ -1099,13 +1102,13 @@ scanModule mod=:{mod_ident,mod_type,mod_defs = pdefs} cached_modules support_gen def_macro_indices = macro_range }} hash_table = set_hte_mark 0 ca_hash_table - + fun_defs = fun_defs++reverse ca_rev_fun_defs fun_range = {ir_from=0,ir_to=n_global_functions} = (reorganise_icl_ok && pea_ok && import_dcl_ok && import_dcls_ok, mod, fun_range, fun_defs, optional_dcl_mod, modules, dcl_module_n,hash_table, err_file, files) where - scan_main_dcl_module :: Ident ModuleKind (ModTimeFunction *Files) *Files *CollectAdmin -> (!Bool,!Optional (Module (CollectedDefinitions (ScannedInstanceAndMembersR FunDef))),!Int,![ScannedModule],![Ident],!*Files,!*CollectAdmin) + scan_main_dcl_module :: Ident ModuleKind (ModTimeFunction *Files) *Files *CollectAdmin -> (!Bool,!Optional ScannedModule,!Int,![ScannedModule],![Ident],!*Files,!*CollectAdmin) scan_main_dcl_module mod_ident MK_Main _ files ca = (True, No,NoIndex,[MakeEmptyModule mod_ident MK_NoMainDcl], cached_modules,files, ca) scan_main_dcl_module mod_ident MK_None _ files ca diff --git a/frontend/refmark.icl b/frontend/refmark.icl index ba4f0b4..0680d7c 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -341,6 +341,8 @@ where = refMark free_vars arg_nr No expr rms refMark free_vars sel _ (MatchExpr _ expr) rms = refMark free_vars sel No expr rms + refMark free_vars sel _ (IsConstructor expr _ _ _ _ _) rms + = refMark free_vars sel No expr rms refMark free_vars sel _ EE rms = rms refMark _ _ _ _ rms @@ -700,7 +702,6 @@ seqCombineRefCount (RC_Used sec_ref) (RC_Used prim_ref) make_primary_selections_non_unique [] = [] - emptyOccurrence type_info = { occ_ref_count = RC_Unused , occ_previous = [] @@ -729,7 +730,6 @@ where = make_shared_vars_non_unique variables fun_body coercion_env rms_var_heap expr_heap (setErrorAdmin position error) var_heap = empty_occurrences variables var_heap = (coercion_env, subst, type_def_infos, var_heap, expr_heap, error) - where clear_occurrences vars subst type_def_infos var_heap expr_heap = foldSt initial_occurrence vars (subst, type_def_infos, var_heap, expr_heap) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 6b15767..1c76796 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -252,8 +252,8 @@ cIsAFunction :== True cIsNotAFunction :== False :: ParsedDefinition - = PD_Function Position Ident Bool [ParsedExpr] Rhs FunKind - | PD_NodeDef Position ParsedExpr Rhs + = PD_Function Position Ident Bool [ParsedExpr] Rhs FunKind + | PD_NodeDef Position ParsedExpr Rhs | PD_Type ParsedTypeDef | PD_TypeSpec Position Ident Priority (Optional SymbolType) FunSpecials | PD_Class ClassDef [ParsedDefinition] @@ -1214,6 +1214,7 @@ instance toString KindInfo | PE_ArrayCompr !ArrayKind !ParsedExpr ![Qualifier] | PE_Sequ Sequence | PE_WildCard + | PE_Matches !Ident /*expr*/!ParsedExpr /*pattern*/!ParsedExpr !Position | PE_QualifiedIdent !Ident !String @@ -1302,6 +1303,7 @@ cIsNotStrict :== False | ABCCodeExpr ![String] !Bool | MatchExpr !(Global DefinedSymbol) !Expression + | IsConstructor !Expression !(Global DefinedSymbol) /*arity*/!Int !GlobalIndex !Ident !Position | FreeVar FreeVar | Constant !SymbIdent !Int !Priority /* auxiliary clause used during checking */ | ClassVariable !VarInfoPtr /* auxiliary clause used during overloading */ diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 2df6046..1f7c5c6 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -385,7 +385,9 @@ where (<<<) file (Update expr1 selections expr2) = file <<< '{' <<< expr1 <<< " & " <<< selections <<< " = " <<< expr2 <<< '}' (<<<) file (RecordUpdate cons_symbol expression expressions) = file <<< '{' <<< cons_symbol <<< ' ' <<< expression <<< " & " <<< expressions <<< '}' (<<<) file (TupleSelect field field_nr expr) = file <<< expr <<<'.' <<< field_nr - (<<<) file (MatchExpr cons expr) = file <<< cons <<< " =: " <<< expr + (<<<) file (MatchExpr cons expr) = file <<< cons <<< " (M)=: " <<< expr + (<<<) file (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) + = file <<< expr <<< " (I)=: " <<< cons_symbol (<<<) file EE = file <<< "** E **" (<<<) file (NoBind _) = file <<< "** NB **" (<<<) file (DynamicExpr {dyn_expr,dyn_type_code}) = file <<< "dynamic " <<< dyn_expr <<< " :: " <<< dyn_type_code @@ -868,12 +870,14 @@ where = file <<< "argument " <<< (elem_nr + 1) <<< " of " <<< ds_arity <<< "-tuple" show_expression file (BasicExpr bv) = file <<< bv + show_expression file (RecordUpdate _ _ _) + = file <<< "update of record" show_expression file (MatchExpr _ expr) = file <<< "match expression" + show_expression file (IsConstructor _ _ _ _ _ _) + = file <<< "is constructor expression" show_expression file (Let _) = file <<< "(let ... ) or #" - show_expression file (RecordUpdate _ _ _) - = file <<< "update of record" show_expression file _ = file diff --git a/frontend/trans.icl b/frontend/trans.icl index 6370bff..771c516 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -283,6 +283,9 @@ where transform (MatchExpr a1 expr) ro ti # (expr,ti) = transform expr ro ti = (MatchExpr a1 expr,ti) + transform (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ro ti + # (expr,ti) = transform expr ro ti + = (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ti) transform (DynamicExpr dynamic_expr) ro ti # (dynamic_expr, ti) = transform dynamic_expr ro ti = (DynamicExpr dynamic_expr, ti) @@ -1240,7 +1243,6 @@ where = index1 =< index2 compare_constructor_arguments (PR_Class app1 lifted_vars_with_types1 t1) (PR_Class app2 lifted_vars_with_types2 t2) -// = app1.app_args =< app2.app_args # cmp = smallerOrEqual t1 t2 | cmp<>Equal = cmp @@ -1869,7 +1871,6 @@ get_producer_type {symb_kind=SK_Constructor {glob_module, glob_object}} ro fun_d # (_,cons_type) = removeAnnotations cons_type // necessary??? = (cons_type, fun_defs, fun_heap) -//@ determine_args determine_args :: ![Bool] ![ConsClass] !Index !{!Producer} ![Optional SymbolType] ![FreeVar] !ReadOnlyTI !*DetermineArgsState -> *DetermineArgsState @@ -3819,6 +3820,8 @@ where VI_AccVar _ _ -> writeVarInfo var_info_ptr VI_Empty var_heap VI_ExpressionOrBody _ _ _ _ -> writeVarInfo var_info_ptr VI_Empty var_heap + VI_Body _ _ _ + -> writeVarInfo var_info_ptr VI_Empty var_heap instance clearVariables Expression where @@ -3848,6 +3851,8 @@ where = clearVariables expr fvi clearVariables (MatchExpr _ expr) fvi = clearVariables expr fvi + clearVariables (IsConstructor expr _ _ _ _ _) fvi + = clearVariables expr fvi clearVariables EE fvi = fvi clearVariables _ fvi @@ -3987,6 +3992,8 @@ where = freeVariables expr fvi freeVariables (MatchExpr _ expr) fvi = freeVariables expr fvi + freeVariables (IsConstructor expr _ _ _ _ _) fvi + = freeVariables expr fvi freeVariables EE fvi = fvi freeVariables _ fvi @@ -4325,6 +4332,9 @@ where copy (MatchExpr cons_ident expr) ci cs # (expr, cs) = copy expr ci cs = (MatchExpr cons_ident expr, cs) + copy (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ci cs + # (expr, cs) = copy expr ci cs + = (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, cs) copy (DynamicExpr expr) ci cs # (expr, cs) = copy expr ci cs = (DynamicExpr expr, cs) diff --git a/frontend/transform.icl b/frontend/transform.icl index 53e1a3f..c076ecc 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -86,6 +86,9 @@ where lift (DynamicExpr expr) ls # (expr, ls) = lift expr ls = (DynamicExpr expr, ls) + lift (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ls + # (expr, ls) = lift expr ls + = (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ls) lift (TypeSignature type_function expr) ls # (expr, ls) = lift expr ls = (TypeSignature type_function expr, ls) @@ -402,6 +405,9 @@ where unfold (MatchExpr cons_ident expr) us # (expr, us) = unfold expr us = (MatchExpr cons_ident expr, us) + unfold (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) us + # (expr, us) = unfold expr us + = (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, us) unfold (DynamicExpr expr) us # (expr, us) = unfold expr us = (DynamicExpr expr, us) @@ -541,7 +547,7 @@ where instance unfold Case where - unfold kees=:{ case_expr,case_guards,case_default,case_info_ptr} us + unfold kees=:{case_expr,case_guards,case_default,case_info_ptr} us # (old_case_info, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap new_case_info = old_case_info (new_info_ptr, us_symbol_heap) = newPtr new_case_info us_symbol_heap @@ -1140,6 +1146,8 @@ where = has_no_curried_macro_Expression expr has_no_curried_macro_Expression (MatchExpr cons_ident expr) = has_no_curried_macro_Expression expr + has_no_curried_macro_Expression (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) + = has_no_curried_macro_Expression expr has_no_curried_macro_Expression (TypeSignature _ expr) = has_no_curried_macro_Expression expr has_no_curried_macro_Expression expr @@ -1513,6 +1521,9 @@ where expand (MatchExpr cons_ident expr) ei # (expr, ei) = expand expr ei = (MatchExpr cons_ident expr, ei) + expand (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ei + # (expr, ei) = expand expr ei + = (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ei) expand (DynamicExpr dyn) ei # (dyn, ei) = expand dyn ei = (DynamicExpr dyn, ei) @@ -1664,7 +1675,8 @@ where determineVariablesAndRefCounts :: ![FreeVar] !Expression !*CollectState -> (!Expression , ![FreeVar], ![FreeVar], ![DynamicPtr], !*CollectState) determineVariablesAndRefCounts free_vars expr cos=:{cos_var_heap} - # (expr, local_vars, dynamics, cos) = collectVariables expr [] [] { cos & cos_var_heap = clearCount free_vars cIsAGlobalVar cos_var_heap } + # cos = {cos & cos_var_heap = clearCount free_vars cIsAGlobalVar cos_var_heap} + (expr, local_vars, dynamics, cos) = collectVariables expr [] [] cos (free_vars, cos_var_heap) = retrieveRefCounts free_vars cos.cos_var_heap (local_vars, cos_var_heap) = retrieveRefCounts local_vars cos_var_heap = (expr, free_vars, local_vars, dynamics, { cos & cos_var_heap = cos_var_heap }) @@ -1986,9 +1998,12 @@ where collectVariables (MatchExpr cons_ident expr) free_vars dynamics cos # (expr, free_vars, dynamics, cos) = collectVariables expr free_vars dynamics cos = (MatchExpr cons_ident expr, free_vars, dynamics, cos) + collectVariables (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) free_vars dynamics cos + # (expr, free_vars, dynamics, cos) = collectVariables expr free_vars dynamics cos + = (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, free_vars, dynamics, cos) collectVariables (DynamicExpr dynamic_expr) free_vars dynamics cos # (dynamic_expr, free_vars, dynamics, cos) = collectVariables dynamic_expr free_vars dynamics cos - = (DynamicExpr dynamic_expr, free_vars, dynamics, cos); + = (DynamicExpr dynamic_expr, free_vars, dynamics, cos) collectVariables (TypeSignature type_function expr) free_vars dynamics cos # (expr, free_vars, dynamics, cos) = collectVariables expr free_vars dynamics cos = (TypeSignature type_function expr, free_vars, dynamics, cos); @@ -2066,7 +2081,8 @@ where instance collectVariables AlgebraicPattern where collectVariables pattern=:{ap_vars,ap_expr} free_vars dynamics cos - # (ap_expr, free_vars, dynamics, cos) = collectVariables ap_expr free_vars dynamics { cos & cos_var_heap = clearCount ap_vars cIsALocalVar cos.cos_var_heap} + # cos = {cos & cos_var_heap = clearCount ap_vars cIsALocalVar cos.cos_var_heap} + (ap_expr, free_vars, dynamics, cos) = collectVariables ap_expr free_vars dynamics cos (ap_vars, cos_var_heap) = retrieveRefCounts ap_vars cos.cos_var_heap = ({ pattern & ap_expr = ap_expr, ap_vars = ap_vars }, free_vars, dynamics, { cos & cos_var_heap = cos_var_heap }) diff --git a/frontend/type.icl b/frontend/type.icl index d7462f1..eab10c7 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1834,6 +1834,18 @@ where = ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique }, No, (reqs, ts)) = ( hd tst_args, No, (reqs, ts)) + requirements ti (IsConstructor expr {glob_object={ds_arity,ds_index,ds_ident},glob_module} _ _ _ _) (reqs,ts) + # cp = CP_Expression expr + ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ti ts + (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs,ts) + reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, + req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] } + ts_attr_store = ts.ts_attr_store + bool_type = { at_attribute = TA_TempVar ts_attr_store, at_type = basicBoolType.box} + ts & ts_attr_store = inc ts_attr_store, + ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap + = (bool_type, No, (reqs, ts)) + requirements _ (AnyCodeExpr _ _ _) (reqs, ts) # (fresh_v, ts) = freshAttributedVariable ts = (fresh_v, No, (reqs, ts)) @@ -2268,7 +2280,6 @@ typeProgram :: !{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !Commo -> (!Bool, !*{# FunDef}, !ArrayAndListInstances, !{# CommonDefs}, !{# {# FunType} }, !*TypeDefInfos,!*Heaps,!*PredefinedSymbols,!*File,!*File) typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports icl_qualified_imports dcl_modules used_module_numbers td_infos heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps,hp_generic_heap} predef_symbols file out - #! fun_env_size = size fun_defs # ts_error = {ea_file = file, ea_loc = [], ea_ok = True } diff --git a/frontend/unitype.icl b/frontend/unitype.icl index db6d77d..0de10bf 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -671,7 +671,6 @@ newInequality off_attr dem_attr coercions=:{coer_demanded, coer_offered} = {coer_demanded = coer_demanded, coer_offered = coer_offered} = {coer_demanded = coer_demanded, coer_offered = coer_offered} where - insert :: !Int !*CoercionTree -> (!Bool, !*CoercionTree) insert new_attr CT_Empty = (True, CT_Node new_attr CT_Empty CT_Empty) @@ -730,9 +729,7 @@ makeNonUnique attr {coer_demanded, coer_offered} # (dem_coercions, coer_demanded) = replace coer_demanded attr CT_Empty coer_offered = { coer_offered & [attr] = CT_NonUnique } = make_non_unique dem_coercions {coer_offered = coer_offered, coer_demanded = coer_demanded} -// ---> ("makeNonUnique", attr) where - // JVG added type: make_non_unique :: !CoercionTree !*Coercions -> *Coercions; make_non_unique (CT_Node this_attr ct_less ct_greater) coercions # coercions = makeNonUnique this_attr coercions @@ -930,7 +927,7 @@ coerceTypes sign defs cons_vars tpos _ _ cs coercions_of_arg_types sign defs cons_vars tpos [t1 : ts1] [t2 : ts2] sign_class arg_number cs # arg_sign = sign * signClassToSign sign_class arg_number (succ, cs) = coerce arg_sign defs cons_vars [arg_number : tpos] t1 t2 cs - | Success succ + | Success succ = coercions_of_arg_types sign defs cons_vars tpos ts1 ts2 sign_class (inc arg_number) cs = (succ, cs) coercions_of_arg_types sign defs cons_vars tpos [] [] _ _ cs @@ -1038,8 +1035,6 @@ where = find_var_position_in_expression expr find_var_position_in_expression (TupleSelect _ _ expr) = find_var_position_in_expression expr - find_var_position_in_expression (MatchExpr _ expr) - = find_var_position_in_expression expr find_var_position_in_expression (Update expr1 selections expr2) # (found,pos) = find_var_position_in_expression expr1 | found @@ -1061,6 +1056,10 @@ where = find_var_position_in_updated_fields updated_fields find_var_position_in_updated_fields [] = (False,NoPos) + find_var_position_in_expression (MatchExpr _ expr) + = find_var_position_in_expression expr + find_var_position_in_expression (IsConstructor expr _ _ _ _ _) + = find_var_position_in_expression expr find_var_position_in_expression (Let {let_strict_binds,let_lazy_binds,let_expr}) # (found,pos) = find_var_position_in_let_binds let_strict_binds | found |