aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--frontend/checkFunctionBodies.icl38
-rw-r--r--frontend/parse.icl23
-rw-r--r--frontend/postparse.icl12
-rw-r--r--frontend/refmark.icl74
-rw-r--r--frontend/syntax.dcl1
-rw-r--r--frontend/unitype.dcl2
-rw-r--r--frontend/unitype.icl173
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)