aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--frontend/StdCompare.dcl3
-rw-r--r--frontend/StdCompare.icl11
-rw-r--r--frontend/check.dcl2
-rw-r--r--frontend/check.icl575
-rw-r--r--frontend/checksupport.dcl3
-rw-r--r--frontend/checksupport.icl4
-rw-r--r--frontend/checktypes.icl52
-rw-r--r--frontend/comparedefimp.dcl9
-rw-r--r--frontend/comparedefimp.icl964
-rw-r--r--frontend/convertDynamics.icl4
-rw-r--r--frontend/convertcases.icl6
-rw-r--r--frontend/explicitimports.icl123
-rw-r--r--frontend/main.icl11
-rw-r--r--frontend/parse.icl16
-rw-r--r--frontend/postparse.icl5
-rw-r--r--frontend/refmark.icl5
-rw-r--r--frontend/syntax.dcl9
-rw-r--r--frontend/syntax.icl24
-rw-r--r--frontend/trans.icl6
-rw-r--r--frontend/transform.icl7
-rw-r--r--frontend/type.icl4
21 files changed, 1479 insertions, 364 deletions
diff --git a/frontend/StdCompare.dcl b/frontend/StdCompare.dcl
index 67fff22..a46ee4d 100644
--- a/frontend/StdCompare.dcl
+++ b/frontend/StdCompare.dcl
@@ -13,7 +13,8 @@ instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, Global a
instance =< Type
-instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue, FunKind, Global a | == a
+instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue,
+ FunKind, Global a | == a, Priority, Assoc
export == Int
diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl
index a8c3f92..c9159c3 100644
--- a/frontend/StdCompare.icl
+++ b/frontend/StdCompare.icl
@@ -70,8 +70,6 @@ where
= tc1 == tc2 && types1 == types2
equal_constructor_args (TB tb1) (TB tb2)
= tb1 == tb2
- equal_constructor_args (TA tc1 types1) (TA tc2 types2)
- = tc1 == tc2 && types1 == types2
equal_constructor_args (type1 :@: types1) (type2 :@: types2)
= type1 == type2 && types1 == types2
equal_constructor_args (TQV varid1) (TQV varid2)
@@ -79,6 +77,15 @@ where
equal_constructor_args type1 type2
= True
+instance == Priority
+where
+ (==) NoPrio NoPrio = True
+ (==) (Prio assoc1 prio1) (Prio assoc2 prio2) = assoc1==assoc2 && prio1==prio2
+
+instance == Assoc
+where
+ (==) a1 a2 = equal_constructor a1 a2
+
:: CompareValue :== Int
Smaller :== -1
Greater :== 1
diff --git a/frontend/check.dcl b/frontend/check.dcl
index 7da5d78..6f1c234 100644
--- a/frontend/check.dcl
+++ b/frontend/check.dcl
@@ -2,8 +2,6 @@ definition module check
import syntax, transform, checksupport, typesupport, predef
-//MOVE
-//cIclModIndex :== 0
cPredefinedModuleIndex :== 1
checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File
diff --git a/frontend/check.icl b/frontend/check.icl
index 5d1e6e5..7720e0a 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -3,8 +3,7 @@ implementation module check
import StdEnv
import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug
-
-import explicitimports
+import explicitimports, comparedefimp
cPredefinedModuleIndex :== 1
@@ -592,7 +591,7 @@ where
}
:: ExpressionState =
- { es_expression_heap :: !.ExpressionHeap
+ { es_expr_heap :: !.ExpressionHeap
, es_var_heap :: !.VarHeap
, es_type_heaps :: !.TypeHeaps
, es_calls :: ![FunCall]
@@ -730,26 +729,34 @@ where
= (id_index, NoIndex, 0, NoPrio, NoIndex, cons_defs, modules, checkError id_name " constructor expected" error)
-checkIdentPattern :: !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) !PatternInput ![Ident] !*PatternState !*ExpressionInfo !*CheckState
- -> (!AuxiliaryPattern, ![Ident], !*PatternState, !*ExpressionInfo, !*CheckState)
-checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_mod_index} var_env ps e_info cs=:{cs_symbol_table}
+checkIdentPattern :: !Bool !Ident !(Optional (Bind Ident VarInfoPtr)) !PatternInput !(![Ident], ![ArrayPattern]) !*PatternState !*ExpressionInfo !*CheckState
+ -> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState)
+checkIdentPattern is_expr_list id=:{id_name,id_info} opt_var {pi_def_level, pi_mod_index} accus=:(var_env, array_patterns)
+ ps e_info cs=:{cs_symbol_table}
#! entry = sreadPtr id_info cs_symbol_table
| isLowerCaseName id_name
# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
cs = checkPatternVariable pi_def_level entry id new_info_ptr cs
- = (AP_Variable id new_info_ptr opt_var, [ id : var_env ], { ps & ps_var_heap = ps_var_heap}, e_info, cs)
+ = (AP_Variable id new_info_ptr opt_var, ([ id : var_env ], array_patterns), { ps & ps_var_heap = ps_var_heap}, e_info, cs)
# (pattern, ps, e_info, cs) = checkPatternConstructor pi_mod_index is_expr_list entry id opt_var ps e_info cs
- = (pattern, var_env, ps, e_info, cs)
+ = (pattern, accus, ps, e_info, cs)
:: PatternState =
{ ps_var_heap :: !.VarHeap
, ps_fun_defs :: !.{# FunDef}
}
+
:: PatternInput =
{ pi_def_level :: !Int
, pi_mod_index :: !Index
, pi_is_node_pattern :: !Bool
}
+
+:: ArrayPattern =
+ { ap_opt_var :: !Optional (Bind Ident VarInfoPtr)
+ , ap_array_var :: !FreeVar
+ , ap_selections :: ![Bind FreeVar ParsedExpr]
+ }
buildPattern mod_index (APK_Constructor type_index) cons_symb args opt_var ps e_info cs
= (AP_Algebraic cons_symb type_index args opt_var, ps, e_info, cs)
@@ -758,58 +765,58 @@ buildPattern mod_index APK_Macro {glob_object} args opt_var ps e_info=:{ef_modul
= unfoldPatternMacro mod_index glob_object.ds_index args opt_var ps ef_modules ef_cons_defs cs_error
= (pattern, ps, { e_info & ef_modules = ef_modules, ef_cons_defs = ef_cons_defs }, { cs & cs_error = cs_error })
-checkPattern :: !ParsedExpr !(Optional (Bind Ident VarInfoPtr)) !PatternInput ![Ident] !*PatternState !*ExpressionInfo !*CheckState
- -> (!AuxiliaryPattern, ![Ident], !*PatternState, !*ExpressionInfo, !*CheckState)
-checkPattern (PE_List [exp]) opt_var p_input var_env ps e_info cs=:{cs_symbol_table}
+checkPattern :: !ParsedExpr !(Optional (Bind Ident VarInfoPtr)) !PatternInput !(![Ident], ![ArrayPattern]) !*PatternState !*ExpressionInfo !*CheckState
+ -> (!AuxiliaryPattern, !(![Ident], ![ArrayPattern]), !*PatternState, !*ExpressionInfo, !*CheckState)
+checkPattern (PE_List [exp]) opt_var p_input accus ps e_info cs=:{cs_symbol_table}
= case exp of
PE_Ident ident
- -> checkIdentPattern cIsNotInExpressionList ident opt_var p_input var_env ps e_info cs
+ -> checkIdentPattern cIsNotInExpressionList ident opt_var p_input accus ps e_info cs
_
- -> checkPattern exp opt_var p_input var_env ps e_info cs
+ -> checkPattern exp opt_var p_input accus ps e_info cs
-checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input var_env ps e_info cs
- # (exp_pat, var_env, ps, e_info, cs) = check_pattern exp1 p_input var_env ps e_info cs
- = check_patterns [exp_pat] exp2 exps opt_var p_input var_env ps e_info cs
+checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input accus ps e_info cs
+ # (exp_pat, accus, ps, e_info, cs) = check_pattern exp1 p_input accus ps e_info cs
+ = check_patterns [exp_pat] exp2 exps opt_var p_input accus ps e_info cs
where
- check_patterns left middle [] opt_var p_input=:{pi_mod_index} var_env ps e_info cs
- # (mid_pat, var_env, ps, e_info, cs) = checkPattern middle No p_input var_env ps e_info cs
+ check_patterns left middle [] opt_var p_input=:{pi_mod_index} accus ps e_info cs
+ # (mid_pat, accus, ps, e_info, cs) = checkPattern middle No p_input accus ps e_info cs
(pat, ps, e_info, cs) = combine_patterns pi_mod_index opt_var [mid_pat : left] [] 0 ps e_info cs
- = (pat, var_env, ps, e_info, cs)
- check_patterns left middle [right:rest] opt_var p_input=:{pi_mod_index} var_env ps e_info cs
- # (mid_pat, var_env, ps, e_info, cs) = check_pattern middle p_input var_env ps e_info cs
+ = (pat, accus, ps, e_info, cs)
+ check_patterns left middle [right:rest] opt_var p_input=:{pi_mod_index} accus ps e_info cs
+ # (mid_pat, accus, ps, e_info, cs) = check_pattern middle p_input accus ps e_info cs
= case mid_pat of
AP_Constant kind constant=:{glob_object={ds_arity,ds_ident}} prio
| ds_arity == 0
# (pattern, ps, e_info, cs) = buildPattern pi_mod_index kind constant [] No ps e_info cs
- -> check_patterns [pattern: left] right rest opt_var p_input var_env ps e_info cs
+ -> check_patterns [pattern: left] right rest opt_var p_input accus ps e_info cs
| is_infix_constructor prio
# (left_arg, ps, e_info, cs) = combine_patterns pi_mod_index No left [] 0 ps e_info cs
- (right_pat, var_env, ps, e_info, cs) = check_pattern right p_input var_env ps e_info cs
+ (right_pat, accus, ps, e_info, cs) = check_pattern right p_input accus ps e_info cs
-> check_infix_pattern [] left_arg kind constant prio [right_pat] rest
- opt_var p_input var_env ps e_info cs
- -> (AP_Empty ds_ident, var_env, ps, e_info,
+ opt_var p_input accus ps e_info cs
+ -> (AP_Empty ds_ident, accus, ps, e_info,
{ cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error })
_
- -> check_patterns [mid_pat : left] right rest opt_var p_input var_env ps e_info cs
+ -> check_patterns [mid_pat : left] right rest opt_var p_input accus ps e_info cs
- check_pattern (PE_Ident id) p_input var_env ps e_info cs
- = checkIdentPattern cIsInExpressionList id No p_input var_env ps e_info cs
- check_pattern expr p_input var_env ps e_info cs
- = checkPattern expr No p_input var_env ps e_info cs
+ check_pattern (PE_Ident id) p_input accus ps e_info cs
+ = checkIdentPattern cIsInExpressionList id No p_input accus ps e_info cs
+ check_pattern expr p_input accus ps e_info cs
+ = checkPattern expr No p_input accus ps e_info cs
- check_infix_pattern left_args left kind cons prio middle [] opt_var p_input=:{pi_mod_index} var_env ps e_info cs
+ check_infix_pattern left_args left kind cons prio middle [] opt_var p_input=:{pi_mod_index} accus ps e_info cs
# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
(pattern, ps, e_info, cs) = buildPattern pi_mod_index kind cons [left,middle_pat] opt_var ps e_info cs
(pattern, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern ps e_info cs
- = (pattern, var_env, ps, e_info, cs)
- check_infix_pattern left_args left kind cons prio middle [right] opt_var p_input=:{pi_mod_index} var_env ps e_info cs
- # (right_pat, var_env, ps, e_info, cs) = checkPattern right No p_input var_env ps e_info cs
+ = (pattern, accus, ps, e_info, cs)
+ check_infix_pattern left_args left kind cons prio middle [right] opt_var p_input=:{pi_mod_index} accus ps e_info cs
+ # (right_pat, accus, ps, e_info, cs) = checkPattern right No p_input accus ps e_info cs
(right_arg, ps, e_info, cs) = combine_patterns pi_mod_index No [right_pat : middle] [] 0 ps e_info cs
(pattern, ps, e_info, cs) = buildPattern pi_mod_index kind cons [left,right_arg] opt_var ps e_info cs
(pattern, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern ps e_info cs
- = (pattern, var_env, ps, e_info, cs)
- check_infix_pattern left_args left kind1 cons1 prio1 middle [inf_cons, arg : rest] opt_var p_input=:{pi_mod_index} var_env ps e_info cs
- # (inf_cons_pat, var_env, ps, e_info, cs) = check_pattern inf_cons p_input var_env ps e_info cs
+ = (pattern, accus, ps, e_info, cs)
+ check_infix_pattern left_args left kind1 cons1 prio1 middle [inf_cons, arg : rest] opt_var p_input=:{pi_mod_index} accus ps e_info cs
+ # (inf_cons_pat, accus, ps, e_info, cs) = check_pattern inf_cons p_input accus ps e_info cs
= case inf_cons_pat of
AP_Constant kind2 cons2=:{glob_object={ds_ident,ds_arity}} prio2
| ds_arity == 0
@@ -817,25 +824,25 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input var_env ps e_info cs
(pattern2, ps, e_info, cs) = buildPattern pi_mod_index kind2 cons2 [] No ps e_info cs
(pattern1, ps, e_info, cs) = buildPattern pi_mod_index kind1 cons1 [left,middle_pat] No ps e_info cs
(pattern1, ps, e_info, cs) = build_final_pattern pi_mod_index left_args pattern1 ps e_info cs
- -> check_patterns [pattern2,pattern1] arg rest opt_var p_input var_env ps e_info cs
+ -> check_patterns [pattern2,pattern1] arg rest opt_var p_input accus ps e_info cs
| is_infix_constructor prio2
# optional_prio = determinePriority prio1 prio2
-> case optional_prio of
Yes priority
- # (arg_pat, var_env, ps, e_info, cs) = check_pattern arg p_input var_env ps e_info cs
+ # (arg_pat, accus, ps, e_info, cs) = check_pattern arg p_input accus ps e_info cs
| priority
# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
(pattern, ps, e_info, cs) = buildPattern pi_mod_index kind1 cons1 [left,middle_pat] No ps e_info cs
(left_args, pattern, ps, e_info, cs) = build_left_pattern pi_mod_index left_args prio2 pattern ps e_info cs
- -> check_infix_pattern left_args pattern kind2 cons2 prio2 [arg_pat] rest opt_var p_input var_env ps e_info cs
+ -> check_infix_pattern left_args pattern kind2 cons2 prio2 [arg_pat] rest opt_var p_input accus ps e_info cs
# (middle_pat, ps, e_info, cs) = combine_patterns pi_mod_index No middle [] 0 ps e_info cs
-> check_infix_pattern [(kind1, cons1, prio1, left) : left_args]
- middle_pat kind2 cons2 prio2 [arg_pat] rest No p_input var_env ps e_info cs
+ middle_pat kind2 cons2 prio2 [arg_pat] rest No p_input accus ps e_info cs
No
- -> (AP_Empty ds_ident, var_env, ps, e_info, { cs & cs_error = checkError ds_ident "conflicting priorities" cs.cs_error })
- -> (AP_Empty ds_ident, var_env, ps, e_info, { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error })
+ -> (AP_Empty ds_ident, accus, ps, e_info, { cs & cs_error = checkError ds_ident "conflicting priorities" cs.cs_error })
+ -> (AP_Empty ds_ident, accus, ps, e_info, { cs & cs_error = checkError ds_ident "arguments of constructor are missing" cs.cs_error })
_
- -> check_infix_pattern left_args left kind1 cons1 prio1 [inf_cons_pat : middle] [arg : rest] opt_var p_input var_env ps e_info cs
+ -> check_infix_pattern left_args left kind1 cons1 prio1 [inf_cons_pat : middle] [arg : rest] opt_var p_input accus ps e_info cs
is_infix_constructor (Prio _ _) = True
is_infix_constructor _ = False
@@ -881,47 +888,48 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input var_env ps e_info cs
= (opt_var, error)
*/
-checkPattern (PE_DynamicPattern pattern type) opt_var p_input var_env ps e_info cs
- # (dyn_pat, var_env, ps, e_info, cs) = checkPattern pattern No p_input var_env ps e_info cs
- = (AP_Dynamic dyn_pat type opt_var, var_env, ps, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics })
+checkPattern (PE_DynamicPattern pattern type) opt_var p_input accus ps e_info cs
+ # (dyn_pat, accus, ps, e_info, cs) = checkPattern pattern No p_input accus ps e_info cs
+ = (AP_Dynamic dyn_pat type opt_var, accus, ps, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics })
-checkPattern (PE_Basic basic_value) opt_var p_input var_env ps e_info cs
- = (AP_Basic basic_value opt_var, var_env, ps, e_info, cs)
+checkPattern (PE_Basic basic_value) opt_var p_input accus ps e_info cs
+ = (AP_Basic basic_value opt_var, accus, ps, e_info, cs)
-checkPattern (PE_Tuple tuple_args) opt_var p_input var_env ps e_info cs
- # (patterns, arity, var_env, ps, e_info, cs) = check_tuple_patterns tuple_args p_input var_env ps e_info cs
+checkPattern (PE_Tuple tuple_args) opt_var p_input accus ps e_info cs
+ # (patterns, arity, accus, ps, e_info, cs) = check_tuple_patterns tuple_args p_input accus ps e_info cs
(tuple_symbol, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex arity) PD_PredefinedModule STE_Constructor arity cs
#! {cons_type_index} = e_info.ef_modules.[tuple_symbol.glob_module].dcl_common.com_cons_defs.[tuple_symbol.glob_object.ds_index]
- = (AP_Algebraic tuple_symbol cons_type_index patterns opt_var, var_env, ps, e_info, cs)
+ = (AP_Algebraic tuple_symbol cons_type_index patterns opt_var, accus, ps, e_info, cs)
where
- check_tuple_patterns [] p_input var_env ps e_info cs
- = ([], 0, var_env, ps, e_info, cs)
- check_tuple_patterns [expr : exprs] p_input var_env ps e_info cs
- # (pattern, var_env, ps, e_info, cs) = checkPattern expr No p_input var_env ps e_info cs
- (patterns, length, var_env, ps, e_info, cs) = check_tuple_patterns exprs p_input var_env ps e_info cs
- = ([pattern : patterns], inc length, var_env, ps, e_info, cs)
-checkPattern (PE_Record record opt_type fields) opt_var p_input=:{pi_mod_index, pi_is_node_pattern} var_env ps e_info cs
+ check_tuple_patterns [] p_input accus ps e_info cs
+ = ([], 0, accus, ps, e_info, cs)
+ check_tuple_patterns [expr : exprs] p_input accus ps e_info cs
+ # (pattern, accus, ps, e_info, cs) = checkPattern expr No p_input accus ps e_info cs
+ (patterns, length, accus, ps, e_info, cs) = check_tuple_patterns exprs p_input accus ps e_info cs
+ = ([pattern : patterns], inc length, accus, ps, e_info, cs)
+checkPattern (PE_Record record opt_type fields) opt_var p_input=:{pi_mod_index, pi_is_node_pattern} accus=:(var_env, array_patterns) ps e_info cs
# (opt_record_and_fields, e_info, cs) = checkFields pi_mod_index fields opt_type e_info cs
= case opt_record_and_fields of
Yes (record_symbol, type_index, new_fields)
- # (patterns, (var_env, ps, e_info, cs)) = mapSt (check_field_pattern p_input) new_fields (var_env, ps, e_info, cs)
+ # (patterns, (var_env, array_patterns, ps, e_info, cs)) = mapSt (check_field_pattern p_input) new_fields (var_env, array_patterns, ps, e_info, cs)
(patterns, ps_var_heap) = bind_opt_record_variable opt_var pi_is_node_pattern patterns new_fields ps.ps_var_heap
- -> (AP_Algebraic record_symbol type_index patterns opt_var, var_env, { ps & ps_var_heap = ps_var_heap }, e_info, cs)
+ -> (AP_Algebraic record_symbol type_index patterns opt_var, (var_env, array_patterns), { ps & ps_var_heap = ps_var_heap }, e_info, cs)
No
- -> (AP_Empty (hd fields).bind_dst, var_env, ps, e_info, cs)
+ -> (AP_Empty (hd fields).bind_dst, accus, ps, e_info, cs)
where
- check_field_pattern p_input=:{pi_def_level} {bind_src = PE_Empty, bind_dst = {glob_object={fs_var}}} (var_env, ps, e_info, cs)
+ check_field_pattern p_input=:{pi_def_level} {bind_src = PE_Empty, bind_dst = {glob_object={fs_var}}}
+ (var_env, array_patterns, ps, e_info, cs)
#! entry = sreadPtr fs_var.id_info cs.cs_symbol_table
# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
cs = checkPatternVariable pi_def_level entry fs_var new_info_ptr cs
- = (AP_Variable fs_var new_info_ptr No, ([ fs_var : var_env ], { ps & ps_var_heap = ps_var_heap }, e_info, cs))
- check_field_pattern p_input {bind_src = PE_WildCard, bind_dst={glob_object={fs_var}}} (var_env, ps, e_info, cs)
+ = (AP_Variable fs_var new_info_ptr No, ([ fs_var : var_env ], array_patterns, { ps & ps_var_heap = ps_var_heap }, e_info, cs))
+ check_field_pattern p_input {bind_src = PE_WildCard, bind_dst={glob_object={fs_var}}} (var_env, array_patterns, ps, e_info, cs)
# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
- = (AP_WildCard (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), (var_env, { ps & ps_var_heap = ps_var_heap }, e_info, cs))
- check_field_pattern p_input {bind_src,bind_dst} (var_env, ps, e_info, cs)
- # (pattern, var_env, ps, e_info, cs) = checkPattern bind_src No p_input var_env ps e_info cs
- = (pattern, (var_env, ps, e_info, cs))
+ = (AP_WildCard (Yes { bind_src = fs_var, bind_dst = new_info_ptr}), (var_env, array_patterns, { ps & ps_var_heap = ps_var_heap }, e_info, cs))
+ check_field_pattern p_input {bind_src,bind_dst} (var_env, array_patterns, ps, e_info, cs)
+ # (pattern, (var_env, array_patterns), ps, e_info, cs) = checkPattern bind_src No p_input (var_env, array_patterns) ps e_info cs
+ = (pattern, (var_env, array_patterns, ps, e_info, cs))
add_bound_variable (AP_Algebraic symbol index patterns No) {bind_dst = {glob_object={fs_var}}} ps_var_heap
@@ -949,30 +957,62 @@ where
bind_opt_record_variable no is_node_pattern patterns _ var_heap
= (patterns, var_heap)
-checkPattern (PE_Bound bind) opt_var p_input var_env ps e_info cs
- = checkBoundPattern bind opt_var p_input var_env ps e_info cs
-
-checkPattern (PE_Ident id) opt_var p_input var_env ps e_info cs
- = checkIdentPattern cIsNotInExpressionList id opt_var p_input var_env ps e_info cs
-checkPattern PE_WildCard opt_var p_input var_env ps e_info cs
- = (AP_WildCard No, var_env, ps, e_info, cs)
-checkPattern expr opt_var p_input var_env ps e_info cs
+checkPattern (PE_ArrayPattern selections) opt_var p_input (var_env, array_patterns) ps e_info cs
+ # (var_env, ap_selections, ps_var_heap, cs)
+ = foldSt (check_array_selection p_input.pi_def_level) selections (var_env, [], ps.ps_var_heap, cs)
+ array_var_ident = case opt_var of {Yes {bind_src} -> bind_src; _ -> { id_name = "_a", id_info = nilPtr }}
+ (array_var, ps_var_heap) = allocate_free_var array_var_ident ps_var_heap
+ = (AP_Variable array_var_ident array_var.fv_info_ptr No,
+ (var_env, [{ ap_opt_var = opt_var, ap_array_var = array_var, ap_selections = ap_selections } :array_patterns]),
+ { ps & ps_var_heap = ps_var_heap }, e_info, cs)
+ where
+ check_array_selection def_level bind=:{bind_dst} states
+ = check_rhs def_level bind (check_index_expr bind_dst states)
+
+ check_index_expr (PE_Ident {id_name}) states
+ | isLowerCaseName id_name
+ = states
+ // further with next alternative
+ check_index_expr (PE_Basic (BVI _)) states
+ = states
+ check_index_expr _ (var_env, ap_selections, var_heap, cs)
+ = (var_env, ap_selections, var_heap, { cs & cs_error = checkError "" "variable or integer constant expected as index expression" cs.cs_error })
+
+ check_rhs def_level {bind_src=PE_Ident ident, bind_dst} (var_env, ap_selections, var_heap, cs)
+ | isLowerCaseName ident.id_name
+ #! entry = sreadPtr ident.id_info cs.cs_symbol_table
+ # (rhs_var, var_heap) = allocate_free_var ident var_heap
+ cs = checkPatternVariable def_level entry ident rhs_var.fv_info_ptr cs
+ = ([ident : var_env], [ { bind_src = rhs_var, bind_dst = bind_dst } : ap_selections], var_heap, cs)
+ // further with next alternative
+ check_rhs _ _ (var_env, ap_selections, var_heap, cs)
+ = (var_env, ap_selections, var_heap,
+ { cs & cs_error = checkError "" "variable expected on right hand side of array pattern" cs.cs_error })
+
+checkPattern (PE_Bound bind) opt_var p_input accus ps e_info cs
+ = checkBoundPattern bind opt_var p_input accus ps e_info cs
+
+checkPattern (PE_Ident id) opt_var p_input accus ps e_info cs
+ = checkIdentPattern cIsNotInExpressionList id opt_var p_input accus ps e_info cs
+checkPattern PE_WildCard opt_var p_input accus ps e_info cs
+ = (AP_WildCard No, accus, ps, e_info, cs)
+checkPattern expr opt_var p_input accus ps e_info cs
= abort "checkPattern: do not know how to handle pattern" ---> expr
-checkBoundPattern {bind_src,bind_dst} opt_var p_input var_env ps e_info cs=:{cs_symbol_table}
+checkBoundPattern {bind_src,bind_dst} opt_var p_input (var_env, array_patterns) ps e_info cs=:{cs_symbol_table}
| isLowerCaseName bind_dst.id_name
#! entry = sreadPtr bind_dst.id_info cs_symbol_table
# (new_info_ptr, ps_var_heap) = newPtr VI_Empty ps.ps_var_heap
cs = checkPatternVariable p_input.pi_def_level entry bind_dst new_info_ptr cs
ps = { ps & ps_var_heap = ps_var_heap }
- var_env = [ bind_dst : var_env ]
+ new_var_env = [ bind_dst : var_env ]
= case opt_var of
Yes bind
- -> checkPattern bind_src (Yes { bind_src = bind_dst, bind_dst = new_info_ptr }) p_input var_env ps
+ -> checkPattern bind_src (Yes { bind_src = bind_dst, bind_dst = new_info_ptr }) p_input (new_var_env, array_patterns) ps
e_info { cs & cs_error = checkError bind.bind_src "pattern may be bound once only" cs.cs_error }
No
- -> checkPattern bind_src (Yes { bind_src = bind_dst, bind_dst = new_info_ptr }) p_input var_env ps e_info cs
- = checkPattern bind_src opt_var p_input var_env ps e_info { cs & cs_error = checkError bind_dst "variable expected" cs.cs_error }
+ -> checkPattern bind_src (Yes { bind_src = bind_dst, bind_dst = new_info_ptr }) p_input (new_var_env, array_patterns) ps e_info cs
+ = checkPattern bind_src opt_var p_input (var_env, array_patterns) ps e_info { cs & cs_error = checkError bind_dst "variable expected" cs.cs_error }
newFreeVariable :: !FreeVar ![FreeVar] ->(!Bool, ![FreeVar])
newFreeVariable new_var vars=:[free_var=:{fv_def_level,fv_info_ptr}: free_vars]
@@ -1000,14 +1040,14 @@ consOptional No things
= things
buildApplication :: !SymbIdent !Int !Int !Bool ![Expression] !*ExpressionState !*ErrorAdmin -> (!Expression,!*ExpressionState,!*ErrorAdmin)
-buildApplication symbol form_arity act_arity is_fun args e_state=:{es_expression_heap} error
+buildApplication symbol form_arity act_arity is_fun args e_state=:{es_expr_heap} error
| is_fun
- # (new_info_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap
+ # (new_info_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
| form_arity < act_arity
# app = { app_symb = { symbol & symb_arity = form_arity }, app_args = take form_arity args, app_info_ptr = new_info_ptr }
- = (App app @ drop form_arity args, { e_state & es_expression_heap = es_expression_heap }, error)
+ = (App app @ drop form_arity args, { e_state & es_expr_heap = es_expr_heap }, error)
# app = { app_symb = { symbol & symb_arity = act_arity }, app_args = take form_arity args, app_info_ptr = new_info_ptr }
- = (App app, { e_state & es_expression_heap = es_expression_heap }, error)
+ = (App app, { e_state & es_expr_heap = es_expr_heap }, error)
# app = App { app_symb = { symbol & symb_arity = act_arity }, app_args = args, app_info_ptr = nilPtr }
| form_arity < act_arity
= (app, e_state, checkError symbol.symb_name " used with too many arguments" error)
@@ -1023,14 +1063,14 @@ where
-> (!Expression, ![FreeVar], !*ExpressionState, !u:ExpressionInfo, !*CheckState)
check_id_expression {ste_kind = STE_Empty} is_expr_list free_vars id e_input e_state e_info cs=:{cs_error}
= (EE, free_vars, e_state, e_info, { cs & cs_error = checkError id " undefined" cs_error })
- check_id_expression {ste_kind = STE_Variable info_ptr,ste_def_level} is_expr_list free_vars id e_input=:{ei_fun_level} e_state=:{es_expression_heap} e_info cs
+ check_id_expression {ste_kind = STE_Variable info_ptr,ste_def_level} is_expr_list free_vars id e_input=:{ei_fun_level} e_state=:{es_expr_heap} e_info cs
| ste_def_level < ei_fun_level
# free_var = { fv_def_level = ste_def_level, fv_name = id, fv_info_ptr = info_ptr, fv_count = 0 }
(free_var_added, free_vars) = newFreeVariable free_var free_vars
= (FreeVar free_var, free_vars, e_state, e_info, cs)
- #! (var_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap
+ #! (var_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
= (Var {var_name = id, var_info_ptr = info_ptr, var_expr_ptr = var_expr_ptr}, free_vars,
- {e_state & es_expression_heap = es_expression_heap}, e_info, cs)
+ {e_state & es_expr_heap = es_expr_heap}, e_info, cs)
check_id_expression entry is_expr_list free_vars id=:{id_info} e_input e_state e_info cs
# (symb_kind, arity, priority, is_a_function, e_state, e_info, cs) = determine_info_of_symbol entry id_info e_input e_state e_info cs
symbol = { symb_name = id, symb_kind = symb_kind, symb_arity = 0 }
@@ -1198,24 +1238,28 @@ where
checkExpression free_vars (PE_Let strict let_locals expr) e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# ei_expr_level = inc ei_expr_level
- (loc_defs, var_env, e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index let_locals e_state e_info cs
+ (loc_defs, (var_env, array_patterns), e_state, e_info, cs)
+ = checkLhssOfLocalDefs ei_expr_level ei_mod_index let_locals e_state e_info cs
e_input = { e_input & ei_expr_level = ei_expr_level }
(let_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
- (let_expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs let_expr e_input e_state e_info cs
+ (expr, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
+ = addArraySelections array_patterns let_expr free_vars e_input e_state e_info cs
+ (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs expr e_input e_state e_info cs
(es_fun_defs, e_info, heaps, cs)
= checkLocalFunctions ei_mod_index ei_expr_level let_locals e_state.es_fun_defs e_info
- { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs
+ { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps } cs
(es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable ei_expr_level var_env let_locals es_fun_defs cs.cs_symbol_table
- = (let_expr, free_vars, { e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expression_heap = heaps.hp_expression_heap,
- es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table })
+ = (expr, free_vars,
+ { e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expr_heap = heaps.hp_expression_heap,
+ es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table })
checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info cs
# (pattern_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
(guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars alts [] case_ident.id_name e_input e_state e_info cs
- (pattern_expr, binds, es_expression_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expression_heap
- (case_expr, es_expression_heap) = build_case guards defaul pattern_expr case_ident es_expression_heap
- (result_expr, es_expression_heap) = buildLetExpression binds cIsNotStrict case_expr es_expression_heap
- = (result_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs)
+ (pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap
+ (case_expr, es_expr_heap) = build_case guards defaul pattern_expr case_ident es_expr_heap
+ (result_expr, es_expr_heap) = buildLetExpression binds cIsNotStrict case_expr es_expr_heap
+ = (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
where
check_guarded_expressions free_vars [g] pattern_variables case_name e_input=:{ei_expr_level} e_state e_info cs
@@ -1228,17 +1272,21 @@ where
= 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
e_input=:{ei_expr_level,ei_mod_index} e_state=:{es_fun_defs,es_var_heap} e_info cs
- # (pattern, var_env, {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 } []
+ # (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 } ([], [])
{ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs
- e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs}
- (expr, free_vars, e_state=:{es_dynamics,es_expression_heap,es_var_heap}, e_info, cs) = checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs
+ e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs }
+ (rhs_expr, free_vars, e_state, e_info, cs)
+ = checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs
+ (expr_with_array_selections, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
+ = 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_expression_heap, dynamics_in_patterns, cs)
- = transform_pattern pattern patterns pattern_scheme pattern_variables defaul expr case_name es_var_heap es_expression_heap es_dynamics { cs & cs_symbol_table = 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
+ es_var_heap es_expr_heap es_dynamics { 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_expression_heap = es_expression_heap, es_dynamics = dynamics_in_patterns },
- e_info, cs)
+ { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns },
+ e_info, cs)
transform_pattern :: !AuxiliaryPattern !CasePatterns !CasePatterns !(Env Ident VarInfoPtr) !(Optional (!Optional FreeVar, !Expression)) !Expression
!String !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState
@@ -1472,11 +1520,11 @@ where
= ({ field & bind_src = EE }, free_vars, e_state, e_info, { cs & cs_error = checkError fs_name "field not specified" cs.cs_error })
check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr RK_Update e_input e_state e_info cs
= ({ field & bind_src = EE }, free_vars, e_state, e_info, cs)
- check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr (RK_UpdateToConstructor fields) e_input e_state=:{es_expression_heap} e_info cs
+ check_field_expr free_vars field=:{bind_src = PE_WildCard} field_nr (RK_UpdateToConstructor fields) e_input e_state=:{es_expr_heap} e_info cs
# (var_name, var_info_ptr) = get_field_var (fields !! field_nr)
- (var_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap
+ (var_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
= ({ field & bind_src = Var { var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr }}, free_vars,
- { e_state & es_expression_heap = es_expression_heap }, e_info, cs)
+ { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
check_field_expr free_vars field=:{bind_src} field_nr upd_record e_input e_state e_info cs
# (expr, free_vars, e_state, e_info, cs)
= checkExpression free_vars bind_src e_input e_state e_info cs
@@ -1495,10 +1543,10 @@ where
get_field_var _
= ({ id_name = "** ERRONEOUS **", id_info = nilPtr }, nilPtr)
-checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_expression_heap,es_dynamics} e_info cs
- # (dyn_info_ptr, es_expression_heap) = newPtr (EI_Dynamic opt_type) es_expression_heap
+checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_expr_heap,es_dynamics} e_info cs
+ # (dyn_info_ptr, es_expr_heap) = newPtr (EI_Dynamic opt_type) es_expr_heap
(dyn_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input
- {e_state & es_dynamics = [dyn_info_ptr : es_dynamics], es_expression_heap = es_expression_heap } e_info cs
+ {e_state & es_dynamics = [dyn_info_ptr : es_dynamics], es_expr_heap = es_expr_heap } e_info cs
= (DynamicExpr { dyn_expr = dyn_expr, dyn_opt_type = opt_type, dyn_info_ptr = dyn_info_ptr, dyn_type_code = TCE_Empty, dyn_uni_vars = [] },
free_vars, e_state, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics })
@@ -1616,8 +1664,8 @@ where
checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
# (index_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars index_expr e_input e_state e_info cs
- (new_info_ptr, es_expression_heap) = newPtr EI_Empty e_state.es_expression_heap
- = (ArraySelection glob_select_symb new_info_ptr index_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs)
+ (new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
+ = (ArraySelection glob_select_symb new_info_ptr index_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
buildLetExpression :: !(Env Expression FreeVar) !Bool !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap)
buildLetExpression [] is_strict expr expr_heap
@@ -1629,31 +1677,31 @@ buildLetExpression binds is_strict expr expr_heap
= (Let {let_strict_binds = [], let_lazy_binds = binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap)
checkLhssOfLocalDefs def_level mod_index (CollectedLocalDefs {loc_functions={ir_from,ir_to},loc_nodes}) e_state=:{es_var_heap,es_fun_defs} e_info cs
- # (loc_defs, var_env, {ps_fun_defs,ps_var_heap}, e_info, cs)
- = check_patterns loc_nodes {pi_def_level = def_level, pi_mod_index = mod_index, pi_is_node_pattern = True } []
+ # (loc_defs, accus, {ps_fun_defs,ps_var_heap}, e_info, cs)
+ = check_patterns loc_nodes {pi_def_level = def_level, pi_mod_index = mod_index, pi_is_node_pattern = True } ([], [])
{ps_fun_defs = es_fun_defs, ps_var_heap = es_var_heap} e_info cs
(es_fun_defs, cs_symbol_table, cs_error) = addLocalFunctionDefsToSymbolTable def_level ir_from ir_to ps_fun_defs cs.cs_symbol_table cs.cs_error
- = (loc_defs, var_env, { e_state & es_fun_defs = es_fun_defs, es_var_heap = ps_var_heap }, e_info, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })
+ = (loc_defs, accus, { e_state & es_fun_defs = es_fun_defs, es_var_heap = ps_var_heap }, e_info, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })
where
- check_patterns [ (_,node_def) : node_defs ] p_input var_env var_store e_info cs
- # (pattern, var_env, var_store, e_info, cs) = checkPattern node_def.nd_dst No p_input var_env var_store e_info cs
- (patterns, var_env, var_store, e_info, cs) = check_patterns node_defs p_input var_env var_store e_info cs
- = ([{ node_def & nd_dst = pattern } : patterns], var_env, var_store, e_info, cs)
- check_patterns [] p_input var_env var_store e_info cs
- = ([], var_env, var_store, e_info, cs)
+ check_patterns [ (_,node_def) : node_defs ] p_input accus var_store e_info cs
+ # (pattern, accus, var_store, e_info, cs) = checkPattern node_def.nd_dst No p_input accus var_store e_info cs
+ (patterns, accus, var_store, e_info, cs) = check_patterns node_defs p_input accus var_store e_info cs
+ = ([{ node_def & nd_dst = pattern } : patterns], accus, var_store, e_info, cs)
+ check_patterns [] p_input accus var_store e_info cs
+ = ([], accus, var_store, e_info, cs)
checkRhssAndTransformLocalDefs free_vars [] rhs_expr e_input e_state e_info cs
= (rhs_expr, free_vars, e_state, e_info, cs)
checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input e_state e_info cs
# (binds, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars loc_defs e_input e_state e_info cs
- (rhs_expr, es_expression_heap) = buildLetExpression binds cIsNotStrict rhs_expr e_state.es_expression_heap
- = (rhs_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs)
+ (rhs_expr, es_expr_heap) = buildLetExpression binds cIsNotStrict rhs_expr e_state.es_expr_heap
+ = (rhs_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
checkAndTransformPatternIntoBind free_vars [{nd_dst,nd_alts,nd_locals} : local_defs] e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# (bind_src, free_vars, e_state, e_info, cs) = checkRhs free_vars nd_alts nd_locals e_input e_state e_info cs
- (binds_of_bind, es_var_heap, es_expression_heap, e_info, cs)
- = transfromPatternIntoBind ei_mod_index ei_expr_level nd_dst bind_src e_state.es_var_heap e_state.es_expression_heap e_info cs
- e_state = { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap }
+ (binds_of_bind, es_var_heap, es_expr_heap, e_info, cs)
+ = transfromPatternIntoBind ei_mod_index ei_expr_level nd_dst bind_src e_state.es_var_heap e_state.es_expr_heap e_info cs
+ e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
(binds_of_local_defs, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars local_defs e_input e_state e_info cs
= (binds_of_bind ++ binds_of_local_defs, free_vars, e_state, e_info, cs)
checkAndTransformPatternIntoBind free_vars [] e_input e_state e_info cs
@@ -1754,14 +1802,17 @@ checkLocalFunctions mod_index level (CollectedLocalDefs {loc_functions={ir_from,
checkRhs free_vars rhs_alts rhs_locals e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# ei_expr_level = inc ei_expr_level
- (loc_defs, var_env, e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index rhs_locals e_state e_info cs
+ (loc_defs, (var_env, array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index rhs_locals e_state e_info cs
(es_fun_defs, e_info, heaps, cs)
= checkLocalFunctions ei_mod_index ei_expr_level rhs_locals e_state.es_fun_defs e_info
- { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs
- (rhs_expr, free_vars, e_state, e_info, cs) = check_opt_guarded_alts free_vars rhs_alts { e_input & ei_expr_level = ei_expr_level }
- { e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expression_heap = heaps.hp_expression_heap,
- es_type_heaps = heaps.hp_type_heaps } e_info cs
- (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input e_state e_info cs
+ { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps } cs
+ (rhs_expr, free_vars, e_state, e_info, cs)
+ = check_opt_guarded_alts free_vars rhs_alts { e_input & ei_expr_level = ei_expr_level }
+ { e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, es_expr_heap = heaps.hp_expression_heap,
+ es_type_heaps = heaps.hp_type_heaps } e_info cs
+ (expr, free_vars, e_state, e_info, cs)
+ = addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
+ (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs expr e_input e_state e_info cs
(es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable ei_expr_level var_env rhs_locals e_state.es_fun_defs cs.cs_symbol_table
= (expr, free_vars, { e_state & es_fun_defs = es_fun_defs}, e_info, { cs & cs_symbol_table = cs_symbol_table })
where
@@ -1771,8 +1822,8 @@ where
(default_expr, free_vars, e_state, e_info, cs)
= check_default_expr free_vars default_expr { e_input & ei_expr_level = last_expr_level } e_state e_info cs
cs = { cs & cs_symbol_table = remove_seq_let_vars e_input.ei_expr_level let_vars_list cs.cs_symbol_table }
- (result_expr, es_expression_heap) = convert_guards_to_cases rev_guarded_exprs default_expr e_state.es_expression_heap
- = (result_expr, free_vars, { e_state & es_expression_heap = es_expression_heap }, e_info, cs)
+ (result_expr, es_expr_heap) = convert_guards_to_cases rev_guarded_exprs default_expr e_state.es_expr_heap
+ = (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
check_opt_guarded_alts free_vars (UnGuardedExpr unguarded_expr) e_input e_state e_info cs
= check_unguarded_expression free_vars unguarded_expr e_input e_state e_info cs
@@ -1782,17 +1833,17 @@ where
check_default_expr free_vars No e_input e_state e_info cs
= (No, free_vars, e_state, e_info, cs)
- convert_guards_to_cases [(let_binds, guard, expr)] result_expr es_expression_heap
- # (case_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap
+ convert_guards_to_cases [(let_binds, guard, expr)] result_expr es_expr_heap
+ # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [{bp_value = (BVB True), bp_expr = expr}],
case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr }
- = build_sequential_lets let_binds case_expr es_expression_heap
- convert_guards_to_cases [(let_binds, guard, expr) : rev_guarded_exprs] result_expr es_expression_heap
- # (case_expr_ptr, es_expression_heap) = newPtr EI_Empty es_expression_heap
+ = build_sequential_lets let_binds case_expr es_expr_heap
+ convert_guards_to_cases [(let_binds, guard, expr) : rev_guarded_exprs] result_expr es_expr_heap
+ # (case_expr_ptr, es_expr_heap) = newPtr EI_Empty es_expr_heap
case_expr = Case { case_expr = guard, case_guards = BasicPatterns BT_Bool [{bp_value = (BVB True), bp_expr = expr}],
case_default = result_expr, case_ident = No, case_info_ptr = case_expr_ptr }
- (result_expr, es_expression_heap) = build_sequential_lets let_binds case_expr es_expression_heap
- = convert_guards_to_cases rev_guarded_exprs (Yes result_expr) es_expression_heap
+ (result_expr, es_expr_heap) = build_sequential_lets let_binds case_expr es_expr_heap
+ = convert_guards_to_cases rev_guarded_exprs (Yes result_expr) es_expr_heap
check_guarded_expressions free_vars [gexpr : gexprs] let_vars_list rev_guarded_exprs e_input e_state e_info cs
# (let_vars_list, rev_guarded_exprs, ei_expr_level, free_vars, e_state, e_info, cs)
@@ -1812,19 +1863,22 @@ where
check_unguarded_expression free_vars {ewl_nodes,ewl_expr,ewl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# this_expr_level = inc ei_expr_level
- (loc_defs, var_env, e_state, e_info, cs) = checkLhssOfLocalDefs this_expr_level ei_mod_index ewl_locals e_state e_info cs
+ (loc_defs, (var_env, array_patterns), e_state, e_info, cs)
+ = checkLhssOfLocalDefs this_expr_level ei_mod_index ewl_locals e_state e_info cs
(binds, let_vars_list, rhs_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars ewl_nodes [] { e_input & ei_expr_level = this_expr_level } e_state e_info cs
(expr, free_vars, e_state, e_info, cs) = checkExpression free_vars ewl_expr { e_input & ei_expr_level = rhs_expr_level } e_state e_info cs
+ (expr, free_vars, e_state, e_info, cs)
+ = addArraySelections array_patterns expr free_vars e_input e_state e_info cs
cs = { cs & cs_symbol_table = remove_seq_let_vars rhs_expr_level let_vars_list cs.cs_symbol_table }
- (seq_let_expr, es_expression_heap) = build_sequential_lets binds expr e_state.es_expression_heap
+ (seq_let_expr, es_expr_heap) = build_sequential_lets binds expr e_state.es_expr_heap
(expr, free_vars, e_state, e_info, cs)
- = checkRhssAndTransformLocalDefs free_vars loc_defs seq_let_expr e_input { e_state & es_expression_heap = es_expression_heap} e_info cs
+ = checkRhssAndTransformLocalDefs free_vars loc_defs seq_let_expr e_input { e_state & es_expr_heap = es_expr_heap} e_info cs
(es_fun_defs, e_info, heaps, cs)
= checkLocalFunctions ei_mod_index rhs_expr_level ewl_locals e_state.es_fun_defs e_info
- { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs
+ { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps } cs
(es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable this_expr_level var_env ewl_locals es_fun_defs cs.cs_symbol_table
= (expr, free_vars, {e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap,
- es_expression_heap = heaps.hp_expression_heap, es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table} )
+ es_expr_heap = heaps.hp_expression_heap, es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table} )
remove_seq_let_vars level [] symbol_table
= symbol_table
@@ -1834,29 +1888,34 @@ where
check_sequential_lets free_vars [seq_let:seq_lets] let_vars_list e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
# ei_expr_level = inc ei_expr_level
e_input = { e_input & ei_expr_level = ei_expr_level }
- (src_expr, pattern_expr, let_vars, free_vars, e_state, e_info, cs) = check_sequential_let free_vars seq_let e_input e_state e_info cs
+ (src_expr, pattern_expr, (let_vars, array_patterns), free_vars, e_state, e_info, cs) = check_sequential_let free_vars seq_let e_input e_state e_info cs
(binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs)
= check_sequential_lets free_vars seq_lets [let_vars : let_vars_list] e_input e_state e_info cs
- (let_binds, es_var_heap, es_expression_heap, e_info, cs)
- = transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr e_state.es_var_heap e_state.es_expression_heap e_info cs
- = ([(seq_let.ndwl_strict, let_binds) : binds], loc_envs, max_expr_level, free_vars, { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap }, e_info, cs)
+ (let_binds, es_var_heap, es_expr_heap, e_info, cs)
+ = transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr e_state.es_var_heap e_state.es_expr_heap e_info cs
+ e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
+ (_, array_pattern_binds, free_vars, e_state, e_info, cs) // XXX arrays currently not strictly evaluated
+ = foldSt (buildSelectCalls e_input) array_patterns ([], [], free_vars, e_state, e_info, cs)
+ all_binds = [(seq_let.ndwl_strict, let_binds), (nOT_STRICT, array_pattern_binds) : binds] with nOT_STRICT = False
+ = (all_binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs)
check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs
= ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs)
check_sequential_let free_vars {ndwl_def={bind_src,bind_dst},ndwl_locals} e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
- # (loc_defs, loc_env, e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index ndwl_locals e_state e_info cs
+ # (loc_defs, (loc_env, loc_array_patterns), e_state, e_info, cs) = checkLhssOfLocalDefs ei_expr_level ei_mod_index ndwl_locals e_state e_info cs
(src_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars bind_src e_input e_state e_info cs
+ (src_expr, free_vars, e_state, e_info, cs)
+ = addArraySelections loc_array_patterns src_expr free_vars e_input e_state e_info cs
(src_expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs src_expr e_input e_state e_info cs
(es_fun_defs, e_info, {hp_var_heap,hp_expression_heap,hp_type_heaps}, cs)
= checkLocalFunctions ei_mod_index ei_expr_level ndwl_locals e_state.es_fun_defs e_info
- { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs
+ { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expr_heap, hp_type_heaps = e_state.es_type_heaps } cs
(es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable ei_expr_level loc_env ndwl_locals es_fun_defs cs.cs_symbol_table
- (pattern, let_vars, {ps_fun_defs,ps_var_heap}, e_info, cs)
- = checkPattern bind_dst No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = True } []
+ (pattern, accus, {ps_fun_defs,ps_var_heap}, e_info, cs)
+ = checkPattern bind_dst No { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = True } ([], [])
{ps_var_heap = hp_var_heap, ps_fun_defs = es_fun_defs } e_info { cs & cs_symbol_table = cs_symbol_table }
- = (src_expr, pattern, let_vars, free_vars,
- { e_state & es_var_heap = ps_var_heap, es_expression_heap = hp_expression_heap, es_type_heaps = hp_type_heaps, es_fun_defs = ps_fun_defs },
- e_info, cs)
+ e_state = { e_state & es_var_heap = ps_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps, es_fun_defs = ps_fun_defs }
+ = (src_expr, pattern, accus, free_vars, e_state, e_info, cs)
build_sequential_lets :: ![(Bool,[Bind Expression FreeVar])] !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap)
build_sequential_lets [] expr expr_heap
@@ -1935,30 +1994,105 @@ typeOfBasicValue (BVS _) cs
# ({glob_module,glob_object={ds_ident,ds_index,ds_arity}}, cs) = getPredefinedGlobalSymbol PD_StringType PD_PredefinedModule STE_Type 0 cs
= (BT_String (TA (MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity) []), cs)
+
+// XXX no strict_binds
+addArraySelections [] rhs_expr free_vars e_input e_state e_info cs
+ = (rhs_expr, free_vars, e_state, e_info, cs)
+addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
+ # (let_strict_binds, let_lazy_binds, free_vars, e_state, e_info, cs)
+ = foldSt (buildSelectCalls e_input) array_patterns ([], [], free_vars, e_state, e_info, cs)
+ (let_expr_ptr, es_expr_heap)
+ = newPtr EI_Empty e_state.es_expr_heap
+ = ( Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds,
+ let_expr = rhs_expr, let_info_ptr = let_expr_ptr }
+ , free_vars
+ , { e_state & es_expr_heap = es_expr_heap}
+ , e_info
+ , cs
+ )
+
+buildSelectCalls e_input {ap_opt_var, ap_array_var, ap_selections}
+ (strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
+ # (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
+ = foldSt (build_sc e_input) ap_selections
+ (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
+ (lazy_binds, e_state)
+ = case ap_opt_var of
+ Yes { bind_src = opt_var_ident, bind_dst = opt_var_var_info_ptr }
+ # (bound_array_var, es_expr_heap) = allocate_bound_var ap_array_var e_state.es_expr_heap
+ free_var = { fv_name = opt_var_ident, fv_info_ptr = opt_var_var_info_ptr, fv_def_level = NotALevel,
+ fv_count = 0 }
+ -> ([{ bind_dst = free_var, bind_src = Var bound_array_var } : lazy_binds],
+ { e_state & es_expr_heap = es_expr_heap })
+ no -> (lazy_binds, e_state)
+ = (strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
+ where
+ build_sc e_input {bind_dst, bind_src=array_element_var} (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
+ # (var_for_uselect_result, es_var_heap)
+ = allocate_free_var { id_name = "_x", id_info = nilPtr } e_state.es_var_heap
+ (new_array_var, es_var_heap)
+ = allocate_free_var ap_array_var.fv_name es_var_heap
+ (bound_array_var, es_expr_heap)
+ = allocate_bound_var ap_array_var e_state.es_expr_heap
+ (bound_var_for_uselect_result, es_expr_heap)
+ = allocate_bound_var var_for_uselect_result es_expr_heap
+ (new_expr_ptr, es_expr_heap)
+ = newPtr EI_Empty es_expr_heap
+ (tuple_cons, cs)
+ = getPredefinedGlobalSymbol (GetTupleConsIndex 2) PD_PredefinedModule STE_Constructor 2 cs
+ (glob_select_symb, cs)
+ = getPredefinedGlobalSymbol PD_UnqArraySelectFun PD_StdArray STE_Member 2 cs
+ e_state
+ = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
+ (index_expr, free_vars, e_state, e_info, cs)
+ = checkExpression free_vars bind_dst e_input e_state e_info cs
+ selection
+ = ArraySelection glob_select_symb new_expr_ptr index_expr
+ = ( new_array_var
+ , strict_binds
+ , [ {bind_dst = var_for_uselect_result, bind_src = Selection No (Var bound_array_var) [selection]}
+ , {bind_dst = new_array_var, bind_src = TupleSelect tuple_cons.glob_object 1 (Var bound_var_for_uselect_result)}
+ , {bind_dst = array_element_var, bind_src = TupleSelect tuple_cons.glob_object 0 (Var bound_var_for_uselect_result)}
+ : lazy_binds
+ ]
+ , free_vars
+ , e_state
+ , e_info
+ , cs
+ )
+
+allocate_free_var ident var_heap
+ # (new_var_info_ptr, var_heap) = newPtr VI_Empty var_heap
+ = ({ fv_def_level = NotALevel, fv_name = ident, fv_info_ptr = new_var_info_ptr, fv_count = 0 }, var_heap)
+
checkFunctionBodies (ParsedBody [{pb_args,pb_rhs={rhs_alts,rhs_locals}} : bodies]) e_input=:{ei_expr_level,ei_mod_index}
e_state=:{es_var_heap, es_fun_defs} e_info cs
- # (aux_patterns, var_env, {ps_var_heap, ps_fun_defs}, e_info, cs)
- = check_patterns pb_args {pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False} []
+ # (aux_patterns, (var_env, array_patterns), {ps_var_heap, ps_fun_defs}, e_info, cs)
+ = check_patterns pb_args {pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False} ([], [])
{ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs
- # (rhs_expr, free_vars, e_state=:{es_dynamics=dynamics_in_rhs}, e_info, cs)
+ (rhs_expr, free_vars, e_state, e_info, cs)
= checkRhs [] rhs_alts rhs_locals e_input { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs } e_info cs
+ (dynamics_in_rhs, e_state)
+ = e_state!es_dynamics
+ (expr_with_array_selections, free_vars, e_state=:{es_var_heap}, e_info, cs)
+ = 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
- (cb_args, es_var_heap) = mapSt determine_function_arg aux_patterns e_state.es_var_heap
- (rhss, free_vars, e_state=:{es_dynamics,es_expression_heap,es_var_heap}, e_info, cs)
- = check_function_bodies free_vars cb_args bodies e_input { e_state & es_var_heap = es_var_heap, es_dynamics = [] } e_info
- { cs & cs_symbol_table = cs_symbol_table }
- (rhs, es_var_heap, es_expression_heap, dynamics_in_patterns, cs)
- = transform_patterns_into_cases aux_patterns cb_args rhs_expr es_var_heap es_expression_heap dynamics_in_rhs cs
+ (cb_args, es_var_heap) = mapSt determine_function_arg aux_patterns es_var_heap
+ (rhss, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
+ = check_function_bodies free_vars cb_args bodies e_input { e_state & es_dynamics = [], es_var_heap = es_var_heap } e_info
+ { cs & cs_symbol_table = cs_symbol_table }
+ (rhs, es_var_heap, es_expr_heap, dynamics_in_patterns, cs)
+ = transform_patterns_into_cases aux_patterns cb_args expr_with_array_selections es_var_heap es_expr_heap
+ dynamics_in_rhs cs
= (CheckedBody { cb_args = cb_args, cb_rhs = [rhs : rhss] }, free_vars,
- { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap, es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
-
+ { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap, es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
where
- check_patterns [pattern : patterns] p_input var_env var_store e_info cs
- # (aux_pat, var_env, var_store, e_info, cs) = checkPattern pattern No p_input var_env var_store e_info cs
- (aux_pats, var_env, var_store, e_info, cs) = check_patterns patterns p_input var_env var_store e_info cs
- = ([aux_pat : aux_pats], var_env, var_store, e_info, cs)
- check_patterns [] p_input var_env var_store e_info cs
- = ([], var_env, var_store, e_info, cs)
+ check_patterns [pattern : patterns] p_input accus var_store e_info cs
+ # (aux_pat, accus, var_store, e_info, cs) = checkPattern pattern No p_input accus var_store e_info cs
+ (aux_pats, accus, var_store, e_info, cs) = check_patterns patterns p_input accus var_store e_info cs
+ = ([aux_pat : aux_pats], accus, var_store, e_info, cs)
+ check_patterns [] p_input accus var_store e_info cs
+ = ([], accus, var_store, e_info, cs)
determine_function_arg (AP_Variable name var_info (Yes {bind_src, bind_dst})) var_store
= ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, var_store)
@@ -1979,17 +2113,19 @@ where
check_function_bodies free_vars fun_args [{pb_args,pb_rhs={rhs_alts,rhs_locals}} : bodies] e_input=:{ei_expr_level,ei_mod_index}
e_state=:{es_var_heap,es_fun_defs} e_info cs
- # (aux_patterns, var_env, {ps_var_heap, ps_fun_defs}, e_info, cs)
- = check_patterns pb_args { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } []
+ # (aux_patterns, (var_env, array_patterns), {ps_var_heap, ps_fun_defs}, e_info, cs)
+ = check_patterns pb_args { pi_def_level = ei_expr_level, pi_mod_index = ei_mod_index, pi_is_node_pattern = False } ([], [])
{ps_var_heap = es_var_heap, ps_fun_defs = es_fun_defs} e_info cs
e_state = { e_state & es_var_heap = ps_var_heap, es_fun_defs = ps_fun_defs}
- (rhs_expr, free_vars, e_state=:{es_dynamics=dynamics_in_rhs}, e_info, cs) = checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs
+ (rhs_expr, free_vars, e_state, e_info, cs) = checkRhs free_vars rhs_alts rhs_locals e_input e_state e_info cs
+ (rhs_expr, free_vars, e_state=:{es_dynamics=dynamics_in_rhs}, e_info, cs)
+ = 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
- (rhs_exprs, free_vars, e_state=:{es_dynamics,es_expression_heap,es_var_heap}, e_info, cs)
+ (rhs_exprs, free_vars, e_state=:{es_dynamics,es_expr_heap,es_var_heap}, e_info, cs)
= check_function_bodies free_vars fun_args bodies e_input { e_state & es_dynamics = [] } e_info { cs & cs_symbol_table = cs_symbol_table }
- (rhs_expr, es_var_heap, es_expression_heap, dynamics_in_patterns, cs)
- = transform_patterns_into_cases aux_patterns fun_args rhs_expr es_var_heap es_expression_heap dynamics_in_rhs cs
- = ([rhs_expr : rhs_exprs], free_vars, { e_state & es_var_heap = es_var_heap, es_expression_heap = es_expression_heap,
+ (rhs_expr, es_var_heap, es_expr_heap, dynamics_in_patterns, cs)
+ = transform_patterns_into_cases aux_patterns fun_args rhs_expr es_var_heap es_expr_heap dynamics_in_rhs cs
+ = ([rhs_expr : rhs_exprs], free_vars, { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap,
es_dynamics = dynamics_in_patterns ++ es_dynamics }, e_info, cs)
check_function_bodies free_vars fun_args [] e_input e_state e_info cs
= ([], free_vars, e_state, e_info, cs)
@@ -2101,14 +2237,14 @@ checkFunction mod_index fun_index def_level fun_defs
(fun_type, ef_type_defs, ef_class_defs, ef_modules, hp_var_heap, hp_type_heaps, cs)
= check_function_type fun_type mod_index ef_type_defs ef_class_defs ef_modules hp_var_heap hp_type_heaps cs
e_info = { e_info & ef_type_defs = ef_type_defs, ef_class_defs = ef_class_defs, ef_modules = ef_modules }
- e_state = { es_var_heap = hp_var_heap, es_expression_heap = hp_expression_heap, es_type_heaps = hp_type_heaps,
+ e_state = { es_var_heap = hp_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps,
es_dynamics = [], es_calls = [], es_fun_defs = fun_defs }
e_input = { ei_expr_level = inc def_level, ei_fun_index = fun_index, ei_fun_level = inc def_level, ei_mod_index = mod_index }
(fun_body, free_vars, e_state, e_info, cs) = checkFunctionBodies fun_body e_input e_state e_info cs
- # {es_fun_defs,es_calls,es_var_heap,es_expression_heap,es_type_heaps,es_dynamics} = e_state
- (ef_type_defs, ef_modules, es_type_heaps, es_expression_heap, cs) =
- checkDynamicTypes mod_index es_dynamics fun_type e_info.ef_type_defs e_info.ef_modules es_type_heaps es_expression_heap cs
+ # {es_fun_defs,es_calls,es_var_heap,es_expr_heap,es_type_heaps,es_dynamics} = e_state
+ (ef_type_defs, ef_modules, es_type_heaps, es_expr_heap, cs) =
+ checkDynamicTypes mod_index es_dynamics fun_type e_info.ef_type_defs e_info.ef_modules es_type_heaps es_expr_heap cs
cs = { cs & cs_error = popErrorAdmin cs.cs_error }
fun_info = { fun_def.fun_info & fi_calls = es_calls, fi_def_level = def_level, fi_free_vars = free_vars, fi_dynamics = es_dynamics,
fi_is_macro_fun = ef_is_macro_fun }
@@ -2116,7 +2252,7 @@ checkFunction mod_index fun_index def_level fun_defs
(fun_defs, cs_symbol_table) = remove_calls_from_symbol_table fun_index def_level es_calls fun_defs cs.cs_symbol_table
= (fun_defs,
{ e_info & ef_type_defs = ef_type_defs, ef_modules = ef_modules },
- { heaps & hp_var_heap = es_var_heap, hp_expression_heap = es_expression_heap, hp_type_heaps = es_type_heaps },
+ { heaps & hp_var_heap = es_var_heap, hp_expression_heap = es_expr_heap, hp_type_heaps = es_type_heaps },
{ cs & cs_symbol_table = cs_symbol_table })
where
@@ -2208,19 +2344,20 @@ checkCommonDefinitions is_dcl module_index common modules type_heaps var_heap cs
collectCommonfinitions :: !(CollectedDefinitions ClassInstance a) -> (!*{# Int}, ![Declaration])
collectCommonfinitions {def_types,def_constructors,def_selectors,def_macros,def_classes,def_members,def_instances}
+ // MW: the order in which the declarations appear in the returned list is essential (explicit imports)
# sizes = createArray cConversionTableSize 0
- (size, defs) = foldSt type_def_to_dcl def_types (0, [])
- sizes = { sizes & [cTypeDefs] = size }
- (size, defs) = foldSt cons_def_to_dcl def_constructors (0, defs)
+ (size, defs) = foldSt cons_def_to_dcl def_constructors (0, [])
sizes = { sizes & [cConstructorDefs] = size }
(size, defs) = foldSt selector_def_to_dcl def_selectors (0, defs)
sizes = { sizes & [cSelectorDefs] = size }
+ (size, defs) = foldSt type_def_to_dcl def_types (0, defs)
+ sizes = { sizes & [cTypeDefs] = size }
(size, defs) = foldSt class_def_to_dcl def_classes (0, defs)
sizes = { sizes & [cClassDefs] = size }
- (size, defs) = foldSt member_def_to_dcl def_members (0, defs)
- sizes = { sizes & [cMemberDefs] = size }
(size, defs) = foldSt instance_def_to_dcl def_instances (0, defs)
sizes = { sizes & [cInstanceDefs] = size }
+ (size, defs) = foldSt member_def_to_dcl def_members (0, defs)
+ sizes = { sizes & [cMemberDefs] = size }
= (sizes, defs)
where
type_def_to_dcl {td_name, td_pos} (dcl_index, decls)
@@ -2453,8 +2590,6 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
heaps = { heaps & hp_expression_heap=hp_expression_heap }
- (main_dcl_module, dcl_modules) = dcl_modules![cIclModIndex]
-
(icl_common, dcl_modules, hp_type_heaps, hp_var_heap, cs)
= checkCommonDefinitions cIsNotADclModule cIclModIndex icl_common dcl_modules heaps.hp_type_heaps heaps.hp_var_heap cs
@@ -2474,12 +2609,13 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
(icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error})
= checkInstanceBodies {ir_from = first_inst_index, ir_to = nr_of_functions} icl_functions e_info heaps cs
+
(icl_imported, dcl_modules, cs_symbol_table) = retrieveImportsFromSymbolTable mod_imports [] e_info.ef_modules cs_symbol_table
| cs_error.ea_ok
- # {hp_var_heap,hp_type_heaps,hp_expression_heap} = heaps
+ # {hp_var_heap,hp_type_heaps=hp_type_heaps=:{th_vars},hp_expression_heap} = heaps
(spec_functions, dcl_modules, class_instances, icl_functions, new_nr_of_functions, dcl_icl_conversions, var_heap, th_vars, expr_heap)
= collect_specialized_functions_in_dcl_module dcl_modules icl_common.com_instance_defs icl_functions nr_of_functions
- hp_var_heap hp_type_heaps.th_vars hp_expression_heap
+ hp_var_heap th_vars hp_expression_heap
icl_global_function_range = {ir_from = 0, ir_to = nr_of_global_funs}
icl_instances = {ir_from = first_inst_index, ir_to = nr_of_functions}
icl_specials = {ir_from = nr_of_functions, ir_to = new_nr_of_functions}
@@ -2496,9 +2632,13 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs
icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common, icl_instances = icl_instances, icl_specials = icl_specials,
icl_imported_objects = mod_imported_objects,
icl_declared = {dcls_local = local_defs, dcls_import = icl_imported, dcls_explicit = dcls_explicit} }
- = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions,
- { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = { hp_type_heaps & th_vars = th_vars }},
- cs_predef_symbols, cs_symbol_table, cs_error.ea_file)
+
+ heaps = { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}}
+
+ (dcl_modules, icl_mod, heaps, cs_error)
+ = compareDefImp dcl_modules icl_mod heaps cs_error // MW++
+
+ = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file)
# icl_common = { icl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs,
com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs }
icl_mod = { icl_name = mod_name, icl_functions = icl_functions, icl_common = icl_common,
@@ -2814,18 +2954,12 @@ initialDclModule ({mod_name, mod_defs=mod_defs=:{def_funtypes,def_macros}, mod_t
checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions heaps=:{hp_var_heap, hp_type_heaps} cs
#! dcl_mod = modules.[mod_index]
# dcl_defined = dcl_mod.dcl_declared.dcls_local
-
- // createCommonDefinitions only converts lists into arrays
-
- dcl_common = createCommonDefinitions mod_defs
- dcl_macros = mod_defs.def_macros
- (imports, modules, cs) = collect_imported_symbols mod_imports [] modules { cs & cs_needed_modules = 0 }
-
- // imports :: [(Index,Declarations)]
-
- # cs = add_imported_symbols_to_symbol_table imports cs
+ dcl_common = createCommonDefinitions mod_defs
+ dcl_macros = mod_defs.def_macros
+ (imports, modules, cs) = collect_imported_symbols mod_imports [] modules cs
+ cs = add_imported_symbols_to_symbol_table imports cs
cs = addGlobalDefinitionsToSymbolTable dcl_defined cs
-
+ cs = { cs & cs_needed_modules = 0 }
nr_of_dcl_functions = size dcl_mod.dcl_functions
(dcl_common, modules, hp_type_heaps, hp_var_heap, cs)
@@ -3016,6 +3150,11 @@ allocate_bound_var {fv_name, fv_info_ptr} expr_heap
# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= ({ var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, expr_heap)
+allocate_bound_var` :: !Ident !VarInfoPtr !*ExpressionHeap -> (!BoundVar, !.ExpressionHeap)
+allocate_bound_var` fv_name fv_info_ptr expr_heap
+ # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
+ = ({ var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = var_expr_ptr }, expr_heap)
+
instance <<< FunCall
where
(<<<) file {fc_index} = file <<< fc_index
@@ -3050,10 +3189,6 @@ instance <<< DefinedSymbol
where
(<<<) file { ds_index, ds_ident } = file <<< ds_ident <<< '.' <<< ds_index
-instance <<< FreeVar
-where
- (<<<) file { fv_name } = file <<< fv_name
-
instance <<< FieldSymbol
where
(<<<) file { fs_var } = file <<< fs_var
@@ -3068,7 +3203,7 @@ where
(<<<) file (SP_ParsedSubstitutions _) = file <<< "SP_ParsedSubstitutions"
(<<<) file (SP_Substitutions substs) = file <<< "SP_Substitutions " <<< substs
(<<<) file (SP_ContextTypes specials) = file <<< "SP_ContextTypes " <<< specials
- (<<<) file (SP_FunIndex _) = file <<< "SP_ParsedSubstitutions"
+ (<<<) file (SP_FunIndex _) = file <<< "SP_ParsedSubstitutions"
(<<<) file SP_None = file <<< "SP_None"
instance <<< Special
@@ -3080,18 +3215,10 @@ instance <<< SpecialSubstitution
where
(<<<) file {ss_environ} = file <<< ss_environ
-instance <<< Declaration
-where
- (<<<) file { dcl_ident } = file <<< dcl_ident
-
instance <<< Ptr a
where
(<<<) file ptr = file <<< "[[" <<< ptrToInt ptr <<< "]]"
-instance <<< LocalDefs
-where
- (<<<) file (CollectedLocalDefs { loc_functions={ir_from,ir_to} }) = file <<< ir_from <<< '-' <<< ir_to
-
retrieveGlobalDefinition :: !SymbolTableEntry !STE_Kind !Index -> (!Index, !Index)
retrieveGlobalDefinition {ste_kind = STE_Imported kind dcl_index, ste_def_level, ste_index} requ_kind mod_index
| kind == requ_kind
diff --git a/frontend/checksupport.dcl b/frontend/checksupport.dcl
index 50a3f3d..1824265 100644
--- a/frontend/checksupport.dcl
+++ b/frontend/checksupport.dcl
@@ -120,8 +120,7 @@ instance toIdent ConsDef, TypeDef a, ClassDef, MemberDef, FunDef, SelectorDef //
instance toIdent SymbIdent, TypeSymbIdent, BoundVar, TypeVar, ATypeVar, Ident
instance toInt STE_Kind
-instance <<< STE_Kind
-instance <<< IdentPos
+instance <<< STE_Kind, IdentPos, Declaration
retrieveAndRemoveImportsFromSymbolTable :: ![(.a,.Declarations)] [Declaration] *(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry);
retrieveAndRemoveImportsOfModuleFromSymbolTable :: ![.Declaration] ![.Declaration] ![.Declaration] !*(Heap SymbolTableEntry) -> ([Declaration],.Heap SymbolTableEntry);
diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl
index 476dc57..f9ede20 100644
--- a/frontend/checksupport.icl
+++ b/frontend/checksupport.icl
@@ -527,4 +527,8 @@ where
STE_Empty
= file <<< "STE_Empty"
+instance <<< Declaration
+ where
+ (<<<) file { dcl_ident }
+ = file <<< dcl_ident
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl
index 4802ced..a94f7fa 100644
--- a/frontend/checktypes.icl
+++ b/frontend/checktypes.icl
@@ -256,7 +256,7 @@ CS_Checking :== 0
}
-class expand a :: !Index !a !*SynTypeInfo !*CheckState -> (!a, !TypeAttribute, !*SynTypeInfo, !*CheckState)
+class expand a :: !Index !a !*SynTypeInfo !*CheckState -> (!a, !*SynTypeInfo, !*CheckState)
expandTypeVariable :: TypeVar !*SynTypeInfo !*CheckState -> (!Type, !TypeAttribute, !*SynTypeInfo, !*CheckState)
expandTypeVariable {tv_name={id_info}} sti cs=:{cs_symbol_table}
@@ -267,29 +267,30 @@ expandTypeVariable {tv_name={id_info}} sti cs=:{cs_symbol_table}
instance expand Type
where
expand module_index (TV tv) sti cs
- = expandTypeVariable tv sti cs
+ # (type, _, sti, cs) = expandTypeVariable tv sti cs
+ = (type, sti, cs)
expand module_index type=:(TA type_cons=:{type_name,type_index={glob_object,glob_module}} types) sti=:{sti_marks} cs=:{cs_error,cs_symbol_table}
| module_index == glob_module
#! mark = sti_marks.[glob_object]
| mark == CS_NotChecked
# (sti, cs) = expandSynType module_index glob_object sti cs
- (types, attr, sti, cs) = expand module_index types sti cs
- = (TA type_cons types, attr, sti, cs)
+ (types, sti, cs) = expand module_index types sti cs
+ = (TA type_cons types, sti, cs)
| mark == CS_Checked
- # (types, attr, sti, cs) = expand module_index types sti cs
- = (TA type_cons types, attr, sti, cs)
+ # (types, sti, cs) = expand module_index types sti cs
+ = (TA type_cons types, sti, cs)
// | mark == CS_Checking
- = (type, TA_None, sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error })
- # (types, attr, sti, cs) = expand module_index types sti cs
- = (TA type_cons types, attr, sti, cs)
+ = (type, sti, { cs & cs_error = checkError type_name "cyclic dependency between type synonyms" cs_error })
+ # (types, sti, cs) = expand module_index types sti cs
+ = (TA type_cons types, sti, cs)
expand module_index (arg_type --> res_type) sti cs
- # (arg_type, _, sti, cs) = expand module_index arg_type sti cs
- (res_type, _, sti, cs) = expand module_index res_type sti cs
- = (arg_type --> res_type, TA_None, sti, cs)
+ # (arg_type, sti, cs) = expand module_index arg_type sti cs
+ (res_type, sti, cs) = expand module_index res_type sti cs
+ = (arg_type --> res_type, sti, cs)
expand module_index (CV tv :@: types) sti cs
- # (type, type_attr, sti, cs) = expandTypeVariable tv sti cs
- (types, _, sti, cs) = expand module_index types sti cs
- = (simplify_type_appl type types, type_attr, sti, cs)
+ # (type, _, sti, cs) = expandTypeVariable tv sti cs
+ (types, sti, cs) = expand module_index types sti cs
+ = (simplify_type_appl type types, sti, cs)
where
simplify_type_appl :: !Type ![AType] -> Type
simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args
@@ -297,22 +298,25 @@ where
simplify_type_appl (TV tv) type_args
= CV tv :@: type_args
expand module_index type sti cs
- = (type, TA_None, sti, cs)
+ = (type, sti, cs)
instance expand [a] | expand a
where
expand module_index [x:xs] sti cs
- # (x, _, sti, cs) = expand module_index x sti cs
- (xs, _, sti, cs) = expand module_index xs sti cs
- = ([x:xs], TA_None, sti, cs)
+ # (x, sti, cs) = expand module_index x sti cs
+ (xs, sti, cs) = expand module_index xs sti cs
+ = ([x:xs], sti, cs)
expand module_index [] sti cs
- = ([], TA_None, sti, cs)
+ = ([], sti, cs)
instance expand AType
where
+ expand module_index atype=:{at_type=(TV tv)} sti cs
+ # (at_type, attr, sti, cs) = expandTypeVariable tv sti cs
+ = ({ atype & at_type = at_type, at_attribute = attr }, sti, cs)
expand module_index atype=:{at_type} sti cs
- # (at_type, attr, sti, cs) = expand module_index at_type sti cs
- = ({ atype & at_type = at_type, at_attribute = attr }, attr, sti, cs)
+ # (at_type, sti, cs) = expand module_index at_type sti cs
+ = ({ atype & at_type = at_type }, sti, cs)
class look_for_cycles a :: !Index !a !(!*SynTypeInfo, !*CheckState) -> (!*SynTypeInfo, !*CheckState)
@@ -357,7 +361,7 @@ expandSynType mod_index type_index sti=:{sti_type_defs,sti_marks,sti_modules} cs
position = newPosition type_def.td_name type_def.td_pos
cs_error = pushErrorAdmin position cs.cs_error
sti_marks = { sti_marks & [type_index] = CS_Checking }
- (exp_type, _, sti, cs) = expand mod_index rhs_type.at_type
+ (exp_type, sti, cs) = expand mod_index rhs_type.at_type
{ sti_type_defs = sti_type_defs, sti_modules = sti_modules, sti_marks = sti_marks }
{ cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }
-> ({sti & sti_type_defs = { sti.sti_type_defs & [type_index] = { type_def & td_rhs = SynType { type & at_type = exp_type }}},
@@ -924,9 +928,11 @@ checkSpecialTypes mod_index SP_None type_defs modules heaps cs
= (SP_None, type_defs, modules, heaps, cs)
+/* MW: already defined in module syntax
instance <<< SelectorDef
where
(<<<) file {sd_symb} = file <<< sd_symb
+*/
instance <<< AttrInequality
where
diff --git a/frontend/comparedefimp.dcl b/frontend/comparedefimp.dcl
new file mode 100644
index 0000000..b9a582f
--- /dev/null
+++ b/frontend/comparedefimp.dcl
@@ -0,0 +1,9 @@
+definition module comparedefimp
+
+import syntax, checksupport
+
+// compare definition and implementation module
+
+compareDefImp :: !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin
+ -> (!.{# DclModule}, !.IclModule,!.Heaps,!.ErrorAdmin);
+
diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl
new file mode 100644
index 0000000..b95b213
--- /dev/null
+++ b/frontend/comparedefimp.icl
@@ -0,0 +1,964 @@
+implementation module comparedefimp
+
+/* compare definition and implementation module
+
+ Difficulty: The icl module's type definitions have been tranformed during checking while
+ the dcl module's type definitions have not. When the root of the rhs of a (icl) type definition was
+ originally an application of a synonym type then this type will have been expanded. The comparision
+ algorithm performs expansion of _dcl_ synonym types 'on the fly' by binding lhs argument type variables
+ to the types of the actual type application. e.g.
+
+ dcl: icl:
+
+ :: T1 :== T2 Int :: T1 :== Int // previously expanded, was originally :: T1 :== T2 Int
+ :: T2 x :== x :: T2 y :== y
+
+ causes x to be bound to Int while processing type T1.
+
+ While T2 is processed x and y will be bound to a correspondence number to abstract from variable names
+ (see type HeapWithNumber). The same happens with attribute variables and variables in macros/functions.
+*/
+
+import syntax, checksupport, compare_constructor, utilities, StdCompare
+import RWSDebug
+
+:: TypesCorrespondState =
+ { tc_type_vars
+ :: !.HeapWithNumber TypeVarInfo
+ , tc_attr_vars
+ :: !.HeapWithNumber AttrVarInfo
+ , tc_dcl_modules
+ :: !.{#DclModule}
+ , tc_icl_type_defs
+ :: !{CheckedTypeDef}
+ , tc_type_conversions
+ :: !Conversions
+ , tc_visited_syn_types // to detect cycles in type synonyms
+ :: !.{#Bool}
+ }
+
+:: TypesCorrespondMonad
+ :== !*TypesCorrespondState -> (!Bool, !*TypesCorrespondState)
+
+:: ExpressionsCorrespondState =
+ { ec_correspondences // ec_correspondences.[i]==j <=> (functions i and j are already compared
+ :: !.{# Int } // || j==cNoCorrespondence)
+ , ec_var_heap
+ :: !.HeapWithNumber VarInfo
+ , ec_expr_heap
+ :: !.ExpressionHeap
+ , ec_icl_functions
+ :: !.{# FunDef }
+ , ec_error_admin
+ :: !.ErrorAdmin
+ , ec_tc_state
+ :: !.TypesCorrespondState
+ }
+
+:: ExpressionsCorrespondMonad
+ :== !*ExpressionsCorrespondState -> *ExpressionsCorrespondState
+
+:: Conversions :== {#Index}
+
+:: HeapWithNumber a
+ = { hwn_heap
+ :: !.Heap a
+ , hwn_number
+ :: !Int
+ }
+
+class t_corresponds a :: a a -> *TypesCorrespondMonad
+ // whether two types correspond
+class e_corresponds a :: !a !a -> ExpressionsCorrespondMonad
+ // check for correspondence of expressions
+
+class getIdentPos a :: a -> IdentPos
+
+class CorrespondenceNumber a where
+ toCorrespondenceNumber :: .a -> Optional Int
+ fromCorrespondenceNumber :: Int -> .a
+
+initial_hwn hwn_heap = { hwn_heap = hwn_heap, hwn_number = 0 }
+
+compareDefImp :: !*{# DclModule} !*IclModule !*Heaps !*ErrorAdmin
+ -> (!.{# DclModule}, !.IclModule,!.Heaps,!.ErrorAdmin);
+compareDefImp dcl_modules icl_module heaps error_admin
+ # (main_dcl_module, dcl_modules) = dcl_modules![cIclModIndex]
+ = case main_dcl_module.dcl_conversions of
+ No -> (dcl_modules, icl_module, heaps, error_admin)
+ Yes conversion_table
+ # {dcl_functions, dcl_macros, dcl_common, dcl_instances} = main_dcl_module
+ {icl_common, icl_functions}
+ = icl_module
+ {hp_var_heap, hp_expression_heap, hp_type_heaps={th_vars, th_attrs}}
+ = heaps
+ { com_type_defs=icl_com_type_defs, com_cons_defs=icl_com_cons_defs,
+ com_selector_defs=icl_com_selector_defs, com_class_defs=icl_com_class_defs,
+ com_member_defs=icl_com_member_defs, com_instance_defs = icl_com_instance_defs }
+ = icl_common
+ (icl_type_defs, icl_com_type_defs) = copy icl_com_type_defs
+ tc_state
+ = { tc_type_vars = initial_hwn th_vars
+ , tc_attr_vars = initial_hwn th_attrs
+ , tc_dcl_modules = dcl_modules
+ , tc_icl_type_defs = icl_type_defs
+ , tc_type_conversions = conversion_table.[cTypeDefs]
+ , tc_visited_syn_types = createArray (size dcl_common.com_type_defs) False
+ }
+ (icl_com_type_defs, tc_state, error_admin)
+ = compareWithConversions conversion_table.[cTypeDefs]
+ dcl_common.com_type_defs icl_com_type_defs tc_state error_admin
+ (icl_com_cons_defs, tc_state, error_admin)
+ = compareWithConversions conversion_table.[cConstructorDefs]
+ dcl_common.com_cons_defs icl_com_cons_defs tc_state error_admin
+ (icl_com_selector_defs, tc_state, error_admin)
+ = compareWithConversions conversion_table.[cSelectorDefs]
+ dcl_common.com_selector_defs icl_com_selector_defs tc_state error_admin
+ (icl_com_member_defs, tc_state, error_admin)
+ = compareWithConversions conversion_table.[cMemberDefs]
+ dcl_common.com_member_defs icl_com_member_defs tc_state error_admin
+ (icl_com_class_defs, tc_state, error_admin)
+ = compareWithConversions conversion_table.[cClassDefs]
+ dcl_common.com_class_defs icl_com_class_defs tc_state error_admin
+ (icl_com_instance_defs, tc_state, error_admin)
+ = compareWithConversions conversion_table.[cInstanceDefs]
+ dcl_common.com_instance_defs icl_com_instance_defs tc_state error_admin
+ (icl_functions, hp_var_heap, hp_expression_heap, tc_state, error_admin)
+ = compareMacrosWithConversion conversion_table.[cMacroDefs] dcl_macros
+ icl_functions hp_var_heap hp_expression_heap tc_state error_admin
+ (icl_functions, tc_state, error_admin)
+ = compareFunctionTypesWithConversions conversion_table.[cFunctionDefs]
+ dcl_functions icl_functions tc_state error_admin
+ { tc_type_vars, tc_attr_vars, tc_dcl_modules }
+ = tc_state
+ icl_common
+ = { icl_common & com_type_defs=icl_com_type_defs, com_cons_defs=icl_com_cons_defs,
+ com_selector_defs=icl_com_selector_defs, com_class_defs=icl_com_class_defs,
+ com_member_defs=icl_com_member_defs, com_instance_defs = icl_com_instance_defs }
+ heaps
+ = { hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap,
+ hp_type_heaps = { th_vars = tc_type_vars.hwn_heap, th_attrs = tc_attr_vars.hwn_heap}}
+ -> ( tc_dcl_modules, { icl_module & icl_common = icl_common, icl_functions = icl_functions },
+ heaps, error_admin )
+ where
+ copy original
+ #! size = size original
+ # new = createArray size (abort "don't make that array strict !")
+ = memcpy size new original
+ memcpy :: !Int !*{CheckedTypeDef} !*{#CheckedTypeDef} -> (!.{CheckedTypeDef}, !.{#CheckedTypeDef})
+ memcpy 0 dst src
+ = (dst, src)
+ memcpy i dst src
+ # i1 = i-1
+ (src_i1, src) = src![i1]
+ = memcpy i1 { dst & [i1] = src_i1 } src
+
+compareWithConversions conversions dclDefs iclDefs tc_state error_admin
+ = iFoldSt (compareWithConversion conversions dclDefs) 0 (size conversions) (iclDefs, tc_state, error_admin)
+
+compareWithConversion conversions dclDefs dclIndex (iclDefs, tc_state, error_admin)
+ # (iclDef, iclDefs) = iclDefs![conversions.[dclIndex]]
+ (corresponds, tc_state) = t_corresponds dclDefs.[dclIndex] iclDef tc_state
+ | corresponds
+ = (iclDefs, tc_state, error_admin)
+ = generate_error error_message iclDef iclDefs tc_state error_admin
+
+compareFunctionTypesWithConversions conversions dcl_fun_types icl_functions tc_state error_admin
+ = iFoldSt (compareTwoFunctionTypes conversions dcl_fun_types) 0 (size conversions)
+ (icl_functions, tc_state, error_admin)
+
+compareTwoFunctionTypes conversions dcl_fun_types dclIndex (icl_functions, tc_state, error_admin)
+ # (fun_def=:{fun_type}, icl_functions) = icl_functions![conversions.[dclIndex]]
+ = case fun_type of
+ No -> generate_error "type of exported function is missing" fun_def icl_functions tc_state error_admin
+ Yes icl_symbol_type
+ # dcl_symbol_type = dcl_fun_types.[dclIndex].ft_type
+ tc_state = init_attr_vars (dcl_symbol_type.st_attr_vars++icl_symbol_type.st_attr_vars)
+ tc_state
+ tc_type_vars = init_type_vars (dcl_symbol_type.st_vars++icl_symbol_type.st_vars)
+ tc_state.tc_type_vars
+ (corresponds, tc_state)
+ = t_corresponds dcl_symbol_type icl_symbol_type { tc_state & tc_type_vars = tc_type_vars }
+ | corresponds
+ -> (icl_functions, tc_state, error_admin)
+ -> generate_error error_message fun_def icl_functions tc_state error_admin
+
+init_type_vars type_vars tc_type_vars=:{hwn_heap}
+ # hwn_heap = foldSt init_type_var type_vars hwn_heap
+ = { tc_type_vars & hwn_heap = hwn_heap }
+init_type_var {tv_info_ptr} heap
+ = writePtr tv_info_ptr TVI_Empty heap
+
+generate_error message iclDef iclDefs tc_state error_admin
+ # ident_pos = getIdentPos iclDef
+ error_admin = pushErrorAdmin ident_pos error_admin
+ error_admin = checkError ident_pos.ip_ident message error_admin
+ = (iclDefs, tc_state, popErrorAdmin error_admin)
+
+compareMacrosWithConversion conversions macro_range icl_functions var_heap expr_heap tc_state error_admin
+ #! nr_of_functions = size icl_functions
+ # correspondences = createArray nr_of_functions cNoCorrespondence
+ ec_state = { ec_correspondences = correspondences, ec_var_heap = initial_hwn var_heap,
+ ec_expr_heap = expr_heap, ec_icl_functions = icl_functions,
+ ec_error_admin = error_admin, ec_tc_state = tc_state }
+ ec_state = iFoldSt (compareMacroWithConversion conversions macro_range.ir_from) macro_range.ir_from macro_range.ir_to
+ ec_state
+ {ec_icl_functions, ec_var_heap, ec_expr_heap, ec_error_admin, ec_tc_state} = ec_state
+ = (ec_icl_functions, ec_var_heap.hwn_heap, ec_expr_heap, ec_tc_state, ec_error_admin)
+
+compareMacroWithConversion conversions ir_from dclIndex ec_state
+ = compareTwoMacroFuns dclIndex conversions.[dclIndex-ir_from] ec_state
+
+compareTwoMacroFuns dclIndex iclIndex
+ ec_state=:{ec_correspondences, ec_icl_functions, ec_error_admin}
+ # (dcl_function, ec_icl_functions) = ec_icl_functions![dclIndex]
+ (icl_function, ec_icl_functions) = ec_icl_functions![iclIndex]
+ ec_correspondences = { ec_correspondences & [dclIndex]=iclIndex, [iclIndex]=dclIndex }
+ ident_pos = getIdentPos dcl_function
+ ec_error_admin = pushErrorAdmin ident_pos ec_error_admin
+ ec_state = { ec_state & ec_correspondences = ec_correspondences,
+ ec_icl_functions = ec_icl_functions, ec_error_admin = ec_error_admin }
+ ec_state = e_corresponds dcl_function icl_function ec_state
+ = { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin }
+
+instance getIdentPos (TypeDef a) where
+ getIdentPos {td_name, td_pos}
+ = makeIdentPos td_name td_pos
+
+instance getIdentPos ConsDef where
+ getIdentPos {cons_symb, cons_pos}
+ = makeIdentPos cons_symb cons_pos
+
+instance getIdentPos SelectorDef where
+ getIdentPos {sd_symb, sd_pos}
+ = makeIdentPos sd_symb sd_pos
+
+instance getIdentPos ClassDef where
+ getIdentPos {class_name, class_pos}
+ = makeIdentPos class_name class_pos
+
+instance getIdentPos MemberDef where
+ getIdentPos {me_symb, me_pos}
+ = makeIdentPos me_symb me_pos
+
+instance getIdentPos ClassInstance where
+ getIdentPos {ins_ident, ins_pos}
+ = makeIdentPos ins_ident ins_pos
+
+instance getIdentPos FunDef where
+ getIdentPos {fun_symb, fun_pos}
+ = makeIdentPos fun_symb fun_pos
+
+makeIdentPos ident (FunPos fileName lineNr _)
+ = { ip_ident=ident, ip_line=lineNr, ip_file=fileName}
+makeIdentPos ident (LinePos fileName lineNr)
+ = { ip_ident=ident, ip_line=lineNr, ip_file=fileName}
+makeIdentPos ident NoPos
+ = { ip_ident=ident, ip_line=0, ip_file=""}
+
+instance CorrespondenceNumber VarInfo where
+ toCorrespondenceNumber (VI_CorrespondenceNumber number)
+ = Yes number
+ toCorrespondenceNumber _
+ = No
+
+ fromCorrespondenceNumber number
+ = VI_CorrespondenceNumber number
+
+instance CorrespondenceNumber TypeVarInfo where
+ toCorrespondenceNumber (TVI_CorrespondenceNumber number)
+ = Yes number
+ toCorrespondenceNumber _
+ = No
+
+ fromCorrespondenceNumber number
+ = TVI_CorrespondenceNumber number
+
+instance CorrespondenceNumber AttrVarInfo where
+ toCorrespondenceNumber (AVI_CorrespondenceNumber number)
+ = Yes number
+ toCorrespondenceNumber _
+ = No
+
+ fromCorrespondenceNumber number
+ = AVI_CorrespondenceNumber number
+
+assignCorrespondenceNumber ptr1 ptr2 {hwn_heap, hwn_number}
+ = let var_info = fromCorrespondenceNumber hwn_number
+ in { hwn_heap
+ = writePtr ptr1 var_info (writePtr ptr2 var_info hwn_heap)
+ , hwn_number
+ = hwn_number + 1
+ }
+
+tryToUnifyVars ptr1 ptr2 heapWithNumber
+ #! info1 = sreadPtr ptr1 heapWithNumber.hwn_heap
+ info2 = sreadPtr ptr2 heapWithNumber.hwn_heap
+ = case (toCorrespondenceNumber info1, toCorrespondenceNumber info2) of
+ (Yes number1, Yes number2)
+ -> (number1==number2, heapWithNumber)
+ (No, No)
+ -> (True, assignCorrespondenceNumber ptr1 ptr2 heapWithNumber)
+ _ -> (False, heapWithNumber)
+
+instance t_corresponds [a] | t_corresponds a where
+ t_corresponds [] []
+ = return True
+ t_corresponds [dclDef:dclDefs] [iclDef:iclDefs]
+ = t_corresponds dclDef iclDef
+ &&& t_corresponds dclDefs iclDefs
+ t_corresponds _ _
+ = return False
+
+instance t_corresponds {# a} | t_corresponds , select_u , size_u a where
+ t_corresponds dclArray iclArray
+ # size_dclArray = size dclArray
+ | size_dclArray<>size iclArray
+ = return False
+ = loop (size_dclArray-1) dclArray iclArray
+ where
+ loop i dclArray iclArray
+ | i<0
+ = return True
+ = t_corresponds dclArray.[i] iclArray.[i]
+ &&& loop (i-1) dclArray iclArray
+
+instance t_corresponds (Optional a) | t_corresponds a where
+ t_corresponds No No
+ = return True
+ t_corresponds (Yes dclYes) (Yes iclYes)
+ = t_corresponds dclYes iclYes
+ t_corresponds _ _
+ = return False
+
+instance t_corresponds (Global DefinedSymbol) where
+ t_corresponds dclDef iclDef
+ = t_corresponds dclDef.glob_object iclDef.glob_object
+ &&& equal dclDef.glob_module iclDef.glob_module
+
+instance t_corresponds (TypeDef TypeRhs) where
+ t_corresponds dclDef iclDef
+ = t_corresponds_TypeDef dclDef iclDef
+ where
+ t_corresponds_TypeDef dclDef iclDef tc_state
+ // sanity check ...
+ | dclDef.td_arity <> length dclDef.td_args
+ = undef <<- "t_corresponds (TypeDef): dclDef.td_arity <> length dclDef.td_args"
+ | iclDef.td_arity <> length iclDef.td_args
+ = undef <<- "t_corresponds (TypeDef): iclDef.td_arity <> length iclDef.td_args"
+ // ... sanity check
+ # tc_state = { tc_state & tc_visited_syn_types.[dclDef.td_index] = True }
+ tc_state = init_atv_variables dclDef.td_args iclDef.td_args tc_state
+ (corresponds, tc_state) = t_corresponds dclDef.td_args iclDef.td_args tc_state
+ | not corresponds
+ = (corresponds, tc_state)
+ # tc_state = init_attr_vars (dclDef.td_attrs++iclDef.td_attrs) tc_state
+ icl_root_has_anonymous_attr = root_has_anonymous_attr iclDef.td_attribute iclDef.td_rhs
+ | icl_root_has_anonymous_attr<>root_has_anonymous_attr dclDef.td_attribute dclDef.td_rhs
+ && isnt_abstract dclDef.td_rhs
+ = (False, tc_state)
+ # coerced_icl_rhs = if icl_root_has_anonymous_attr (coerce iclDef.td_rhs) iclDef.td_rhs
+ (corresponds, tc_state) = t_corresponds dclDef.td_rhs coerced_icl_rhs tc_state
+ tc_state = { tc_state & tc_visited_syn_types.[dclDef.td_index] = False }
+ | not corresponds
+ = (corresponds, tc_state)
+ # (corresponds, tc_state) = t_corresponds dclDef.td_context iclDef.td_context tc_state
+ | not corresponds
+ = (corresponds, tc_state)
+ = t_corresponds dclDef.td_attribute iclDef.td_attribute tc_state
+
+ root_has_anonymous_attr (TA_Var lhs_attr_var) syn_type=:(SynType a_type=:{at_attribute=TA_Var rhs_attr_var})
+ = rhs_attr_var.av_info_ptr==lhs_attr_var.av_info_ptr
+ root_has_anonymous_attr _ _
+ = False
+
+ coerce (SynType atype)
+ = SynType { atype & at_attribute = TA_Anonymous }
+
+ isnt_abstract (AbstractType _) = False
+ isnt_abstract _ = True
+
+init_atv_variables [dcl_type_var:dcl_type_vars] [icl_type_var:icl_type_vars]
+ tc_state=:{tc_type_vars}
+ # tc_type_vars
+ = assignCorrespondenceNumber dcl_type_var.atv_variable.tv_info_ptr
+ icl_type_var.atv_variable.tv_info_ptr tc_type_vars
+ = init_atv_variables dcl_type_vars icl_type_vars { tc_state & tc_type_vars = tc_type_vars }
+init_atv_variables _ _ tc_state
+ = tc_state
+
+instance t_corresponds TypeContext where
+ t_corresponds dclDef iclDef
+ = t_corresponds dclDef.tc_class iclDef.tc_class
+ &&& t_corresponds dclDef.tc_types iclDef.tc_types
+
+instance t_corresponds DefinedSymbol where
+ t_corresponds dclDef iclDef
+ = equal dclDef.ds_ident iclDef.ds_ident
+
+instance t_corresponds ATypeVar where
+ t_corresponds dclDef iclDef
+ = t_corresponds dclDef.atv_attribute iclDef.atv_attribute
+ &&& equal dclDef.atv_annotation iclDef.atv_annotation
+ &&& t_corresponds dclDef.atv_variable iclDef.atv_variable
+
+instance t_corresponds AType where
+ t_corresponds dclDef iclDef
+ = t_corresponds_at_type dclDef iclDef
+ where
+ t_corresponds_at_type dclDef iclDef tc_state
+ # (corresponds, tc_state) = simple_corresponds dclDef iclDef tc_state
+ | corresponds
+ = (corresponds, tc_state)
+ = case dclDef.at_type of
+ TA dcl_type_symb dcl_args
+ -> corresponds_with_expanded_syn_type dcl_type_symb.type_index dcl_args iclDef tc_state
+ TV {tv_info_ptr}
+ #! x = sreadPtr tv_info_ptr tc_state.tc_type_vars.hwn_heap
+ -> case x of
+ TVI_AType dcl_atype
+ -> t_corresponds dcl_atype iclDef tc_state
+ _ -> (False, tc_state)
+ _ -> (False, tc_state)
+ where
+ simple_corresponds dclDef iclDef
+ = t_corresponds dclDef.at_attribute iclDef.at_attribute
+ &&& equal dclDef.at_annotation iclDef.at_annotation
+ &&& t_corresponds dclDef.at_type iclDef.at_type
+
+ corresponds_with_expanded_syn_type {glob_module, glob_object} dclArgs icl_atype
+ tc_state
+ # is_defined_in_main_dcl = glob_module==cIclModIndex
+ | is_defined_in_main_dcl && tc_state.tc_visited_syn_types.[glob_object]
+ = (False, tc_state) // cycle in synonym types in main dcl
+ # ({dcl_common}, tc_state) = tc_state!tc_dcl_modules.[glob_module]
+ type_def = dcl_common.com_type_defs.[glob_object]
+ = case type_def.td_rhs of
+ SynType atype
+ # tc_state = { tc_state & tc_type_vars
+ = bind_type_vars type_def.td_args dclArgs tc_state.tc_type_vars }
+ tc_state = init_attr_vars type_def.td_attrs tc_state
+ tc_state = opt_set_visited_bit is_defined_in_main_dcl glob_object True tc_state
+ atype = { atype & at_attribute = determine_type_attribute type_def.td_attribute }
+ (corresponds, tc_state) = t_corresponds atype icl_atype tc_state
+ # tc_state = opt_set_visited_bit is_defined_in_main_dcl glob_object False tc_state
+ -> (corresponds, tc_state)
+ AbstractType _
+ #! icl_type_def = tc_state.tc_icl_type_defs.[tc_state.tc_type_conversions.[glob_object]]
+ # tc_state = { tc_state & tc_type_vars
+ = bind_type_vars icl_type_def.td_args dclArgs tc_state.tc_type_vars }
+ tc_state = init_attr_vars icl_type_def.td_attrs tc_state
+ -> case icl_type_def.td_rhs of
+ SynType atype
+ # atype = { atype & at_attribute = determine_type_attribute type_def.td_attribute } // XXX auch bei abstract types
+ -> t_corresponds atype icl_atype tc_state
+ _ -> (False, tc_state)
+ _ -> (False, tc_state)
+ where
+ bind_type_vars formal_args actual_args tc_type_vars
+ # (ok, hwn_heap) = bind_type_vars` formal_args actual_args tc_type_vars.hwn_heap
+ = { tc_type_vars & hwn_heap = hwn_heap }
+
+ bind_type_vars` [{atv_variable}:formal_args] [actual_arg:actual_args] type_var_heap
+ = bind_type_vars` formal_args actual_args
+ (writePtr atv_variable.tv_info_ptr (TVI_AType actual_arg) type_var_heap)
+ bind_type_vars` [] [] type_var_heap
+ = (True, type_var_heap)
+ bind_type_vars` _ _ type_var_heap
+ = (False, type_var_heap)
+
+ opt_set_visited_bit True glob_object bit tc_state
+ = { tc_state & tc_visited_syn_types.[glob_object] = bit }
+ opt_set_visited_bit False _ _ tc_state
+ = tc_state
+
+ determine_type_attribute TA_Unique = TA_Unique
+ determine_type_attribute _ = TA_Multi
+
+instance t_corresponds TypeAttribute where
+ t_corresponds TA_Unique TA_Unique
+ = return True
+ t_corresponds TA_Multi TA_Multi
+ = return True
+ t_corresponds (TA_Var dclDef) (TA_Var iclDef)
+ = t_corresponds dclDef iclDef
+ t_corresponds _ TA_Anonymous // XXX comment
+ = return True
+ t_corresponds TA_None icl
+ = case icl of
+ TA_Multi-> return True
+ TA_None -> return True
+ _ -> return False
+ t_corresponds TA_Multi icl
+ = case icl of
+ TA_Multi-> return True
+ TA_None -> return True
+ _ -> return False
+ t_corresponds _ _
+ = return False
+
+instance t_corresponds AttributeVar where
+ t_corresponds dclDef iclDef
+ = corresponds` dclDef iclDef
+ where
+ corresponds` dclDef iclDef tc_state=:{tc_attr_vars}
+ # (unifiable, tc_attr_vars) = tryToUnifyVars dclDef.av_info_ptr iclDef.av_info_ptr tc_attr_vars
+ = (unifiable, { tc_state & tc_attr_vars = tc_attr_vars })
+
+instance t_corresponds Type where
+ t_corresponds (TA dclIdent dclArgs) icl_type=:(TA iclIdent iclArgs)
+ = equal dclIdent.type_name iclIdent.type_name
+ &&& equal dclIdent.type_index.glob_module iclIdent.type_index.glob_module
+ &&& t_corresponds dclArgs iclArgs
+ t_corresponds (dclFun --> dclArg) (iclFun --> iclArg)
+ = t_corresponds dclFun iclFun
+ &&& t_corresponds dclArg iclArg
+ t_corresponds (dclVar :@: dclArgs) (iclVar :@: iclArgs)
+ = t_corresponds dclVar iclVar
+ &&& t_corresponds dclArgs iclArgs
+ t_corresponds (TB dclDef) (TB iclDef)
+ = equal dclDef iclDef
+ t_corresponds (TV dclDef) (TV iclDef)
+ = t_corresponds dclDef iclDef
+ t_corresponds (GTV dclDef) (GTV iclDef)
+ = t_corresponds dclDef iclDef
+ t_corresponds dclDef iclDef
+ = type_var_bindings_correspond dclDef iclDef
+ where
+ type_var_bindings_correspond (TV {tv_info_ptr}) icl_type tc_state
+ #! tvi = sreadPtr tv_info_ptr tc_state.tc_type_vars.hwn_heap
+ = case tvi of
+ TVI_Type dcl_type
+ -> t_corresponds dcl_type icl_type tc_state
+ _ -> (True, tc_state)
+ type_var_bindings_correspond _ _ tc_state
+ = (False, tc_state)
+
+instance t_corresponds ConsVariable where
+ t_corresponds (CV dclVar) (CV iclVar)
+ = t_corresponds dclVar iclVar
+
+instance t_corresponds TypeVar where
+ t_corresponds dclDef iclDef
+ = corresponds_TypeVar dclDef iclDef
+ where
+ corresponds_TypeVar dclDef iclDef tc_state=:{tc_type_vars}
+ # (unifiable, tc_type_vars) = tryToUnifyVars dclDef.tv_info_ptr iclDef.tv_info_ptr tc_type_vars
+ = (unifiable, { tc_state & tc_type_vars = tc_type_vars })
+
+instance t_corresponds TypeRhs where
+ t_corresponds (AlgType dclConstructors) (AlgType iclConstructors)
+ = t_corresponds dclConstructors iclConstructors
+ t_corresponds (SynType dclType) (SynType iclType)
+ = t_corresponds dclType iclType
+ t_corresponds (RecordType dclRecord) (RecordType iclRecord)
+ = t_corresponds dclRecord iclRecord
+ t_corresponds (AbstractType _) _
+ = return True
+// sanity check ...
+ t_corresponds UnknownType _
+ = undef <<- "t_corresponds (TypeRhs): dclDef == UnknownType"
+ t_corresponds _ UnknownType
+ = undef <<- "t_corresponds (TypeRhs): iclDef == UnknownType"
+// ... sanity check
+ t_corresponds _ _
+ = return False
+
+instance t_corresponds RecordType where
+ t_corresponds dclRecord iclRecord
+ = t_corresponds dclRecord.rt_constructor iclRecord.rt_constructor
+ &&& t_corresponds dclRecord.rt_fields iclRecord.rt_fields
+
+instance t_corresponds FieldSymbol where
+ t_corresponds dclField iclField
+ = equal dclField.fs_name iclField.fs_name
+
+instance t_corresponds ConsDef where
+ t_corresponds dclDef iclDef
+ = exi_vars_correspond dclDef.cons_exi_vars iclDef.cons_exi_vars
+ &&& t_corresponds dclDef.cons_type iclDef.cons_type
+ &&& equal dclDef.cons_symb iclDef.cons_symb
+ &&& equal dclDef.cons_priority iclDef.cons_priority
+
+instance t_corresponds SelectorDef where
+ t_corresponds dclDef iclDef
+ = exi_vars_correspond dclDef.sd_exi_vars iclDef.sd_exi_vars
+ &&& t_corresponds dclDef.sd_type iclDef.sd_type
+ &&& equal dclDef.sd_field_nr iclDef.sd_field_nr
+
+exi_vars_correspond dcl_exi_vars icl_exi_vars tc_state
+ # tc_state = init_atv_variables dcl_exi_vars icl_exi_vars tc_state
+ = t_corresponds dcl_exi_vars icl_exi_vars tc_state
+
+instance t_corresponds SymbolType where
+ t_corresponds dclDef iclDef
+ = t_corresponds dclDef.st_args iclDef.st_args
+ &&& t_corresponds dclDef.st_result iclDef.st_result
+ &&& t_corresponds dclDef.st_context iclDef.st_context
+ &&& t_corresponds dclDef.st_attr_env iclDef.st_attr_env
+
+instance t_corresponds AttrInequality where
+ t_corresponds dclDef iclDef
+ = t_corresponds dclDef.ai_demanded iclDef.ai_demanded
+ &&& t_corresponds dclDef.ai_offered iclDef.ai_offered
+
+instance t_corresponds ClassDef where
+ t_corresponds dclDef iclDef
+ = equal dclDef.class_name iclDef.class_name
+ &&& t_corresponds dclDef.class_args iclDef.class_args
+ &&& t_corresponds dclDef.class_context iclDef.class_context
+ &&& t_corresponds dclDef.class_members iclDef.class_members
+
+instance t_corresponds MemberDef where
+ t_corresponds dclDef iclDef
+ = equal dclDef.me_symb iclDef.me_symb
+ &&& equal dclDef.me_offset iclDef.me_offset
+ &&& equal dclDef.me_priority iclDef.me_priority
+ &&& t_corresponds dclDef.me_type iclDef.me_type
+
+instance t_corresponds ClassInstance where
+ t_corresponds dclDef iclDef
+ = t_corresponds` dclDef.ins_type iclDef.ins_type
+ where
+ t_corresponds` dclDef iclDef tc_state
+ # tc_state
+ = init_attr_vars (dclDef.it_attr_vars++iclDef.it_attr_vars) tc_state
+ tc_type_vars
+ = init_type_vars (dclDef.it_vars++iclDef.it_vars) tc_state.tc_type_vars
+ (corresponds, tc_state)
+ = t_corresponds dclDef.it_types iclDef.it_types { tc_state & tc_type_vars = tc_type_vars }
+ | not corresponds
+ = (corresponds, tc_state)
+ = t_corresponds dclDef.it_context iclDef.it_context tc_state
+
+instance t_corresponds DynamicType where
+ t_corresponds dclDef iclDef
+ = t_corresponds dclDef.dt_type iclDef.dt_type
+
+instance e_corresponds (Optional a) | e_corresponds a where
+ e_corresponds No No
+ = do_nothing
+ e_corresponds (Yes dclYes) (Yes iclYes)
+ = e_corresponds dclYes iclYes
+ e_corresponds _ _
+ = give_error ""
+
+instance e_corresponds (a, b) | e_corresponds a & e_corresponds b where
+ e_corresponds (a1, b1) (a2, b2)
+ = (e_corresponds a1 a2)
+ o` (e_corresponds b1 b2)
+
+instance e_corresponds [a] | e_corresponds a where
+ e_corresponds [] []
+ = do_nothing
+ e_corresponds [dclDef:dclDefs] [iclDef:iclDefs]
+ = e_corresponds dclDef iclDef
+ o` e_corresponds dclDefs iclDefs
+ e_corresponds _ _
+ = give_error ""
+
+instance e_corresponds (Global a) | e_corresponds a where
+ e_corresponds dclDef iclDef
+ = equal2 dclDef.glob_module iclDef.glob_module
+ o` e_corresponds dclDef.glob_object iclDef.glob_object
+
+instance e_corresponds DefinedSymbol where
+ e_corresponds dclDef iclDef
+ = equal2 dclDef.ds_ident iclDef.ds_ident
+
+instance e_corresponds FunDef where
+ e_corresponds dclDef iclDef
+ = e_corresponds (fromBody dclDef.fun_body) (fromBody iclDef.fun_body)
+ where
+ fromBody (TransformedBody {tb_args, tb_rhs}) = (tb_args, [tb_rhs])
+ fromBody (CheckedBody {cb_args, cb_rhs}) = (cb_args, cb_rhs)
+
+instance e_corresponds TransformedBody where
+ e_corresponds dclDef iclDef
+ = e_corresponds dclDef.tb_args iclDef.tb_args
+ o` e_corresponds dclDef.tb_rhs iclDef.tb_rhs
+
+instance e_corresponds FreeVar where
+ e_corresponds dclVar iclVar
+ = e_corresponds_VarInfoPtr iclVar.fv_name dclVar.fv_info_ptr iclVar.fv_info_ptr
+
+instance e_corresponds Expression where
+ // the following alternatives don't occur anymore: Lambda, Conditional, WildCard
+ e_corresponds (Var dcl) (Var icl)
+ = e_corresponds dcl icl
+ e_corresponds (App dcl_app) (App icl_app)
+ = e_corresponds_app_symb dcl_app.app_symb icl_app.app_symb
+ o` e_corresponds dcl_app.app_args icl_app.app_args
+ e_corresponds (dclFun @ dclArgs) (iclFun @ iclArgs)
+ = e_corresponds dclFun iclFun
+ o` e_corresponds dclArgs iclArgs
+ e_corresponds (Let dcl) (Let icl)
+ = e_corresponds dcl icl
+ e_corresponds (Case dcl) (Case icl)
+ = e_corresponds dcl icl
+ e_corresponds (Selection dcl_is_unique dcl_expr dcl_selections) (Selection icl_is_unique icl_expr icl_selections)
+ | not (equal_constructor dcl_is_unique icl_is_unique)
+ = give_error ""
+ = e_corresponds dcl_expr icl_expr
+ o` e_corresponds dcl_selections icl_selections
+ e_corresponds (Update dcl_expr_1 dcl_selections dcl_expr_2) (Update icl_expr_1 icl_selections icl_expr_2)
+ = e_corresponds dcl_expr_1 icl_expr_1
+ o` e_corresponds dcl_selections icl_selections
+ o` e_corresponds dcl_expr_2 icl_expr_2
+ e_corresponds (RecordUpdate dcl_type dcl_expr dcl_selections) (RecordUpdate icl_type icl_expr icl_selections)
+ = e_corresponds dcl_type icl_type
+ o` e_corresponds dcl_expr icl_expr
+ o` e_corresponds dcl_selections icl_selections
+ e_corresponds (TupleSelect dcl_ds dcl_field_nr dcl_expr) (TupleSelect icl_ds icl_field_nr icl_expr)
+ = e_corresponds dcl_ds icl_ds
+ o` equal2 dcl_field_nr icl_field_nr
+ o` e_corresponds dcl_expr icl_expr
+ e_corresponds (BasicExpr dcl_value dcl_type) (BasicExpr icl_value icl_type)
+ = equal2 dcl_value icl_value
+ o` equal2 dcl_type icl_type
+ e_corresponds (AnyCodeExpr dcl_ins dcl_outs dcl_code_sequence) (AnyCodeExpr icl_ins icl_outs icl_code_sequence)
+ = e_corresponds dcl_ins icl_ins
+ o` e_corresponds dcl_outs icl_outs
+ o` equal2 dcl_code_sequence icl_code_sequence
+ e_corresponds (ABCCodeExpr dcl_lines dcl_do_inline) (ABCCodeExpr icl_lines icl_do_inline)
+ = equal2 dcl_lines icl_lines
+ o` equal2 dcl_do_inline icl_do_inline
+ e_corresponds (MatchExpr dcl_opt_tuple_type dcl_cons_symbol dcl_src_expr)
+ (MatchExpr icl_opt_tuple_type icl_cons_symbol icl_src_expr)
+ = e_corresponds dcl_opt_tuple_type icl_opt_tuple_type
+ o` 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)
+ = e_corresponds dcl icl
+ e_corresponds (TypeCodeExpression dcl) (TypeCodeExpression icl)
+ = e_corresponds dcl icl
+ e_corresponds _ _
+ = give_error ""
+
+
+instance e_corresponds Let where
+ e_corresponds dclLet iclLet
+ = e_corresponds dclLet.let_strict_binds iclLet.let_strict_binds
+ o` e_corresponds dclLet.let_lazy_binds iclLet.let_lazy_binds
+ o` e_corresponds dclLet.let_expr iclLet.let_expr
+
+instance e_corresponds (Bind a b) | e_corresponds a & e_corresponds b where
+ e_corresponds dcl icl
+ = e_corresponds dcl.bind_src icl.bind_src
+ o` e_corresponds dcl.bind_dst icl.bind_dst
+
+instance e_corresponds Case where
+ e_corresponds dclCase iclCase
+ = e_corresponds dclCase.case_expr iclCase.case_expr
+ o` e_corresponds dclCase.case_guards iclCase.case_guards
+ o` e_corresponds dclCase.case_default iclCase.case_default
+
+instance e_corresponds CasePatterns where
+ e_corresponds (AlgebraicPatterns dcl_alg_type dcl_patterns) (AlgebraicPatterns icl_alg_type icl_patterns)
+ = e_corresponds dcl_patterns icl_patterns
+ e_corresponds (BasicPatterns dcl_basic_type dcl_patterns) (BasicPatterns icl_basic_type icl_patterns)
+ = equal2 dcl_basic_type icl_basic_type
+ o` e_corresponds dcl_patterns icl_patterns
+ e_corresponds (DynamicPatterns dcl_patterns) (DynamicPatterns icl_patterns)
+ = e_corresponds dcl_patterns icl_patterns
+ e_corresponds NoPattern NoPattern
+ = do_nothing
+ e_corresponds _ _
+ = give_error ""
+
+instance e_corresponds AlgebraicPattern where
+ e_corresponds dcl icl
+ = e_corresponds dcl.ap_symbol icl.ap_symbol
+ o` e_corresponds dcl.ap_vars icl.ap_vars
+ o` e_corresponds dcl.ap_expr icl.ap_expr
+
+instance e_corresponds BasicPattern where
+ e_corresponds dcl icl
+ = equal2 dcl.bp_value icl.bp_value
+ o` e_corresponds dcl.bp_expr icl.bp_expr
+
+instance e_corresponds DynamicPattern where
+ e_corresponds dcl icl
+ = e_corresponds dcl.dp_var icl.dp_var
+ o` e_corresponds dcl.dp_rhs icl.dp_rhs
+ o` e_corresponds_dp_type dcl.dp_type icl.dp_type
+ where
+ e_corresponds_dp_type dcl_expr_ptr icl_expr_ptr ec_state=:{ec_expr_heap, ec_tc_state}
+ #! dcl_type
+ = sreadPtr dcl_expr_ptr ec_expr_heap
+ icl_type
+ = sreadPtr icl_expr_ptr ec_expr_heap
+ # (EI_DynamicTypeWithVars _ dcl_dyn_type _)
+ = dcl_type
+ (EI_DynamicTypeWithVars _ icl_dyn_type _)
+ = icl_type
+ (corresponds, ec_tc_state)
+ = t_corresponds dcl_dyn_type icl_dyn_type ec_tc_state
+ ec_state
+ = { ec_state & ec_tc_state = ec_tc_state }
+ | corresponds
+ = ec_state
+ = give_error "" ec_state
+
+instance e_corresponds Selection where
+ e_corresponds (RecordSelection dcl_selector dcl_field_nr) (RecordSelection icl_selector icl_field_nr)
+ = e_corresponds dcl_selector icl_selector
+ o` equal2 dcl_field_nr icl_field_nr
+ e_corresponds (ArraySelection dcl_selector _ dcl_index_expr) (ArraySelection icl_selector _ icl_index_expr)
+ = e_corresponds dcl_selector icl_selector
+ o` e_corresponds dcl_index_expr icl_index_expr
+ e_corresponds (DictionarySelection dcl_dict_var dcl_selections _ dcl_index_expr)
+ (DictionarySelection icl_dict_var icl_selections _ icl_index_expr)
+ = e_corresponds dcl_dict_var icl_dict_var
+ o` e_corresponds dcl_selections icl_selections
+ o` e_corresponds dcl_index_expr icl_index_expr
+
+instance e_corresponds DynamicExpr where
+ e_corresponds dcl icl
+ = e_corresponds_dyn_opt_type dcl.dyn_opt_type icl.dyn_opt_type
+ o` e_corresponds dcl.dyn_expr icl.dyn_expr
+ where
+ e_corresponds_dyn_opt_type dcl icl ec_state
+ # (corresponds, ec_tc_state) = t_corresponds dcl icl ec_state.ec_tc_state
+ ec_state = { ec_state & ec_tc_state = ec_tc_state }
+ | corresponds
+ = ec_state
+ = give_error "" ec_state
+
+instance e_corresponds TypeCodeExpression where
+ e_corresponds TCE_Empty TCE_Empty
+ = do_nothing
+ e_corresponds _ _
+ = abort "comparedefimp:e_corresponds (TypeCodeExpression): currently only TCE_Empty can appear"
+
+instance e_corresponds {#Char} where
+ e_corresponds s1 s2
+ = equal2 s1 s2
+
+instance e_corresponds BoundVar where
+ e_corresponds dcl icl
+ = e_corresponds_VarInfoPtr icl.var_name dcl.var_info_ptr icl.var_info_ptr
+
+instance e_corresponds FieldSymbol where
+ e_corresponds dclField iclField
+ = equal2 dclField.fs_name iclField.fs_name
+
+e_corresponds_VarInfoPtr ident dclPtr iclPtr ec_state=:{ec_var_heap}
+ # (unifiable, ec_var_heap) = tryToUnifyVars dclPtr iclPtr ec_var_heap
+ ec_state = { ec_state & ec_var_heap = ec_var_heap }
+ | not unifiable
+ = { ec_state & ec_error_admin = checkError ident error_message ec_state.ec_error_admin }
+ = ec_state
+
+/* e_corresponds_app_symb checks correspondence of the function symbols in an App expression.
+ The problem: also different symbols can correspond with each other, because for macros
+ all local functions (also lambda functions) will be generated twice.
+*/
+e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_Function dcl_glob_index}
+ icl_app_symb=:{symb_kind=SK_Function icl_glob_index}
+ ec_state
+ = continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
+ ec_state
+e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_OverloadedFunction dcl_glob_index}
+ icl_app_symb=:{symb_kind=SK_OverloadedFunction icl_glob_index}
+ ec_state
+ = continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
+ ec_state
+e_corresponds_app_symb {symb_name=dcl_symb_name, symb_kind=SK_Constructor dcl_glob_index}
+ {symb_name=icl_symb_name, symb_kind=SK_Constructor icl_glob_index}
+ ec_state
+ | dcl_glob_index.glob_module==icl_glob_index.glob_module && dcl_symb_name.id_name==icl_symb_name.id_name
+ = ec_state
+ = give_error icl_symb_name ec_state
+e_corresponds_app_symb {symb_name} _ ec_state
+ = give_error symb_name ec_state
+
+continuation_for_possibly_twice_defined_funs dcl_app_symb dcl_glob_index icl_app_symb icl_glob_index
+ ec_state
+ | dcl_glob_index==icl_glob_index
+ = ec_state
+ | dcl_glob_index.glob_module<>cIclModIndex || icl_glob_index.glob_module<>cIclModIndex
+ = give_error icl_app_symb.symb_name ec_state
+ // two different functions from the main module were referenced. Check their correspondence
+ # dcl_index = dcl_glob_index.glob_object
+ icl_index = icl_glob_index.glob_object
+ #! dcl_is_macro_fun = get_is_macro_fun dcl_index ec_state.ec_icl_functions
+ icl_is_macro_fun = get_is_macro_fun icl_index ec_state.ec_icl_functions
+ | not dcl_is_macro_fun || not icl_is_macro_fun
+ // at least one function was not locally defined in a macro.
+ = give_error icl_app_symb.symb_name ec_state
+ // two functions that are local to a macro definition were referencend.
+ | not (names_are_compatible dcl_index icl_index ec_state.ec_icl_functions)
+ = give_error icl_app_symb.symb_name ec_state
+ | both_funs_have_not_been_checked_before dcl_index icl_index ec_state.ec_correspondences
+ // going into recursion is save
+ = compareTwoMacroFuns dcl_index icl_index ec_state
+ | both_funs_correspond dcl_index icl_index ec_state.ec_correspondences
+ = ec_state
+ = give_error icl_app_symb.symb_name ec_state
+ where
+ names_are_compatible dcl_index icl_index icl_functions
+ # dcl_function = icl_functions.[dcl_index]
+ icl_function = icl_functions.[icl_index]
+ dcl_is_lambda = get_is_lambda dcl_function.fun_kind
+ icl_is_lambda = get_is_lambda icl_function.fun_kind
+ = (dcl_is_lambda==icl_is_lambda)
+ && (implies (not dcl_is_lambda) (dcl_function.fun_symb.id_name==icl_function.fun_symb.id_name))
+ // functions that originate from lambda expressions can correspond although their names differ
+ where
+ get_is_lambda (FK_Function is_lambda)
+ = is_lambda
+ get_is_lambda _
+ = False
+
+ both_funs_have_not_been_checked_before dcl_index icl_index correspondences
+ = correspondences.[dcl_index]==cNoCorrespondence && correspondences.[icl_index]==cNoCorrespondence
+
+ both_funs_correspond dcl_index icl_index correspondences
+ = correspondences.[dcl_index]==icl_index && correspondences.[icl_index]==dcl_index
+
+ get_is_macro_fun fun_nr icl_functions
+ = icl_functions.[fun_nr].fun_info.fi_is_macro_fun
+
+init_attr_vars attr_vars tc_state=:{tc_attr_vars}
+ # hwn_heap = foldSt init_attr_var attr_vars tc_attr_vars.hwn_heap
+ tc_attr_vars = { tc_attr_vars & hwn_heap = hwn_heap }
+ = { tc_state & tc_attr_vars = tc_attr_vars }
+ where
+ init_attr_var {av_info_ptr} attr_heap
+ = writePtr av_info_ptr AVI_Empty attr_heap
+
+error_message :== "definition in the impl module conflicts with the def module"
+cNoCorrespondence :== -1
+implies a b :== not a || b
+
+(==>) infix 0 // :: w:(St .s .a) v:(.a -> .(St .s .b)) -> u:(St .s .b), [u <= v, u <= w]
+(==>) f g :== \st0 -> let (r,st1) = f st0 in g r st1
+
+(o`) infixr 0
+(o`) f g :== \state -> g (f state)
+
+// XXX should be a macro (but this crashes the 1.3.2 compiler)
+(&&&) infixr
+(&&&) m1 m2
+ = m1 ==> \b
+ -> if b
+ m2
+ (return False)
+
+equal a b
+ = return (a == b)
+
+equal2 a b
+ | a<>b
+ = give_error ""
+ = do_nothing
+
+do_nothing ec_state
+ = ec_state
+
+give_error s ec_state
+ = { ec_state & ec_error_admin = checkError s error_message ec_state.ec_error_admin }
+
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl
index fa89919..b953168 100644
--- a/frontend/convertDynamics.icl
+++ b/frontend/convertDynamics.icl
@@ -568,10 +568,6 @@ zipAppend2 xs [] zs = zs
zipAppend2 [x : xs] [y : ys] zs = [ (x,y) : zipAppend2 xs ys zs ]
-instance <<< FreeVar
-where
- (<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< '[' <<< fv_info_ptr <<< ']'
-
instance <<< Ptr a
where
(<<<) file ptr = file <<< ptrToInt ptr
diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl
index cb0ddcd..88b5845 100644
--- a/frontend/convertcases.icl
+++ b/frontend/convertcases.icl
@@ -280,7 +280,7 @@ newFunction opt_id fun_bodies local_vars arg_types result_type group_index (ci_n
, fun_type = Yes fun_type
, fun_pos = NoPos
, fun_index = NoIndex
- , fun_kind = FK_Function cFunctionGenerated
+ , fun_kind = FK_Function cNameNotLocationDependent
, fun_lifted = 0
, fun_info = { EmptyFunInfo & fi_group_index = group_index, fi_local_vars = local_vars }
}
@@ -1481,10 +1481,6 @@ instance <<< Ptr a
where
(<<<) file ptr = file <<< ptrToInt ptr
-instance <<< FreeVar
-where
- (<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< '[' <<< fv_info_ptr <<< ']'
-
instance <<< BoundVar
where
(<<<) file {var_name,var_info_ptr} = file <<< var_name <<< '[' <<< var_info_ptr <<< ']'
diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl
index e6e67b1..437db6b 100644
--- a/frontend/explicitimports.icl
+++ b/frontend/explicitimports.icl
@@ -73,8 +73,7 @@ possibly_filter_decls [] decls_of_imported_module _ modules cs // implicit impor
= (decls_of_imported_module, modules, cs)
possibly_filter_decls listed_symbols decls_of_imported_module (file_name, line_nr) modules cs
// explicit import
- #!
- ident_pos = { ip_ident= { id_name="", id_info=nilPtr }
+ #! ident_pos = { ip_ident= { id_name="", id_info=nilPtr }
, ip_line = line_nr
, ip_file = file_name
}
@@ -87,17 +86,17 @@ filter_explicitly_imported_decl _ [] akku _ modules cs
= (akku, modules, cs)
filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,dcls_explicit}):new_decls] akku
line_nr modules cs
- # undefined = -1
- atoms = flatten (map toAtom import_symbols)
+ # undefined = -1
+ atoms = flatten (map toAtom import_symbols)
structures = flatten (map toStructure import_symbols)
(checked_atoms, cs) = checkAtoms atoms cs
- unimported = (checked_atoms, structures)
+ unimported = (checked_atoms, structures)
((dcls_import,unimported), modules, cs)
- = filter_decl dcls_import [] unimported undefined modules cs
+ = filter_decl dcls_import unimported undefined modules cs
((dcls_local,unimported), modules, cs)
- = filter_decl dcls_local [] unimported index modules cs
- cs_error = foldSt checkAtomError (fst unimported) cs.cs_error
- cs_error = foldSt checkStructureError (snd unimported) cs_error
+ = filter_decl dcls_local unimported index modules cs
+ cs_error = foldSt checkAtomError (fst unimported) cs.cs_error
+ cs_error = foldSt checkStructureError (snd unimported) cs_error
cs = { cs & cs_error=cs_error }
| (isEmpty dcls_import && isEmpty dcls_local && isEmpty dcls_explicit)
= filter_explicitly_imported_decl import_symbols new_decls akku line_nr modules cs
@@ -146,16 +145,16 @@ filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,d
to_structure _ No _
= []
to_structure ident (Yes []) structureType
- = [(ident, SI_DotDot, structureType, No)]
+ = [(ident, SI_DotDot, structureType, No)]
to_structure ident (Yes elements) structureType
- # element_idents = removeDup [ ii_ident \\ {ii_ident}<-elements]
- = [(ident, (SI_Elements element_idents True),structureType, No)]
+ # element_idents = removeDup [ ii_ident \\ {ii_ident}<-elements]
+ = [(ident, (SI_Elements element_idents True),structureType, No)]
checkAtoms l cs
# groups = grouped l
- # wrong = filter isErrornous groups
+ wrong = filter isErrornous groups
unique = map hd groups
- | isEmpty wrong
+ | isEmpty wrong
= (unique, cs)
= (unique, foldSt error wrong cs)
where
@@ -252,12 +251,17 @@ instance == ConsequenceKind
(==) CK_Macro c = case c of CK_Macro-> True
_ -> False
-filter_decl [] akku unimported _ modules cs
- = ((akku, unimported), modules, cs)
-filter_decl [decl:decls] akku unimported index modules cs
- # ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs
- = filter_decl decls (if appears [decl:akku] akku) unimported index modules cs
+NoPosition :== -1
+filter_decl [] unimported _ modules cs
+ = (([], unimported), modules, cs)
+filter_decl [decl:decls] unimported index modules cs
+ # ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs
+ (r=:((recurs, unimported), modules, cs)) = filter_decl decls unimported index modules cs
+ | appears
+ = (([decl:recurs],unimported), modules, cs)
+ = r
+
decl_appears :: !Declaration !ExplicitImports !Index !*{#DclModule} !*CheckState
-> (!(!Bool, !ExplicitImports), !*{#DclModule}, !*CheckState)
decl_appears dec=:{dcl_kind=STE_Imported ste_Kind def_index} unimported _ modules cs
@@ -303,32 +307,30 @@ decl_appears {dcl_ident, dcl_kind, dcl_index} unimported index modules cs
isAtom STE_Instance = True
-// CommonDefs CollectedDefinitions
-
elementAppears imported_st dcl_ident dcl_index (atomicImports, structureImports) index modules cs
# ((result, structureImports), modules, cs)
- = element_appears imported_st dcl_ident dcl_index structureImports [] index modules cs
+ = element_appears imported_st dcl_ident dcl_index structureImports structureImports 0 index modules cs
= ((result, (atomicImports, structureImports)), modules, cs)
atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules cs
# ((result, atomicImports), modules, cs)
- = atom_appears dcl_ident dcl_index atomicImports [] index modules cs
+ = atom_appears dcl_ident dcl_index atomicImports atomicImports 0 index modules cs
= ((result, (atomicImports, structureImports)), modules, cs)
-atom_appears _ _ [] akku _ modules cs
- = ((False, akku), modules, cs)
-atom_appears ident dcl_index [h=:(import_ident, atomType):t] akku index modules cs
+atom_appears _ _ [] atomic_imports _ _ modules cs
+ = ((False, atomic_imports), modules, cs)
+atom_appears ident dcl_index [h=:(import_ident, atomType):t] atomic_imports unimp_index index modules cs
// MW2..
| do_temporary_import_solution_XXX
&& ident.id_name==import_ident.id_name
&& atomType==(AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True) // True or False doesn't matter in this line
# new_h = (import_ident, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True)
- = ((True, [new_h:t]++akku), modules, cs)
+ = ((True, [new_h: removeAt unimp_index atomic_imports]), modules, cs)
// ..MW2
| ident==import_ident
- # (modules, cs) = checkRecordError atomType import_ident dcl_index index modules cs
- = ((True, t++akku), modules, cs)
+ # (modules, cs) = checkRecordError atomType import_ident dcl_index index modules cs
+ = ((True, removeAt unimp_index atomic_imports), modules, cs)
// goes further with next alternative
where
checkRecordError atomType import_ident dcl_index index modules cs
@@ -345,8 +347,8 @@ atom_appears ident dcl_index [h=:(import_ident, atomType):t] akku index modules
_ -> checkError import_ident "imported as an algebraic type" cs_error
_ -> cs_error
= (modules, { cs & cs_error=cs_error })
-atom_appears ident dcl_index [h:t] akku index modules cs
- = atom_appears ident dcl_index t [h:akku] index modules cs
+atom_appears ident dcl_index [h:t] atomic_imports unimp_index index modules cs
+ = atom_appears ident dcl_index t atomic_imports (inc unimp_index) index modules cs
instance == StructureType
where
@@ -355,55 +357,58 @@ instance == StructureType
(==) ST_Class ST_Class = True
(==) _ _ = False
-element_appears _ _ _ [] akku _ modules cs
- = ((False, akku), modules, cs)
-// MW remove this later ..
+element_appears _ _ _ [] atomic_imports _ _ modules cs
+ = ((False, atomic_imports), modules, cs)
+// MW2 remove this later ..
element_appears imported_st element_ident dcl_index
- [h=:(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] akku
+ [h=:(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] atomic_imports unimp_index
index modules cs
| do_temporary_import_solution_XXX
# (appears, modules, cs)
= element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs
| appears
- = ((appears,[h:t]++akku), modules, cs)
- = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
+ = ((appears, atomic_imports), modules, cs)
+ = element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
// otherwise go further with next alternative
-// ..MW
+// ..MW2
element_appears imported_st element_ident dcl_index
- [h=:(_, _, st, _):t] akku
+ [h=:(_, _, st, _):t] atomic_imports unimp_index
index modules cs
| imported_st<>st
- = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
+ = element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
// goes further with next alternative
element_appears imported_st element_ident dcl_index
- [h=:(_, _, _, (Yes notDefinedHere)):t] akku
+ [h=:(_, _, _, (Yes notDefinedHere)):t] atomic_imports unimp_index
index modules cs
| notDefinedHere==dcl_index
- = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
+ = element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
// goes further with next alternative
element_appears imported_st element_ident dcl_index
- [h=:(struct_id, (SI_Elements elements explicit), st, optInfo):t] akku
+ [h=:(struct_id, (SI_Elements elements explicit), st, optInfo):t] atomic_imports unimp_index
index modules cs
+ | not (isMember element_ident elements)
+ = element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
# (l,r) = span ((<>) element_ident) elements
- | isEmpty r
- = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
- # oneLess = l++(tl r)
- newStructure = (struct_id, (SI_Elements oneLess explicit), st, optInfo)
+ oneLess = l++(tl r)
+ newStructure = (struct_id, (SI_Elements oneLess explicit), st, optInfo)
+ atomic_imports_1 = removeAt unimp_index atomic_imports
| not explicit
- = ((True, [newStructure: t]++akku), modules, cs)
+ = ((True, [newStructure: atomic_imports_1]), modules, cs)
// the found element was explicitly specified by the programmer: check it
# (appears, _, _, modules, cs)
= element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs
| appears
- = ((True, [newStructure: t]++akku), modules, cs)
+ = ((True, [newStructure: atomic_imports_1]), modules, cs)
# message = "does not belong to specified "+++(case st of
ST_Class -> "class."
_ -> "type.")
cs = { cs & cs_error= checkError element_ident message cs.cs_error}
- = ((False, t++akku), modules, cs)
+ = ((False, atomic_imports_1), modules, cs)
element_appears imported_st element_ident dcl_index
- [h=:(struct_id, SI_DotDot, st, optInfo):t] akku
+ [h=:(struct_id, SI_DotDot, st, optInfo):t] atomic_imports unimp_index
index modules cs
+ | (case st of {ST_stomm_stomm_stomm _ -> True; _ -> False}) && (False->>"element_appears weird case")
+ = undef
# (appears, defined, opt_element_idents, modules, cs)
= element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs
| not appears
@@ -411,17 +416,19 @@ element_appears imported_st element_ident dcl_index
No -> SI_DotDot
Yes element_idents -> (SI_Elements element_idents False)
newStructure = (struct_id, structureInfo, st, (if defined No (Yes dcl_index)))
- = element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs
+ new_atomic_imports = [newStructure : removeAt unimp_index atomic_imports]
+ = element_appears imported_st element_ident dcl_index t new_atomic_imports (inc unimp_index) index modules cs
# (Yes element_idents) = opt_element_idents
oneLess = filter ((<>) element_ident) element_idents
- newStructure = (struct_id, (SI_Elements oneLess False), st, No)
- = ((True,[newStructure:t]++akku), modules, cs)
-element_appears imported_st element_ident dcl_index [h:t] akku index modules cs
- = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs
+ newStructure = (struct_id, (SI_Elements oneLess False), st, No)
+ new_atomic_imports = [newStructure : removeAt unimp_index atomic_imports]
+ = ((True,new_atomic_imports), modules, cs)
+element_appears imported_st element_ident dcl_index [h:t] atomic_imports unimp_index index modules cs
+ = element_appears imported_st element_ident dcl_index t atomic_imports (inc unimp_index) index modules cs
lookup_type dcl_index index modules cs
- # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index]
- (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
+ # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index]
+ (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
cs = { cs & cs_symbol_table=cs_symbol_table }
= continuation module_entry.ste_kind dcl_module modules cs
where
diff --git a/frontend/main.icl b/frontend/main.icl
index 5f4c7d0..d907e1c 100644
--- a/frontend/main.icl
+++ b/frontend/main.icl
@@ -19,6 +19,16 @@ Start world
(ms.ms_out, ms.ms_files))) world
= fclose ms_out world
+
+CommandLoop proj ms=:{ms_io}
+ # answer = "c t5\n"
+ (command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
+ | command == []
+ = CommandLoop proj { ms & ms_io = ms_io}
+ # (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io}
+ = ms
+
+/*
CommandLoop proj ms=:{ms_io}
# (answer, ms_io) = freadline (ms_io <<< "> ")
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
@@ -28,6 +38,7 @@ CommandLoop proj ms=:{ms_io}
| ready
= ms
= CommandLoop proj ms
+*/
:: MainStateDefs funs funtypes types conses classes instances members selectors =
{ msd_funs :: !funs
diff --git a/frontend/parse.icl b/frontend/parse.icl
index b7ab535..9d5eb0a 100644
--- a/frontend/parse.icl
+++ b/frontend/parse.icl
@@ -476,11 +476,11 @@ where
-> (PD_Function pos name is_infix [] rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState)
_ -> (PD_Function pos name is_infix args rhs fun_kind, pState)
where
- token_to_fun_kind s BarToken = (FK_Function cFunctionNotGenerated, False, s)
- token_to_fun_kind s (SeqLetToken _) = (FK_Function cFunctionNotGenerated, False, s)
- token_to_fun_kind s EqualToken = (FK_Function cFunctionNotGenerated, True, s)
+ token_to_fun_kind s BarToken = (FK_Function cNameNotLocationDependent, False, s)
+ token_to_fun_kind s (SeqLetToken _) = (FK_Function cNameNotLocationDependent, False, s)
+ token_to_fun_kind s EqualToken = (FK_Function cNameNotLocationDependent, True, s)
token_to_fun_kind s ColonDefinesToken = (FK_Macro, False, s)
- token_to_fun_kind s DoubleArrowToken = (FK_Function cFunctionNotGenerated, True, s)
+ token_to_fun_kind s DoubleArrowToken = (FK_Function cNameNotLocationDependent, True, s)
token_to_fun_kind s DefinesColonToken = (FK_Caf, False, s)
token_to_fun_kind s token = (FK_Unknown, False, parseError "RHS" (Yes token) "defines token (=, => or =:) or argument" s)
@@ -1808,7 +1808,7 @@ wantSelectors token pState
where
want_selector :: !Token !*ParseState -> *(![ParsedSelection], !*ParseState)
want_selector SquareOpenToken pState
- # (array_selectors, pState) = want_array_selectors pState
+ # (array_selectors, pState) = want_array_selectors pState
= (array_selectors, wantToken FunctionContext "array selector" SquareCloseToken pState)
where
want_array_selectors :: !*ParseState -> *(![ParsedSelection], !*ParseState)
@@ -2153,9 +2153,9 @@ wantRecordOrArrayExp is_pattern pState
= (PE_ArrayDenot [], pState)
| is_pattern
| token == SquareOpenToken
- // # (elems, pState) = want_array_assignments cIsAPattern pState // currently no array selections in pattern PK
- // = (PE_Array PE_Empty elems [], wantToken FunctionContext "array selections in pattern" CurlyCloseToken pState)
- = (PE_Empty, parseError "array selection" No "No array selection in pattern" pState)
+ # (elems, pState) = want_array_assignments cIsAPattern pState
+ = (PE_ArrayPattern elems, wantToken FunctionContext "array selections in pattern" CurlyCloseToken pState)
+// MW was = (PE_Empty, parseError "array selection" No "No array selection in pattern" pState)
// otherwise // is_pattern && token <> SquareOpenToken
= want_record_pattern token pState
// otherwise // ~ is_pattern
diff --git a/frontend/postparse.icl b/frontend/postparse.icl
index a8e7a93..75f0d69 100644
--- a/frontend/postparse.icl
+++ b/frontend/postparse.icl
@@ -208,6 +208,7 @@ where
instance collectFunctions CaseAlt
where
collectFunctions calt=:{calt_pattern,calt_rhs} ca
+// MW why not # (calt_rhs, fun_defs, ca) = collectFunctions calt_rhs ca
# ((calt_pattern,calt_rhs), fun_defs, ca) = collectFunctions (calt_pattern,calt_rhs) ca
= ({calt & calt_pattern = calt_pattern, calt_rhs = calt_rhs}, fun_defs, ca)
@@ -311,7 +312,7 @@ transformLambda lam_ident args result
# lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs },
rhs_locals = NoCollectedLocalDefs }
lam_body = [{pb_args = args, pb_rhs = lam_rhs }]
- fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cFunctionGenerated) NoPrio No NoPos
+ fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No NoPos
= fun_def
makeNilExpression :: *CollectAdmin -> (ParsedExpr,*CollectAdmin)
@@ -739,7 +740,7 @@ MakeNewFunction name arity body kind prio opt_type pos
// +++ position
MakeNewParsedDef ident args rhs
- :== PD_Function NoPos ident False args rhs (FK_Function cFunctionGenerated)
+ :== PD_Function NoPos ident False args rhs (FK_Function cNameLocationDependent)
collectFunctionBodies :: !Ident !Int !Priority !FunKind ![ParsedDefinition] !*CollectAdmin
-> (![ParsedBody], !FunKind, ![ParsedDefinition], !*CollectAdmin)
diff --git a/frontend/refmark.icl b/frontend/refmark.icl
index f14cc37..5ff60bc 100644
--- a/frontend/refmark.icl
+++ b/frontend/refmark.icl
@@ -577,11 +577,6 @@ where
(<<<) file ptr = file <<< '[' <<< ptrToInt ptr <<< ']'
-instance <<< FreeVar
-where
- (<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< fv_info_ptr
-
-
import Debug
show
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index f348a69..0d3d7eb 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -135,8 +135,8 @@ cIsNotAFunction :== False
| PD_Erroneous
:: FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_Unknown
-cFunctionNotGenerated :== False
-cFunctionGenerated :== True
+cNameNotLocationDependent :== False
+cNameLocationDependent :== True
:: ParsedSelector =
{ ps_field_name :: !Ident
@@ -276,6 +276,7 @@ instance toString (Import from_symbol), AttributeVar, TypeAttribute, Annotation
cIsImportedLibrary :== True
cIsImportedObject :== False
+
:: ImportedObject =
{ io_is_library :: !Bool
, io_name :: !{#Char}
@@ -789,7 +790,7 @@ cNonRecursiveAppl :== False
:: TypeVarInfoPtr :== Ptr TypeVarInfo
:: TypeVarHeap :== Heap TypeVarInfo
-:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId
+:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId
| AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */
:: AttrVarInfoPtr :== Ptr AttrVarInfo
:: AttrVarHeap :== Heap AttrVarInfo
@@ -1132,7 +1133,7 @@ instance == ModuleKind, Ident
instance <<< Module a | <<< a, ParsedDefinition, InstanceType, AttributeVar, TypeVar, SymbolType, Expression, Type, Ident, Global object | <<< object,
Position, CaseAlt, AType, FunDef, ParsedExpr, TypeAttribute, Bind a b | <<< a & <<< b, ParsedConstructor, TypeDef a | <<< a, TypeVarInfo,
BasicValue, ATypeVar, TypeRhs, FunctionPattern, (Import from_symbol) | <<< from_symbol, ImportDeclaration, ImportedIdent, CasePatterns,
- Optional a | <<< a, ConsVariable, BasicType, Annotation, Selection, SignClassification
+ Optional a | <<< a, ConsVariable, BasicType, Annotation, Selection, SelectorDef, ConsDef, LocalDefs, FreeVar, ClassInstance
instance == TypeAttribute
instance == Annotation
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index 10eef66..898eaac 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -138,8 +138,8 @@ cIsNotAFunction :== False
| PD_Erroneous
:: FunKind = FK_Function !Bool | FK_Macro | FK_Caf | FK_Unknown
-cFunctionNotGenerated :== False
-cFunctionGenerated :== True
+cNameNotLocationDependent :== False
+cNameLocationDependent :== True
:: ParsedSelector =
{ ps_field_name :: !Ident
@@ -749,7 +749,7 @@ cNotVarNumber :== -1
:: TypeVarInfoPtr :== Ptr TypeVarInfo
:: TypeVarHeap :== Heap TypeVarInfo
-:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId
+:: AttrVarInfo = AVI_Empty | AVI_Attr !TypeAttribute | AVI_Forward !TempAttrId
| AVI_CorrespondenceNumber !Int /* auxiliary used in module comparedefimp */
:: AttrVarInfoPtr :== Ptr AttrVarInfo
:: AttrVarHeap :== Heap AttrVarInfo
@@ -1123,12 +1123,10 @@ where
instance <<< TypeVar
where
-// (<<<) file varid = file <<< varid.tv_name <<< '[' <<< ptrToInt varid.tv_info_ptr <<< ']'
(<<<) file varid = file <<< varid.tv_name
instance <<< AttributeVar
where
-// (<<<) file {av_name,av_info_ptr} = file <<< av_name <<< '[' <<< ptrToInt av_info_ptr <<< ']'
(<<<) file {av_name,av_info_ptr} = file <<< av_name
instance toString AttributeVar
@@ -1325,10 +1323,9 @@ instance <<< Expression
where
(<<<) file (Var ident) = file <<< ident
(<<<) file (App {app_symb, app_args, app_info_ptr})
-// = file <<< app_symb <<< ' ' <<< app_args
- = file <<< app_symb <<< " <" <<< ptrToInt app_info_ptr <<< "> " <<< app_args
+ = file <<< app_symb <<< ' ' <<< app_args
(<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')'
- (<<<) file (Let {let_info_ptr, let_strict_binds, let_lazy_binds, let_expr}) = write_binds (file <<< "let" <<< '\n') (let_strict_binds ++ let_lazy_binds) <<< "in\n" <<< let_expr
+ (<<<) file (Let {let_info_ptr, let_strict_binds, let_lazy_binds, let_expr}) = write_binds (file <<< "let" <<< '\n') (let_strict_binds++let_lazy_binds) <<< "in\n" <<< let_expr
where
write_binds file []
= file
@@ -1370,7 +1367,7 @@ where
(<<<) file (ABCCodeExpr code_sequence do_inline) = file <<< (if do_inline "code inline\n" "code\n") <<< code_sequence
(<<<) file (AnyCodeExpr input output code_sequence) = file <<< "code\n" <<< input <<< "\n" <<< output <<< "\n" <<< code_sequence
- (<<<) file (FreeVar {fv_name}) = file <<< "FREEVAR " <<< fv_name
+ (<<<) file (FreeVar {fv_name}) = file <<< fv_name
(<<<) file (ClassVariable info_ptr) = file <<< "ClassVariable " <<< ptrToInt info_ptr
(<<<) file expr = abort ("<<< (Expression) [line 1290]" )//<<- expr)
@@ -1496,6 +1493,14 @@ where
(<<<) file (FP_Empty) = file <<< '_'
+instance <<< FunKind
+where
+ (<<<) file (FK_Function False) = file <<< "FK_Function"
+ (<<<) file (FK_Function True) = file <<< "Lambda"
+ (<<<) file FK_Macro = file <<< "FK_Macro"
+ (<<<) file FK_Caf = file <<< "FK_Caf"
+ (<<<) file FK_Unknown = file <<< "FK_Unknown"
+
instance <<< FunDef
where
(<<<) file {fun_symb,fun_index,fun_body=ParsedBody bodies} = file <<< fun_symb <<< '.' <<< fun_index <<< ' ' <<< bodies
@@ -1507,6 +1512,7 @@ where
// <<< fun_index <<< '.' <<< fi_def_level <<< ' ' <<< '[' <<< fi_free_vars <<< ']' <<< tb_args <<< " = " <<< tb_rhs
(<<<) file {fun_symb,fun_index,fun_body=BackendBody body,fun_type=Yes type} = file <<< type <<< '\n' <<< fun_symb <<< '.'
<<< fun_index <<< body <<< '\n'
+
instance <<< FunCall
where
(<<<) file { fc_level,fc_index }
diff --git a/frontend/trans.icl b/frontend/trans.icl
index 77aa76d..c9e2caf 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -1021,7 +1021,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti
, fun_type = Yes fun_type
, fun_pos = NoPos
, fun_index = fun_index
- , fun_kind = FK_Function cFunctionGenerated
+ , fun_kind = FK_Function cNameNotLocationDependent
, fun_lifted = undeff
, fun_info = { fi_calls = []
, fi_group_index = outer_fun_def.fun_info.fi_group_index
@@ -2328,10 +2328,6 @@ instance <<< InstanceInfo
file = foldSt (\pr file -> file<<<pr<<<",") [el \\ el<-:producers] file
= write_ii r (file<<<")")
-instance <<< FreeVar
-where
- (<<<) file { fv_name,fv_info_ptr } = file <<< fv_name <<< "<" <<< fv_info_ptr <<< ">"
-
instance <<< Ptr a
where
(<<<) file p = file <<< ptrToInt p
diff --git a/frontend/transform.icl b/frontend/transform.icl
index 122b290..75b8972 100644
--- a/frontend/transform.icl
+++ b/frontend/transform.icl
@@ -1375,13 +1375,8 @@ where
-> (var, [{fv_name = var_name, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0} : free_vars ],
{ cos & cos_var_heap = writePtr var_info_ptr (VI_Count 1 is_global) cos.cos_var_heap })
_
- -> abort "collectVariables [BoundVar] (transform, 1227)" // <<- (var_info ---> var_name)
+ -> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> var_name)
-// XXX
-instance <<< FreeVar
-where
- (<<<) file { fv_name,fv_info_ptr } = file <<< fv_name <<< "<" <<< fv_info_ptr <<< ">"
-
instance <<< Ptr a
where
(<<<) file p = file <<< ptrToInt p
diff --git a/frontend/type.icl b/frontend/type.icl
index 63615a0..b93fde7 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -1762,10 +1762,6 @@ instance <<< AttrCoercion
where
(<<<) file {ac_demanded,ac_offered} = file <<< ac_demanded <<< '~' <<< ac_offered
-instance <<< FreeVar
-where
- (<<<) file {fv_name} = file <<< fv_name
-
instance <<< TypeCoercion
where
(<<<) file {tc_demanded,tc_offered} = file <<< tc_demanded <<< '~' <<< tc_offered
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-13 19:08:22 +0000