Commit 12e61eac authored by Martin Wierich's avatar Martin Wierich
Browse files

check.icl: improving bugfix that yielded revision 1.15

trans.icl: improving sjaaks changes that yielded revision 1.17
parse.icl: bugfix: The following program led into "could not determine the type of this record"

module t5

:: R1 = { f :: Int }
:: R2 = { f :: Int }
:: R3 = { g :: R1 }

g x = { x & g.R1.f = 1 }
parent a42774b8
......@@ -969,7 +969,7 @@ checkBoundPattern {bind_src,bind_dst} opt_var p_input var_env ps e_info cs=:{cs_
= case opt_var of
Yes bind
-> checkPattern bind_src (Yes { bind_src = bind_dst, bind_dst = new_info_ptr }) p_input var_env ps
e_info { cs & cs_error = checkError bind.bind_src "pattern already bound" cs.cs_error }
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 }
......@@ -1212,7 +1212,6 @@ checkExpression free_vars (PE_Let strict let_locals expr) e_input=:{ei_expr_leve
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
// (guards, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars alts [] 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
......@@ -1227,18 +1226,7 @@ where
(gs, pattern_scheme, pattern_variables, defaul, free_vars, e_state, e_info, cs)
= check_guarded_expressions free_vars gs pattern_variables case_name e_input e_state e_info cs
= check_guarded_expression free_vars g gs pattern_scheme pattern_variables defaul case_name e_input e_state e_info cs
/*
check_guarded_expressions free_vars [g] pattern_variables e_input=:{ei_expr_level} e_state e_info cs
# e_input = { e_input & ei_expr_level = inc ei_expr_level }
= check_guarded_expression free_vars g NoPattern pattern_variables No e_input e_state e_info cs
check_guarded_expressions free_vars [g : gs] pattern_variables e_input=:{ei_expr_level} e_state e_info cs
# e_input = { e_input & ei_expr_level = inc ei_expr_level }
(gs, pattern_variables, defaul, free_vars, e_state, e_info, cs)
= check_guarded_expressions free_vars gs pattern_variables e_input e_state e_info cs
= check_guarded_expression free_vars g gs pattern_variables defaul e_input e_state e_info cs
*/
check_guarded_expression free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals}} patterns pattern_scheme pattern_variables defaul case_name
// check_guarded_expression free_vars {calt_pattern,calt_rhs={rhs_alts,rhs_locals}} patterns 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 } []
......@@ -1247,21 +1235,14 @@ where
(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
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)
// (guarded_expr, 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, free_vars,
// = (guarded_expr, 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)
transform_pattern :: !AuxiliaryPattern !CasePatterns !CasePatterns !(Env Ident VarInfoPtr) !(Optional (![FreeVar], !Expression)) !Expression
transform_pattern :: !AuxiliaryPattern !CasePatterns !CasePatterns !(Env Ident VarInfoPtr) !(Optional (!Optional FreeVar, !Expression)) !Expression
!String !*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState
-> (!CasePatterns, !CasePatterns, !Env Ident VarInfoPtr, !Optional (![FreeVar],!Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState)
/*
transform_pattern :: !AuxiliaryPattern !CasePatterns !(Env Ident VarInfoPtr) !(Optional (Optional FreeVar, Expression)) !Expression
!*VarHeap !*ExpressionHeap ![DynamicPtr] !*CheckState
-> (!CasePatterns, !Env Ident VarInfoPtr, !Optional (Optional FreeVar,Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState)
*/
-> (!CasePatterns, !CasePatterns, !Env Ident VarInfoPtr, !Optional (!Optional FreeVar,!Expression), !*VarHeap, !*ExpressionHeap, ![DynamicPtr], !*CheckState)
transform_pattern (AP_Algebraic cons_symbol type_index args opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs
# (var_args, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPatterns args result_expr var_store expr_heap opt_dynamics cs
type_symbol = { glob_module = cons_symbol.glob_module, glob_object = type_index}
......@@ -1279,19 +1260,6 @@ where
_
-> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
{ cs & cs_error = checkError cons_symbol.glob_object.ds_ident "illegal combination of patterns" cs.cs_error })
/*
= case patterns of
AlgebraicPatterns alg_type alg_patterns
| type_symbol == alg_type
-> (AlgebraicPatterns type_symbol [pattern : alg_patterns], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
-> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
{ cs & cs_error = checkError cons_symbol.glob_object.ds_ident "incompatible types of patterns" cs.cs_error })
NoPattern
-> (AlgebraicPatterns type_symbol [pattern], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs)
_
-> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics,
{ cs & cs_error = checkError cons_symbol.glob_object.ds_ident "illegal combination of patterns" cs.cs_error })
*/
transform_pattern (AP_Basic basic_val opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs
# pattern = { bp_value = basic_val, bp_expr = result_expr}
pattern_variables = cons_optional opt_var pattern_variables
......@@ -1324,24 +1292,21 @@ where
{ cs & cs_error = checkError "<dynamic pattern>" "illegal combination of patterns" cs.cs_error })
transform_pattern (AP_Variable name var_info opt_var) NoPattern pattern_scheme pattern_variables No result_expr _ var_store expr_heap opt_dynamics cs
= ( NoPattern, pattern_scheme, cons_optional opt_var pattern_variables,
Yes ([{ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }], result_expr),
Yes (Yes { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr),
var_store, expr_heap, opt_dynamics, cs)
transform_pattern (AP_Variable name var_info opt_var) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs
# vars_as_patterns = fst_optional defaul
default_expr = snd_optional defaul
free_var = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }
# free_var = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }
(new_bound_var, expr_heap) = allocate_bound_var free_var expr_heap
case_ident = { id_name = case_name, id_info = nilPtr }
(new_case, expr_heap) = build_case patterns defaul (Var new_bound_var) case_ident expr_heap
new_defaul = insert_as_default new_case result_expr
// if (!has_been_inserted) checkWarning("pattern won't match");
= (NoPattern, pattern_scheme, (cons_optional opt_var pattern_variables), Yes (cons_opt free_var vars_as_patterns, new_defaul),
= (NoPattern, pattern_scheme, (cons_optional opt_var pattern_variables), Yes (Yes free_var, new_defaul),
var_store, expr_heap, opt_dynamics, cs)
transform_pattern (AP_WildCard (Yes opt_var)) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs
= transform_pattern (AP_Variable opt_var.bind_src opt_var.bind_dst No) patterns pattern_scheme pattern_variables defaul
result_expr case_name var_store expr_heap opt_dynamics cs
transform_pattern (AP_WildCard no) NoPattern pattern_scheme pattern_variables No result_expr _ var_store expr_heap opt_dynamics cs
= (NoPattern, pattern_scheme, pattern_variables, Yes ([], result_expr), var_store, expr_heap, opt_dynamics, cs)
= (NoPattern, pattern_scheme, pattern_variables, Yes (No, result_expr), var_store, expr_heap, opt_dynamics, cs)
transform_pattern (AP_WildCard _) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs
# (new_info_ptr, var_store) = newPtr VI_Empty var_store
= transform_pattern (AP_Variable (newVarId "wc") new_info_ptr No) patterns pattern_scheme pattern_variables defaul
......@@ -1357,58 +1322,56 @@ where
= case case_default of
No -> Case { kees & case_default = Yes to_insert }
Yes defaul -> Case { kees & case_default = Yes (insert_as_default to_insert defaul)}
insert_as_default _ expr = expr
insert_as_default _ expr = expr // checkWarning "pattern won't match"
build_case NoPattern defaul expr case_ident expr_heap
= case defaul of
Yes (vars, result)
| isEmpty vars
-> (result, expr_heap)
# (let_expression, expr_heap) = bind_default_variables expr vars result expr_heap
-> (let_expression, expr_heap)
Yes (opt_var, result)
-> case opt_var of
Yes var
# (let_expression, expr_heap) = bind_default_variable expr var result expr_heap
-> (let_expression, expr_heap)
No
-> (result, expr_heap)
No
-> (EE, expr_heap)
build_case (DynamicPatterns patterns) defaul expr case_ident expr_heap
= case defaul of
Yes (vars, result)
-> case vars of
[] # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (buildTypeCase expr patterns (Yes result) type_case_info_ptr, expr_heap)
[var:_]
Yes (opt_var, result)
-> case opt_var of
Yes var
# (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
(bound_var, expr_heap) = allocate_bound_var var expr_heap
result = buildTypeCase (Var bound_var) patterns (Yes result) type_case_info_ptr
(case_expression, expr_heap) = bind_default_variables expr vars result expr_heap
(case_expression, expr_heap) = bind_default_variable expr var result expr_heap
-> (case_expression, expr_heap)
No
# (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (buildTypeCase expr patterns (Yes result) type_case_info_ptr, expr_heap)
No
# (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (buildTypeCase expr patterns No type_case_info_ptr, expr_heap)
build_case patterns (Yes (vars,result)) expr case_ident expr_heap
= case vars of
[] # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result,
case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap)
[var:_]
build_case patterns (Yes (opt_var,result)) expr case_ident expr_heap
= case opt_var of
Yes var
# (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(bound_var, expr_heap) = allocate_bound_var var expr_heap
result = Case {case_expr = Var bound_var, case_guards = patterns, case_default = Yes result,
case_ident = Yes case_ident, case_info_ptr = case_expr_ptr}
(case_expression, expr_heap) = bind_default_variables expr (reverse vars) result expr_heap
(case_expression, expr_heap) = bind_default_variable expr var result expr_heap
-> (case_expression, expr_heap)
No
# (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
-> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result,
case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap)
build_case patterns No expr case_ident expr_heap
# (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Case {case_expr = expr, case_guards = patterns, case_default = No, case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap)
bind_default_variables expr vars result_expr expr_heap
bind_default_variable bind_src bind_dst result_expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
(var_binds, expr_heap) = build_binds vars [] expr_heap
let_binds = [{ bind_src = expr, bind_dst = hd vars }:var_binds]
= (Let {let_strict_binds = [], let_lazy_binds = let_binds, let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap)
where
build_binds [var] accu expr_heap
= (accu, expr_heap)
build_binds [var1:tl=:[var2:vars]] accu expr_heap
# (bound_var, expr_heap) = allocate_bound_var var1 expr_heap
= build_binds tl [{ bind_src = Var bound_var, bind_dst = var2 }:accu] expr_heap
= (Let {let_strict_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], let_lazy_binds = [],
let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap)
bind_pattern_variables [] pattern_expr expr_heap
= (pattern_expr, [], expr_heap)
......@@ -1423,18 +1386,6 @@ where
cons_optional No variables
= variables
cons_opt x No = [x]
cons_opt x (Yes l) = [x:l]
fst_optional (Yes (x,_)) = Yes x
fst_optional no = No
snd_optional (Yes (_,x)) = Yes x
snd_optional no = No
opt_to_list (Yes x) = x
opt_to_list no = []
checkExpression free_vars (PE_Selection is_unique expr [PS_Array index_expr]) e_input e_state e_info cs
# (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
| is_unique
......
......@@ -2322,7 +2322,8 @@ where
(assignments, (optionalIdent, final_record_type,pState2))
= mapSt (transform_update level) groupedUpdates (No, record_type,pState)
updateExpr
= build_update record_type optionalIdent expr assignments
= build_update final_record_type optionalIdent expr assignments
// MW was = build_update record_type optionalIdent expr assignments
// transform one group of nested updates with the same first field
// for example: f.g1 = e1, f.g2 = e2 -> f = {id.f & g1 = e1, g2 = e2},
// (id is ident to shared expression that's being updated)
......@@ -2336,7 +2337,6 @@ where
= make_ident optionalIdent level pState
select
= PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type]
// = PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent field_record_type]
(update_expr, pState)
= transform_record_or_array_update No select (map sub_update updates) (level+1) pState
= ({bind_dst = fieldIdent, bind_src = update_expr}, (Yes shareIdent,record_type,pState))
......
......@@ -803,10 +803,11 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf
Let lad
| not is_active
-> skip_over this_case ro ti
# (let_strict_binds, ti) = transform lad.let_strict_binds { ro & ro_root_case_mode = NotRootCase } ti
(let_lazy_binds, ti) = transform lad.let_lazy_binds { ro & ro_root_case_mode = NotRootCase } ti
# ro_not_root = { ro & ro_root_case_mode = NotRootCase }
(new_let_strict_binds, ti) = transform lad.let_strict_binds ro_not_root ti
(new_let_lazy_binds, ti) = transform lad.let_lazy_binds ro_not_root ti
(new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti
-> (Let { lad & let_expr = new_let_expr, let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds }, ti)
-> (Let { lad & let_expr = new_let_expr, let_strict_binds = new_let_strict_binds, let_lazy_binds = new_let_lazy_binds }, ti)
_ -> skip_over this_case ro ti
where
equal (SK_Function glob_index1) (SK_Function glob_index2)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment