diff options
| -rw-r--r-- | frontend/check.icl | 71 | ||||
| -rw-r--r-- | frontend/scanner.dcl | 10 | ||||
| -rw-r--r-- | frontend/scanner.icl | 18 |
3 files changed, 72 insertions, 27 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 8505bfc..114f539 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -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) diff --git a/frontend/scanner.dcl b/frontend/scanner.dcl index 79aec04..2dae649 100644 --- a/frontend/scanner.dcl +++ b/frontend/scanner.dcl @@ -151,5 +151,13 @@ instance <<< Token instance toString Token, Priority -instance < Priority + +/* Sjaak ... */ + +// instance < Priority + +determinePriority :: !Priority !Priority -> Optional Bool + +/* ... Sjaak */ + diff --git a/frontend/scanner.icl b/frontend/scanner.icl index 1d579da..d718ae2 100644 --- a/frontend/scanner.icl +++ b/frontend/scanner.icl @@ -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 |