diff options
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 38 | ||||
| -rw-r--r-- | frontend/parse.icl | 23 | ||||
| -rw-r--r-- | frontend/postparse.icl | 12 | ||||
| -rw-r--r-- | frontend/refmark.icl | 74 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 1 | ||||
| -rw-r--r-- | frontend/unitype.dcl | 2 | ||||
| -rw-r--r-- | frontend/unitype.icl | 173 |
7 files changed, 240 insertions, 83 deletions
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 3c8a856..8da8574 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -636,7 +636,7 @@ where = check_guarded_expressions free_vars gs pattern_variables case_name e_input e_state e_info cs = check_guarded_expression free_vars g gs pattern_scheme pattern_variables defaul case_name e_input e_state e_info cs - check_guarded_expression free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals}} patterns pattern_scheme pattern_variables defaul case_name + check_guarded_expression free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals},calt_position} patterns pattern_scheme pattern_variables defaul case_name e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_fun_defs,es_var_heap,es_dynamics=outer_dynamics} e_info cs # (pattern, (var_env, array_patterns), {ps_fun_defs,ps_var_heap}, e_info, cs) = checkPattern calt_pattern No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], []) @@ -648,20 +648,20 @@ where = addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs cs_symbol_table = removeLocalIdentsFromSymbolTable ei_expr_level var_env cs.cs_symbol_table (guarded_expr, pattern_scheme, pattern_variables, defaul, es_var_heap, es_expr_heap, dynamics_in_patterns, cs) - = transform_pattern pattern patterns pattern_scheme pattern_variables defaul expr_with_array_selections case_name + = transform_pattern pattern patterns pattern_scheme pattern_variables defaul expr_with_array_selections case_name calt_position es_var_heap es_expr_heap dynamics_in_rhs { cs & cs_symbol_table = cs_symbol_table } = (guarded_expr, pattern_scheme, pattern_variables, defaul, free_vars, { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ outer_dynamics }, e_info, cs) transform_pattern :: !AuxiliaryPattern !CasePatterns !CasePatterns !(Env Ident VarInfoPtr) !(Optional (!Optional FreeVar, !Expression)) !Expression - !String !*VarHeap !*ExpressionHeap !Dynamics !*CheckState + !String !Position !*VarHeap !*ExpressionHeap !Dynamics !*CheckState -> (!CasePatterns, !CasePatterns, !Env Ident VarInfoPtr, !Optional (!Optional FreeVar,!Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState) - transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs - # (var_args, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr NoPos var_store expr_heap opt_dynamics cs + transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs + # (var_args, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr pos var_store expr_heap opt_dynamics cs type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index} pattern_variables = cons_optional opt_var pattern_variables - # pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = NoPos} + # pattern = { ap_symbol = cons_symbol, ap_vars = var_args, ap_expr = result_expr, ap_position = pos} | 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 @@ -811,8 +811,8 @@ where = ({pattern & ap_symbol.glob_object=glob_object},cs) = abort "replace_overloaded_symbol_in_pattern" - transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs - # pattern = { bp_value = basic_val, bp_expr = result_expr, bp_position = NoPos} + transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs + # pattern = { bp_value = basic_val, bp_expr = result_expr, bp_position = pos} pattern_variables = cons_optional opt_var pattern_variables (type_symbol, cs) = typeOfBasicValue basic_val cs = case pattern_scheme of @@ -831,11 +831,11 @@ where _ -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError basic_val "illegal combination of patterns" cs.cs_error}) - transform_pattern (AP_Dynamic pattern type opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs - # (var_arg, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr NoPos var_store expr_heap opt_dynamics cs + transform_pattern (AP_Dynamic pattern type opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs + # (var_arg, result_expr, _, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr pos var_store expr_heap opt_dynamics cs (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap pattern = { dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, - dp_type_code = TCE_Empty, dp_position = NoPos } + dp_type_code = TCE_Empty, dp_position = pos } pattern_variables = cons_optional opt_var pattern_variables = case pattern_scheme of DynamicPatterns _ @@ -850,11 +850,11 @@ where _ -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError "<dynamic pattern>" "illegal combination of patterns" cs.cs_error }) - transform_pattern (AP_Variable name var_info opt_var) NoPattern pattern_scheme pattern_variables No result_expr _ var_store expr_heap opt_dynamics cs + transform_pattern (AP_Variable name var_info opt_var) NoPattern pattern_scheme pattern_variables No result_expr _ pos var_store expr_heap opt_dynamics cs = ( NoPattern, pattern_scheme, cons_optional opt_var pattern_variables, Yes (Yes { fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr), var_store, expr_heap, opt_dynamics, cs) - transform_pattern (AP_Variable name var_info opt_var) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs + transform_pattern (AP_Variable name var_info opt_var) patterns pattern_scheme pattern_variables defaul result_expr case_name pos var_store expr_heap opt_dynamics cs # free_var = { fv_ident = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 } (new_bound_var, expr_heap) = allocate_bound_var free_var expr_heap case_ident = { id_name = case_name, id_info = nilPtr } @@ -863,16 +863,16 @@ where new_defaul = insert_as_default new_case result_expr = (NoPattern, pattern_scheme, (cons_optional opt_var pattern_variables), Yes (Yes free_var, new_defaul), var_store, expr_heap, opt_dynamics, cs) - transform_pattern (AP_WildCard (Yes opt_var)) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs + transform_pattern (AP_WildCard (Yes opt_var)) patterns pattern_scheme pattern_variables defaul result_expr case_name pos var_store expr_heap opt_dynamics cs = transform_pattern (AP_Variable opt_var.bind_src opt_var.bind_dst No) patterns pattern_scheme pattern_variables defaul - result_expr case_name var_store expr_heap opt_dynamics cs - transform_pattern (AP_WildCard no) NoPattern pattern_scheme pattern_variables No result_expr _ var_store expr_heap opt_dynamics cs + result_expr case_name pos var_store expr_heap opt_dynamics cs + transform_pattern (AP_WildCard no) NoPattern pattern_scheme pattern_variables No result_expr _ pos var_store expr_heap opt_dynamics cs = (NoPattern, pattern_scheme, pattern_variables, Yes (No, result_expr), var_store, expr_heap, opt_dynamics, cs) - transform_pattern (AP_WildCard _) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs + transform_pattern (AP_WildCard _) patterns pattern_scheme pattern_variables defaul result_expr case_name pos var_store expr_heap opt_dynamics cs # (new_info_ptr, var_store) = newPtr VI_Empty var_store = transform_pattern (AP_Variable (newVarId "wc") new_info_ptr No) patterns pattern_scheme pattern_variables defaul - result_expr case_name var_store expr_heap opt_dynamics cs - transform_pattern (AP_Empty name) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs + result_expr case_name pos var_store expr_heap opt_dynamics cs + transform_pattern (AP_Empty name) patterns pattern_scheme pattern_variables defaul result_expr _ pos var_store expr_heap opt_dynamics cs = (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) diff --git a/frontend/parse.icl b/frontend/parse.icl index 14a80ab..29d3bec 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -3210,10 +3210,12 @@ wantCaseExp pState where tryCaseAlt :: (!RhsDefiningSymbol, !ParseState) -> (!Bool, CaseAlt, (!RhsDefiningSymbol, !ParseState)) tryCaseAlt (definingSymbol, pState) - # (succ, pattern, pState) = try_pattern pState + # (token, pState) = nextToken FunctionContext pState + # (fname,linenr,pState) = getFileAndLineNr pState + # (succ, pattern, pState) = try_pattern token pState | succ # (rhs, definingSymbol, pState) = wantRhs True definingSymbol pState - = (True, { calt_pattern = pattern, calt_rhs = rhs }, (definingSymbol, pState)) + = (True, { calt_pattern = pattern, calt_rhs = rhs, calt_position=LinePos fname linenr }, (definingSymbol, pState)) // otherwise // ~ succ = (False, abort "no case alt", (definingSymbol, pState)) @@ -3221,16 +3223,17 @@ where tryLastCaseAlt definingSymbol pState # (token, pState) = nextToken FunctionContext pState | isDefiningSymbol definingSymbol token - # pState = tokenBack pState - (rhs, _, pState) - = wantRhs True definingSymbol pState - = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) + # (fname,linenr,pState) = getFileAndLineNr pState + pState = tokenBack pState + (rhs, _, pState) = wantRhs True definingSymbol pState + = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs, calt_position=LinePos fname linenr }, pState) | token == OtherwiseToken # (token, pState) = nextToken FunctionContext pState + (fname,linenr,pState) = getFileAndLineNr pState pState = tokenBack pState | isDefiningSymbol definingSymbol token # (rhs, _, pState) = wantRhs True definingSymbol pState - = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) + = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs, calt_position=LinePos fname linenr }, pState) = (False, abort "no case alt", pState) = (False, abort "no case alt", tokenBack pState) @@ -3238,9 +3241,9 @@ where // FIXME: it would be better if this would use (tryExpression cIsNotPattern) // but there's no function tryExpression available yet - try_pattern :: !ParseState -> (!Bool, ParsedExpr, !ParseState) - try_pattern pState - # (succ, expr, pState) = trySimpleLhsExpression pState + try_pattern :: !Token !ParseState -> (!Bool, ParsedExpr, !ParseState) + try_pattern token pState + # (succ, expr, pState) = trySimpleLhsExpressionT token pState | succ # (succ, expr2, pState) = trySimpleLhsExpression pState | succ diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 228cba4..4cd3239 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -146,8 +146,8 @@ where # true_pattern = PE_Basic (BVB True) false_pattern = PE_WildCard // PE_Basic (BVB False) = collectFunctions (PE_Case if_ident c - [ {calt_pattern = true_pattern , calt_rhs = exprToRhs t} - , {calt_pattern = false_pattern, calt_rhs = exprToRhs e} + [ {calt_pattern = true_pattern , calt_rhs = exprToRhs t, calt_position=NoPos} + , {calt_pattern = false_pattern, calt_rhs = exprToRhs e, calt_position=NoPos} ]) icl_module ca collectFunctions (PE_Let strict locals in_expr) icl_module ca # ((node_defs,in_expr), ca) = collectFunctions (locals,in_expr) icl_module ca @@ -686,8 +686,8 @@ where # smaller_fun = get_predef_id PD_SmallerFun # (case_ident,ca) = prefixAndPositionToIdent ("g_s"+++toString n) gen_position ca = (PE_Case case_ident (PE_List [ident1,PE_Ident smaller_fun,ident2]) - [{calt_pattern = PE_Basic (BVB True), calt_rhs = exprToRhs ident1}, - {calt_pattern = PE_WildCard, calt_rhs = exprToRhs ident2}],ca) + [{calt_pattern = PE_Basic (BVB True), calt_rhs = exprToRhs ident1, calt_position=NoPos}, + {calt_pattern = PE_WildCard, calt_rhs = exprToRhs ident2, calt_position=NoPos}],ca) = (node_defs,to_exp,ident1,ca) store_minimum_of_sizes_in_generator :: [ParsedDefinition] ParsedExpr Int TransformedGenerator -> TransformedGenerator; @@ -948,8 +948,8 @@ makeComprehensions [{tq_generators,tq_let_defs,tq_filter, tq_end, tq_call, tq_lh = rhs case_with_default case_ident expr expr_is_uselect pattern rhs default_rhs = exprToRhs (PE_Case case_ident expr - [ {calt_pattern = pattern, calt_rhs = rhs} - , {calt_pattern = PE_WildCard, calt_rhs = exprToRhs default_rhs} + [ {calt_pattern = pattern, calt_rhs = rhs, calt_position=NoPos} + , {calt_pattern = PE_WildCard, calt_rhs = exprToRhs default_rhs, calt_position=NoPos} ]) /* +++ remove code duplication (bug in 2.0 with nested cases) diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 698e143..4bfefb5 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -669,7 +669,7 @@ emptyOccurrence type_info = /* emptyObservingOccurrence =: VI_Occurrence (emptyOccurrence True) emptyNonObservingOccurrence =: VI_Occurrence (emptyOccurrence False) -*/ +*/ makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !v:TypeDefInfos !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !v:TypeDefInfos, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) makeSharedReferencesNonUnique [] fun_defs coercion_env subst type_def_infos var_heap expr_heap error @@ -680,13 +680,13 @@ makeSharedReferencesNonUnique [fun : funs] fun_defs coercion_env subst type_def_ = make_shared_references_of_function_non_unique fun_def coercion_env subst type_def_infos var_heap expr_heap error = makeSharedReferencesNonUnique funs fun_defs coercion_env subst type_def_infos var_heap expr_heap error where - make_shared_references_of_function_non_unique {fun_ident, fun_pos, fun_body = TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}} + make_shared_references_of_function_non_unique {fun_ident, fun_pos, fun_body = fun_body =: TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}} coercion_env subst type_def_infos var_heap expr_heap error # variables = tb_args ++ fi_local_vars (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap (_, {rms_var_heap}) = fullRefMark [tb_args] NotASelector No /* tb_rhs var_heap */ (tb_rhs ===> ("makeSharedReferencesNonUnique", fun_ident, tb_rhs)) var_heap position = newPosition fun_ident fun_pos - (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env rms_var_heap expr_heap + (coercion_env, var_heap, expr_heap, error) = 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) @@ -724,46 +724,40 @@ where get_type _ = abort "has_observing_base_type (refmark.icl)" - make_shared_vars_non_unique vars coercion_env var_heap expr_heap error + make_shared_vars_non_unique vars fun_body coercion_env var_heap expr_heap error = foldl make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) vars - - make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) fv=:{fv_ident,fv_info_ptr} - # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap - = case occ.occ_ref_count of - RC_Used {rcu_multiply,rcu_selectively} - # (coercion_env, expr_heap, error) = make_shared_occurrences_non_unique fv rcu_multiply (coercion_env, expr_heap, error) - (coercion_env, expr_heap, error) = foldSt (make_selection_non_unique fv) rcu_selectively (coercion_env, expr_heap, error) - -> (coercion_env, var_heap, expr_heap, error) - _ - -> (coercion_env, var_heap, expr_heap, error) -// ===> ("make_shared_var_non_unique", fv_ident) - - make_shared_occurrences_non_unique fv multiply (coercion_env, expr_heap, error) - = foldSt (make_shared_occurrence_non_unique fv) multiply (coercion_env, expr_heap, error) - - make_shared_occurrence_non_unique free_var var_expr_ptr (coercion_env, expr_heap, error) - | isNilPtr var_expr_ptr - = (coercion_env, expr_heap, error) - # (expr_info, expr_heap) = readPtr var_expr_ptr expr_heap - = case expr_info of - EI_Attribute sa_attr_nr - # (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env - | succ - ===> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr, sa_attr_nr) - -> (coercion_env, expr_heap, error) - -> (coercion_env, expr_heap, uniquenessError (CP_Expression (FreeVar free_var)) " demanded attribute cannot be offered by shared object" error) + where + make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) fv=:{fv_ident,fv_info_ptr} + # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap + = case occ.occ_ref_count of + RC_Used {rcu_multiply,rcu_selectively} + # (coercion_env, expr_heap, error) = make_shared_occurrences_non_unique fv rcu_multiply (coercion_env, expr_heap, error) + (coercion_env, expr_heap, error) = foldSt (make_selection_non_unique fv) rcu_selectively (coercion_env, expr_heap, error) + -> (coercion_env, var_heap, expr_heap, error) _ - -> abort ("make_shared_occurrence_non_unique" ===> ((free_var, var_expr_ptr) )) // <<- expr_info)) - - make_selection_non_unique fv {su_multiply} cee - = make_shared_occurrences_non_unique fv su_multiply cee + -> (coercion_env, var_heap, expr_heap, error) + // ===> ("make_shared_var_non_unique", fv_ident) + + make_shared_occurrences_non_unique fv multiply (coercion_env, expr_heap, error) + = foldSt (make_shared_occurrence_non_unique fv) multiply (coercion_env, expr_heap, error) + + make_shared_occurrence_non_unique free_var var_expr_ptr (coercion_env, expr_heap, error) + | isNilPtr var_expr_ptr + = (coercion_env, expr_heap, error) + # (expr_info, expr_heap) = readPtr var_expr_ptr expr_heap + = case expr_info of + EI_Attribute sa_attr_nr + # (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env + | succ + ===> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr, sa_attr_nr) + -> (coercion_env, expr_heap, error) + -> (coercion_env, expr_heap, uniquenessErrorVar free_var fun_body " demanded attribute cannot be offered by shared object" error) + _ + -> abort ("make_shared_occurrence_non_unique" ===> ((free_var, var_expr_ptr) )) // <<- expr_info)) + + make_selection_non_unique fv {su_multiply} cee + = make_shared_occurrences_non_unique fv su_multiply cee -/* - has_observing_type type_def_infos TE - = True - has_observing_type type_def_infos (TB basic_type) - = True -*/ has_observing_type (TB basic_type) type_def_infos subst = True has_observing_type (TempV var_number) type_def_infos subst diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index cb88692..4986059 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1081,6 +1081,7 @@ instance toString KindInfo :: CaseAlt = { calt_pattern :: !ParsedExpr , calt_rhs :: !Rhs + , calt_position :: !Position } :: LocalDef :== ParsedDefinition diff --git a/frontend/unitype.dcl b/frontend/unitype.dcl index 4b2dee4..12512e2 100644 --- a/frontend/unitype.dcl +++ b/frontend/unitype.dcl @@ -53,7 +53,7 @@ tryToMakeNonUnique :: !Int !*Coercions -> (!Bool, !*Coercions) tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions) -uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin +uniquenessErrorVar :: !FreeVar !FunctionBody !String !*ErrorAdmin -> *ErrorAdmin liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeHeaps !*TypeDefInfos -> (*{! Type}, !Int, !*TypeHeaps, !*TypeDefInfos) diff --git a/frontend/unitype.icl b/frontend/unitype.icl index 6f377d9..d05677c 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -26,13 +26,6 @@ FirstAttrVar :== 3 , pi_deps :: ![Int] } - -uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin -uniquenessError position mess err=:{ea_file,ea_loc} - # ea_file = ea_file <<< "Uniqueness error " <<< hd ea_loc <<< ": \"" <<< position <<< '\"' <<< mess <<< '\n' - = { err & ea_file = ea_file, ea_ok = False} - - :: BOOLVECT :== Int BITINDEX temp_var_id :== temp_var_id >> 5 @@ -1014,3 +1007,169 @@ where = (CT_NonUnique, tree) copy_coercion_tree tree=:CT_Existential = (CT_Existential, tree) + +uniquenessErrorVar :: !FreeVar !FunctionBody !String !*ErrorAdmin -> *ErrorAdmin +uniquenessErrorVar free_var=:{fv_info_ptr} (TransformedBody {tb_args,tb_rhs}) mess err + | var_in_free_vars fv_info_ptr tb_args + = uniquenessError (CP_Expression (FreeVar free_var)) mess err + # position = find_var_position_in_expression fv_info_ptr tb_rhs + = case position of + LinePos file_name line_n + # ea_file = err.ea_file <<< "Uniqueness error " <<< {ip_file=file_name,ip_line=line_n,ip_ident=free_var.fv_ident} <<< '\"' <<< mess <<< '\n' + -> { err & ea_file = ea_file, ea_ok = False} + FunPos file_name line_n fun_name + # ea_file = err.ea_file <<< "Uniqueness error " <<< {ip_file=file_name,ip_line=line_n,ip_ident=free_var.fv_ident} <<< '\"' <<< mess <<< '\n' + -> { err & ea_file = ea_file, ea_ok = False} + _ + -> uniquenessError (CP_Expression (FreeVar free_var)) mess err + +uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin +uniquenessError position mess err=:{ea_file,ea_loc} + # ea_file = ea_file <<< "Uniqueness error " <<< hd ea_loc <<< ": \"" <<< position <<< '\"' <<< mess <<< '\n' + = { err & ea_file = ea_file, ea_ok = False} + +var_in_free_vars var_ptr [] + = False +var_in_free_vars var_ptr [{fv_info_ptr}:vars] + = var_ptr==fv_info_ptr || var_in_free_vars var_ptr vars + +find_var_position_in_expression var_ptr expr + # (found,pos) = find_var_position_in_expression expr + | found + = pos + = NoPos +where + find_var_position_in_expression (App {app_args}) + = find_var_position_in_expressions app_args + find_var_position_in_expression (f @ a) + # (found,pos) = find_var_position_in_expression f + | found + = (True,pos) + = find_var_position_in_expressions a + find_var_position_in_expression (Selection _ expr selections) + # (found,pos) = find_var_position_in_selections selections + | found + = (True,pos) + = 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 + = (True,pos) + # (found,pos) = find_var_position_in_selections selections + | found + = (True,pos) + = find_var_position_in_expression expr2 + find_var_position_in_expression (RecordUpdate _ expr updated_fields) + # (found,pos) = find_var_position_in_updated_fields updated_fields + | found + = (True,pos) + = find_var_position_in_expression expr + where + find_var_position_in_updated_fields [{bind_src}:updated_fields] + # (found,pos) = find_var_position_in_expression bind_src + | found + = (True,pos) + = find_var_position_in_updated_fields updated_fields + find_var_position_in_updated_fields [] + = (False,NoPos) + 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 + = (True,pos) + # (found,pos) = find_var_position_in_let_binds let_lazy_binds + | found + = (True,pos) + = find_var_position_in_expression let_expr + where + find_var_position_in_let_binds [{lb_dst={fv_info_ptr},lb_position}:let_binds] + | var_ptr==fv_info_ptr + = (True,lb_position) + = find_var_position_in_let_binds let_binds + find_var_position_in_let_binds [] + = (False,NoPos) + find_var_position_in_expression (Case {case_expr,case_guards,case_default}) + # (found,pos) = find_var_position_in_expression case_expr + | found + = (True,pos); + # (found,pos) = find_var_position_in_case_guards case_guards + | found + = (True,pos); + = find_var_position_in_case_default case_default + where + find_var_position_in_case_guards (AlgebraicPatterns _ algebraic_patterns) + = find_var_position_in_algebraic_patterns algebraic_patterns + find_var_position_in_case_guards (BasicPatterns _ basic_patterns) + = find_var_position_in_basic_patterns basic_patterns + where + find_var_position_in_basic_patterns [{bp_expr}:basic_patterns] + # (found,pos) = find_var_position_in_expression bp_expr + | found + = (True,pos) + = find_var_position_in_basic_patterns basic_patterns + find_var_position_in_basic_patterns [] + = (False,NoPos) + find_var_position_in_case_guards (OverloadedListPatterns _ _ algebraic_patterns) + = find_var_position_in_algebraic_patterns algebraic_patterns + find_var_position_in_case_guards (DynamicPatterns dynamic_patterns) + = find_var_position_in_dynamic_patterns dynamic_patterns + where + find_var_position_in_dynamic_patterns [{dp_var,dp_rhs,dp_position}:dynamic_patterns] + | var_ptr==dp_var.fv_info_ptr + = (True,dp_position) + # (found,pos) = find_var_position_in_expression dp_rhs + | found + = (True,pos) + = find_var_position_in_dynamic_patterns dynamic_patterns + find_var_position_in_dynamic_patterns [] + = (False,NoPos) + find_var_position_in_case_guards NoPattern + = (False,NoPos) + + find_var_position_in_algebraic_patterns [{ap_vars,ap_expr,ap_position}:algebraic_patterns] + | var_in_free_vars var_ptr ap_vars + = (True,ap_position); + # (found,pos) = find_var_position_in_expression ap_expr + | found + = (True,pos) + = find_var_position_in_algebraic_patterns algebraic_patterns + find_var_position_in_algebraic_patterns [] + = (False,NoPos) + + find_var_position_in_case_default (Yes expr) + = find_var_position_in_expression expr + find_var_position_in_case_default No + = (False,NoPos) + find_var_position_in_expression (DynamicExpr {dyn_expr}) + = find_var_position_in_expression dyn_expr + find_var_position_in_expression expr + = (False,NoPos) + + find_var_position_in_expressions [expr:exprs] + # (found,pos) = find_var_position_in_expression expr + | found + = (True,pos) + = find_var_position_in_expressions exprs + find_var_position_in_expressions [] + = (False,NoPos) + + find_var_position_in_selections [RecordSelection _ _:selections] + = find_var_position_in_selections selections + find_var_position_in_selections [ArraySelection _ _ expr:selections] + # (found,pos) = find_var_position_in_expression expr + | found + = (True,pos) + = find_var_position_in_selections selections + find_var_position_in_selections [DictionarySelection _ d_selections _ expr:selections] + # (found,pos) = find_var_position_in_expression expr + | found + = (True,pos) + # (found,pos) = find_var_position_in_selections d_selections + | found + = (True,pos) + = find_var_position_in_selections selections + find_var_position_in_selections [] + = (False,NoPos) |