Commit f1f5f184 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

bug fix: instance of < for Priority removed,

function determinePriority added
parent 68e5eff6
......@@ -816,14 +816,19 @@ checkPattern def_level mod_index (PE_List [exp1, exp2 : exps]) opt_var var_env p
(pattern1, ps, e_info, cs) = build_final_pattern mod_index left_args pattern1 ps e_info cs
-> check_patterns def_level mod_index [pattern2,pattern1] arg rest opt_var var_env ps e_info cs
| is_infix_constructor prio2
| prio1 > prio2
# (mid_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index middle var_env ps e_info cs
(pattern, ps, e_info, cs) = buildPattern mod_index kind1 cons1 [left,mid_pat] No ps e_info cs
(left_args, pattern, ps, e_info, cs) = build_left_pattern mod_index left_args prio2 pattern ps e_info cs
-> check_infix_pattern def_level mod_index left_args pattern kind2 cons2 prio2 arg rest opt_var var_env ps e_info cs
# (mid_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs
-> check_infix_pattern def_level mod_index [(kind1, cons1, prio1, left) : left_args]
mid_pat kind2 cons2 prio2 arg rest No var_env ps e_info cs
# optional_prio = determinePriority prio1 prio2
-> case optional_prio of
Yes priority
| priority
# (mid_pat, var_env, ps, e_info, cs) = check_pattern def_level mod_index middle var_env ps e_info cs
(pattern, ps, e_info, cs) = buildPattern mod_index kind1 cons1 [left,mid_pat] No ps e_info cs
(left_args, pattern, ps, e_info, cs) = build_left_pattern mod_index left_args prio2 pattern ps e_info cs
-> check_infix_pattern def_level mod_index left_args pattern kind2 cons2 prio2 arg rest opt_var var_env ps e_info cs
# (mid_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs
-> check_infix_pattern def_level mod_index [(kind1, cons1, prio1, left) : left_args]
mid_pat kind2 cons2 prio2 arg rest No var_env 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 })
_
# (right_pat, var_env, ps, e_info, cs) = checkPattern def_level mod_index middle No var_env ps e_info cs
......@@ -837,10 +842,15 @@ checkPattern def_level mod_index (PE_List [exp1, exp2 : exps]) opt_var var_env p
build_left_pattern mod_index [] _ result_pattern ps e_info cs
= ([], result_pattern, ps, e_info, cs)
build_left_pattern mod_index la=:[(kind, cons, priol, left) : left_args] prior result_pattern ps e_info cs
| priol > prior
# (result_pattern, ps, e_info, cs) = buildPattern mod_index kind cons [left,result_pattern] No ps e_info cs
= build_left_pattern mod_index left_args prior result_pattern ps e_info cs
= (la, result_pattern, ps, e_info, cs)
# optional_prio = determinePriority priol prior
= case optional_prio of
Yes priority
| priority
# (result_pattern, ps, e_info, cs) = buildPattern mod_index kind cons [left,result_pattern] No ps e_info cs
-> build_left_pattern mod_index left_args prior result_pattern ps e_info cs
-> (la, result_pattern, ps, e_info, cs)
No
-> (la, result_pattern, ps, e_info,{ cs & cs_error = checkError cons.glob_object.ds_ident "conflicting priorities" cs.cs_error })
build_final_pattern mod_index [] result_pattern ps e_info cs
= (result_pattern, ps, e_info, cs)
......@@ -1161,14 +1171,19 @@ where
# (opt_opr, left2, e_state, cs_error) = split_at_operator [re] res e_state cs_error
= case opt_opr of
Yes (symb2, prio2, is_fun2, right)
| prio1 > prio2
# (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
(new_left, e_state, cs_error) = buildApplication symb1 2 2 is_fun1 [left1,middle_exp] e_state cs_error
(left_appls, new_left, e_state, cs_error) = build_left_operand left_appls prio2 new_left e_state cs_error
-> build_operator_expression left_appls new_left (symb2, prio2, is_fun2) right e_state cs_error
# (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
-> build_operator_expression [(symb1, prio1, is_fun1, left1) : left_appls]
middle_exp (symb2, prio2, is_fun2) right e_state cs_error
# optional_prio = determinePriority prio1 prio2
-> case optional_prio of
Yes priority
| priority
# (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
(new_left, e_state, cs_error) = buildApplication symb1 2 2 is_fun1 [left1,middle_exp] e_state cs_error
(left_appls, new_left, e_state, cs_error) = build_left_operand left_appls prio2 new_left e_state cs_error
-> build_operator_expression left_appls new_left (symb2, prio2, is_fun2) right e_state cs_error
# (middle_exp, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
-> build_operator_expression [(symb1, prio1, is_fun1, left1) : left_appls]
middle_exp (symb2, prio2, is_fun2) right e_state cs_error
No
-> (EE, e_state, checkError symb1.symb_name "conflicting priorities" cs_error)
No
# (right, e_state, cs_error) = combine_expressions left2 [] 0 e_state cs_error
(result_expr, e_state, cs_error) = buildApplication symb1 2 2 is_fun1 [left1,right] e_state cs_error
......@@ -1177,10 +1192,15 @@ where
build_left_operand [] _ result_expr e_state cs_error
= ([], result_expr, e_state, cs_error)
build_left_operand la=:[(symb, priol, is_fun, left) : left_appls] prior result_expr e_state cs_error
| priol > prior
# (result_expr, e_state, cs_error) = buildApplication symb 2 2 is_fun [left,result_expr] e_state cs_error
= build_left_operand left_appls prior result_expr e_state cs_error
= (la, result_expr, e_state, cs_error)
# optional_prio = determinePriority priol prior
= case optional_prio of
Yes priority
| priority
# (result_expr, e_state, cs_error) = buildApplication symb 2 2 is_fun [left,result_expr] e_state cs_error
-> build_left_operand left_appls prior result_expr e_state cs_error
-> (la, result_expr, e_state, cs_error)
No
-> (la, EE, e_state, checkError symb.symb_name "conflicting priorities" cs_error)
build_final_expression [] result_expr e_state cs_error
= (result_expr, e_state, cs_error)
......@@ -2234,7 +2254,7 @@ combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs
}
, icl_sizes
, { cs & cs_symbol_table = cs_symbol_table }
)->>("conversion_table",conversion_table)
)
where
add_to_conversion_table first_macro_index decl=:{dcl_ident=dcl_ident=:{id_info},dcl_kind,dcl_index,dcl_pos}
......@@ -2294,7 +2314,6 @@ where
# (rt_constructor, cs) = redirect_defined_symbol STE_Constructor td_pos rt_constructor cs
(rt_fields, cs) = redirect_field_symbols td_pos rt_fields cs
= ([ { td & td_rhs = RecordType { rt & rt_constructor = rt_constructor, rt_fields = rt_fields }} : new_type_defs ], cs)
// MW was add_type_def td=:{td_name, td_pos} new_type_defs cs
add_type_def td=:{td_name, td_pos, td_rhs = AbstractType _} new_type_defs cs
# cs_error = checkError "definition module" "abstract type not defined in implementation module"
(setErrorAdmin (newPosition td_name td_pos) cs.cs_error)
......
......@@ -151,5 +151,13 @@ instance <<< Token
instance toString Token, Priority
instance < Priority
/* Sjaak ... */
// instance < Priority
determinePriority :: !Priority !Priority -> Optional Bool
/* ... Sjaak */
......@@ -1216,6 +1216,9 @@ where
equal_args_of_tokens (ErrorToken id1) (ErrorToken id2) = id1 == id2
equal_args_of_tokens _ _ = True
/* Sjaak ... */
/*
instance < Priority
where
(<) (Prio assoc1 prio1) (Prio assoc2 prio2)
......@@ -1227,6 +1230,21 @@ where
(<) _ LeftAssoc = True
(<) LeftAssoc _ = False
(<) _ _ = True
*/
determinePriority :: !Priority !Priority -> Optional Bool
determinePriority (Prio assoc_left prio_left) (Prio assoc_right prio_right)
| prio_left == prio_right
= has_priority_over assoc_left assoc_right
= Yes (prio_left > prio_right)
where
has_priority_over LeftAssoc LeftAssoc = Yes True
has_priority_over RightAssoc RightAssoc = Yes False
has_priority_over _ _ = No
/* Sjaak ... */
instance toString Priority
where
......
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