| /* Implement actions for CHILL. |
| Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 |
| Free Software Foundation, Inc. |
| Authors: Per Bothner, Bill Cox, Michael Tiemann, Michael North |
| |
| This file is part of GNU CC. |
| |
| GNU CC is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 2, or (at your option) |
| any later version. |
| |
| GNU CC is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU General Public License for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with GNU CC; see the file COPYING. If not, write to |
| the Free Software Foundation, 59 Temple Place - Suite 330, |
| Boston, MA 02111-1307, USA. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "tree.h" |
| #include "rtl.h" |
| #include "expr.h" |
| #include "ch-tree.h" |
| #include "lex.h" |
| #include "flags.h" |
| #include "actions.h" |
| #include "obstack.h" |
| #include "assert.h" |
| #include "toplev.h" |
| |
| static int id_cmp PARAMS ((tree *, tree *)); |
| static void warn_unhandled PARAMS ((const char *)); |
| static tree adjust_return_value PARAMS ((tree, const char *)); |
| static tree update_else_range_for_int_const PARAMS ((tree, tree)); |
| static tree update_else_range_for_range PARAMS ((tree, tree, tree)); |
| static tree update_else_range_for_range_expr PARAMS ((tree, tree)); |
| static tree update_else_range_for_type PARAMS ((tree, tree)); |
| static tree compute_else_range PARAMS ((tree, tree, int)); |
| static tree check_case_value PARAMS ((tree, tree)); |
| static void chill_handle_case_label_range PARAMS ((tree, tree, tree)); |
| static tree chill_handle_multi_case_label_range PARAMS ((tree, tree, tree)); |
| static tree chill_handle_multi_case_else_label PARAMS ((tree)); |
| static tree chill_handle_multi_case_label PARAMS ((tree, tree)); |
| static tree chill_handle_multi_case_label_list PARAMS ((tree, tree)); |
| static void print_missing_cases PARAMS ((tree, const unsigned char *, long)); |
| |
| #define obstack_chunk_alloc xmalloc |
| #define obstack_chunk_free free |
| |
| /* reserved tag definitions */ |
| |
| #define TYPE_ID "id" |
| #define TAG_OBJECT "chill_object" |
| #define TAG_CLASS "chill_class" |
| |
| extern int flag_short_enums; |
| extern int current_nesting_level; |
| |
| extern struct obstack *expression_obstack, permanent_obstack; |
| extern struct obstack *current_obstack, *saveable_obstack; |
| |
| /* This flag is checked throughout the non-CHILL-specific |
| in the front end. */ |
| tree chill_integer_type_node; |
| tree chill_unsigned_type_node; |
| |
| /* Never used. Referenced from c-typeck.c, which we use. */ |
| int current_function_returns_value = 0; |
| int current_function_returns_null = 0; |
| |
| /* data imported from toplev.c */ |
| |
| extern char *dump_base_name; |
| |
| /* set from command line parameter, to exit after |
| grant file written, generating no code. */ |
| int grant_only_flag = 0; |
| |
| const char * |
| lang_identify () |
| { |
| return "chill"; |
| } |
| |
| |
| void |
| init_chill () |
| { |
| } |
| |
| void |
| print_lang_statistics () |
| { |
| } |
| |
| |
| void |
| lang_finish () |
| { |
| #if 0 |
| extern int errorcount, sorrycount; |
| |
| /* this should be the last action in compiling a module. |
| If there are other actions to be performed at lang_finish |
| please insert before this */ |
| |
| /* FIXME: in case of a syntax error, this leaves the grant file incomplete */ |
| /* for the moment we print a warning in case of errors and |
| continue granting */ |
| if ((errorcount || sorrycount) && grant_count) |
| { |
| warning ("%d errors, %d sorries, do granting", errorcount, sorrycount); |
| errorcount = sorrycount = 0; |
| } |
| #endif |
| } |
| |
| void |
| chill_check_decl (decl) |
| tree decl; |
| { |
| tree type = TREE_TYPE (decl); |
| static int alreadyWarned = 0; |
| |
| if (TREE_CODE (type) == RECORD_TYPE) /* && TREE_STATIC_TEMPLATE (type)) */ |
| { |
| if (!alreadyWarned) |
| { |
| error ("GNU compiler does not support statically allocated objects"); |
| alreadyWarned = 1; |
| } |
| error_with_decl (decl, "`%s' cannot be statically allocated"); |
| } |
| } |
| |
| /* Comparison function for sorting identifiers in RAISES lists. |
| Note that because IDENTIFIER_NODEs are unique, we can sort |
| them by address, saving an indirection. */ |
| static int |
| id_cmp (p1, p2) |
| tree *p1, *p2; |
| { |
| long diff = (long)TREE_VALUE (*p1) - (long)TREE_VALUE (*p2); |
| |
| return (diff < 0) ? -1 : (diff > 0); |
| } |
| |
| /* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions |
| listed in RAISES. */ |
| tree |
| build_exception_variant (type, raises) |
| tree type, raises; |
| { |
| int i; |
| tree v = TYPE_MAIN_VARIANT (type); |
| tree t, t2; |
| int constp = TYPE_READONLY (type); |
| int volatilep = TYPE_VOLATILE (type); |
| |
| if (!raises) |
| return build_type_variant (v, constp, volatilep); |
| |
| if (TREE_CHAIN (raises)) |
| { /* Sort the list */ |
| tree *a = (tree *)alloca ((list_length (raises)+1) * sizeof (tree)); |
| for (i = 0, t = raises; t; t = TREE_CHAIN (t), i++) |
| a[i] = t; |
| /* NULL terminator for list. */ |
| a[i] = NULL_TREE; |
| qsort (a, i, sizeof (tree), |
| (int (*) PARAMS ((const void*, const void*))) id_cmp); |
| while (i--) |
| TREE_CHAIN (a[i]) = a[i+1]; |
| raises = a[0]; |
| } |
| |
| for (v = TYPE_NEXT_VARIANT (v); v; v = TYPE_NEXT_VARIANT (v)) |
| { |
| if (TYPE_READONLY (v) != constp |
| || TYPE_VOLATILE (v) != volatilep) |
| continue; |
| |
| t = raises; |
| t2 = TYPE_RAISES_EXCEPTIONS (v); |
| while (t && t2) |
| { |
| if (TREE_TYPE (t) == TREE_TYPE (t2)) |
| { |
| t = TREE_CHAIN (t); |
| t2 = TREE_CHAIN (t2); |
| } |
| else break; |
| } |
| if (t || t2) |
| continue; |
| /* List of exceptions raised matches previously found list. |
| |
| @@ Nice to free up storage used in consing up the |
| @@ list of exceptions raised. */ |
| return v; |
| } |
| |
| /* Need to build a new variant. */ |
| if (TREE_PERMANENT (type)) |
| { |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| v = copy_node (type); |
| pop_obstacks (); |
| } |
| else |
| v = copy_node (type); |
| |
| TYPE_NEXT_VARIANT (v) = TYPE_NEXT_VARIANT (type); |
| TYPE_NEXT_VARIANT (type) = v; |
| if (raises && ! TREE_PERMANENT (raises)) |
| { |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| raises = copy_list (raises); |
| pop_obstacks (); |
| } |
| TYPE_RAISES_EXCEPTIONS (v) = raises; |
| return v; |
| } |
| #if 0 |
| |
| tree |
| build_rts_call (name, type, args) |
| const char *name; |
| tree type, args; |
| { |
| tree decl = lookup_name (get_identifier (name)); |
| tree converted_args = NULL_TREE; |
| tree result, length = NULL_TREE; |
| |
| assert (decl != NULL_TREE); |
| while (args) |
| { |
| tree arg = TREE_VALUE (args); |
| if (TREE_CODE (TREE_TYPE (arg)) == SET_TYPE |
| || TREE_CODE (TREE_TYPE (arg)) == ARRAY_TYPE) |
| { |
| length = size_in_bytes (TREE_TYPE (arg)); |
| arg = build_chill_addr_expr (arg, (char *)0); |
| } |
| converted_args = tree_cons (NULL_TREE, arg, converted_args); |
| args = TREE_CHAIN (args); |
| } |
| if (length != NULL_TREE) |
| converted_args = tree_cons (NULL_TREE, length, converted_args); |
| converted_args = nreverse (converted_args); |
| result = build_chill_function_call (decl, converted_args); |
| if (TREE_CODE (type) == SET_TYPE || TREE_CODE (type) == ARRAY_TYPE) |
| result = build1 (INDIRECT_REF, type, result); |
| else |
| result = convert (type, result); |
| return result; |
| } |
| #endif |
| |
| /* |
| * queue name of unhandled exception |
| * to avoid multiple unhandled warnings |
| * in one compilation module |
| */ |
| |
| struct already_type |
| { |
| struct already_type *next; |
| char *name; |
| }; |
| |
| static struct already_type *already_warned = 0; |
| |
| static void |
| warn_unhandled (ex) |
| const char *ex; |
| { |
| struct already_type *p = already_warned; |
| |
| while (p) |
| { |
| if (!strcmp (p->name, ex)) |
| return; |
| p = p->next; |
| } |
| |
| /* not yet warned */ |
| p = (struct already_type *)xmalloc (sizeof (struct already_type)); |
| p->next = already_warned; |
| p->name = xstrdup (ex); |
| already_warned = p; |
| pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex); |
| } |
| |
| /* |
| * build a call to the following function: |
| * void __cause_ex1 (char* ex, const char *file, |
| * const unsigned lineno); |
| * if the exception is handled or |
| * void __unhandled_ex (char *ex, char *file, unsigned lineno) |
| * if the exception is not handled. |
| */ |
| tree |
| build_cause_exception (exp_name, warn_if_unhandled) |
| tree exp_name; |
| int warn_if_unhandled; |
| { |
| /* We don't use build_rts_call() here, because the string (array of char) |
| would be followed by its length in the parameter list built by |
| build_rts_call, and the runtime routine doesn't want a length parameter.*/ |
| tree exp_decl = build_chill_exception_decl (IDENTIFIER_POINTER (exp_name)); |
| tree function, fname, lineno, result; |
| int handled = is_handled (exp_name); |
| |
| switch (handled) |
| { |
| case 0: |
| /* no handler */ |
| if (warn_if_unhandled) |
| warn_unhandled (IDENTIFIER_POINTER (exp_name)); |
| function = lookup_name (get_identifier ("__unhandled_ex")); |
| fname = force_addr_of (get_chill_filename ()); |
| lineno = get_chill_linenumber (); |
| break; |
| case 1: |
| /* local handler */ |
| function = lookup_name (get_identifier ("__cause_ex1")); |
| fname = force_addr_of (get_chill_filename ()); |
| lineno = get_chill_linenumber (); |
| break; |
| case 2: |
| /* function may propagate this exception */ |
| function = lookup_name (get_identifier ("__cause_ex1")); |
| fname = lookup_name (get_identifier (CALLER_FILE)); |
| if (fname == NULL_TREE) |
| fname = error_mark_node; |
| lineno = lookup_name (get_identifier (CALLER_LINE)); |
| if (lineno == NULL_TREE) |
| lineno = error_mark_node; |
| break; |
| default: |
| abort(); |
| } |
| result = |
| build_chill_function_call (function, |
| tree_cons (NULL_TREE, build_chill_addr_expr (exp_decl, (char *)0), |
| tree_cons (NULL_TREE, fname, |
| tree_cons (NULL_TREE, lineno, NULL_TREE)))); |
| return result; |
| } |
| |
| void |
| expand_cause_exception (exp_name) |
| tree exp_name; |
| { |
| expand_expr_stmt (build_cause_exception (exp_name, 1)); |
| } |
| |
| /* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE); |
| otherwise return EXPR. */ |
| |
| tree |
| check_expression (expr, condition, exception) |
| tree expr, condition, exception; |
| { |
| if (integer_zerop (condition)) |
| return expr; |
| else |
| return build (COMPOUND_EXPR, TREE_TYPE (expr), |
| fold (build (TRUTH_ANDIF_EXPR, boolean_type_node, |
| condition, build_cause_exception (exception, 0))), |
| expr); |
| } |
| |
| /* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT, |
| somewhat optimized and with some warnings suppressed. |
| If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes. */ |
| |
| tree |
| test_range (value, lo_limit, hi_limit) |
| tree value, lo_limit, hi_limit; |
| { |
| if (lo_limit || hi_limit) |
| { |
| int old_inhibit_warnings = inhibit_warnings; |
| tree lo_check, hi_check, check; |
| |
| /* This is a hack so that `shorten_compare' doesn't warn the |
| user about useless range checks that are too much work to |
| optimize away here. */ |
| inhibit_warnings = 1; |
| |
| lo_check = lo_limit ? |
| fold (build_compare_discrete_expr (LT_EXPR, value, lo_limit)) : |
| boolean_false_node; /* fake passing the check */ |
| |
| hi_check = hi_limit ? |
| fold (build_compare_discrete_expr (GT_EXPR, value, hi_limit)) : |
| boolean_false_node; /* fake passing the check */ |
| |
| if (lo_check == boolean_false_node) |
| check = hi_check; |
| else if (hi_check == boolean_false_node) |
| check = lo_check; |
| else |
| check = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, |
| lo_check, hi_check)); |
| |
| inhibit_warnings = old_inhibit_warnings; |
| return check; |
| } |
| else |
| return boolean_false_node; |
| } |
| |
| /* Return EXPR, except if range_checking is on, return an expression |
| that also checks that value >= low_limit && value <= hi_limit. |
| If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes. */ |
| |
| tree |
| check_range (expr, value, lo_limit, hi_limit) |
| tree expr, value, lo_limit, hi_limit; |
| { |
| tree check = test_range (value, lo_limit, hi_limit); |
| if (!integer_zerop (check)) |
| { |
| if (current_function_decl == NULL_TREE) |
| { |
| if (TREE_CODE (check) == INTEGER_CST) |
| error ("range failure (not inside function)"); |
| else |
| warning ("possible range failure (not inside function)"); |
| } |
| else |
| { |
| if (TREE_CODE (check) == INTEGER_CST) |
| warning ("expression will always cause RANGEFAIL"); |
| if (range_checking) |
| expr = check_expression (expr, check, |
| ridpointers[(int) RID_RANGEFAIL]); |
| } |
| } |
| return expr; |
| } |
| |
| /* Same as EXPR, except raise EMPTY if EXPR is NULL. */ |
| |
| tree |
| check_non_null (expr) |
| tree expr; |
| { |
| if (empty_checking) |
| { |
| expr = save_if_needed (expr); |
| return check_expression (expr, |
| build_compare_expr (EQ_EXPR, |
| expr, null_pointer_node), |
| ridpointers[(int) RID_EMPTY]); |
| } |
| return expr; |
| } |
| |
| /* There are four conditions to generate a runtime check: |
| 1) assigning a longer INT to a shorter (signs irrelevant) |
| 2) assigning a signed to an unsigned |
| 3) assigning an unsigned to a signed of the same size. |
| 4) TYPE is a discrete subrange */ |
| |
| tree |
| chill_convert_for_assignment (type, expr, place) |
| tree type, expr; |
| const char *place; /* location description for error messages */ |
| { |
| tree ttype = type; |
| tree etype = TREE_TYPE (expr); |
| tree result; |
| |
| if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) |
| return error_mark_node; |
| if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) |
| return expr; |
| if (TREE_CODE (expr) == TYPE_DECL) |
| { |
| error ("right hand side of assignment is a mode"); |
| return error_mark_node; |
| } |
| |
| if (! CH_COMPATIBLE (expr, type)) |
| { |
| error ("incompatible modes in %s", place); |
| return error_mark_node; |
| } |
| |
| if (TREE_CODE (type) == REFERENCE_TYPE) |
| ttype = TREE_TYPE (ttype); |
| if (etype && TREE_CODE (etype) == REFERENCE_TYPE) |
| etype = TREE_TYPE (etype); |
| |
| if (etype |
| && (CH_STRING_TYPE_P (ttype) |
| || (chill_varying_type_p (ttype) |
| && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype)))) |
| && (CH_STRING_TYPE_P (etype) |
| || (chill_varying_type_p (etype) |
| && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype))))) |
| { |
| tree cond; |
| if (range_checking) |
| expr = save_if_needed (expr); |
| cond = string_assignment_condition (ttype, expr); |
| if (TREE_CODE (cond) == INTEGER_CST) |
| { |
| if (integer_zerop (cond)) |
| { |
| error ("bad string length in %s", place); |
| return error_mark_node; |
| } |
| /* Otherwise, the condition is always true, so no runtime test. */ |
| } |
| else if (range_checking) |
| expr = check_expression (expr, |
| invert_truthvalue (cond), |
| ridpointers[(int) RID_RANGEFAIL]); |
| } |
| |
| if (range_checking |
| && discrete_type_p (ttype) |
| && etype != NULL_TREE |
| && discrete_type_p (etype)) |
| { |
| int cond1 = tree_int_cst_lt (TYPE_SIZE (ttype), |
| TYPE_SIZE (etype)); |
| int cond2 = TREE_UNSIGNED (ttype) |
| && (! TREE_UNSIGNED (etype)); |
| int cond3 = (! TREE_UNSIGNED (type)) |
| && TREE_UNSIGNED (etype) |
| && tree_int_cst_equal (TYPE_SIZE (ttype), |
| TYPE_SIZE (etype)); |
| int cond4 = TREE_TYPE (ttype) |
| && discrete_type_p (TREE_TYPE (ttype)); |
| |
| if (cond1 || cond2 || cond3 || cond4) |
| { |
| tree type_min = TYPE_MIN_VALUE (ttype); |
| tree type_max = TYPE_MAX_VALUE (ttype); |
| |
| expr = save_if_needed (expr); |
| if (expr && type_min && type_max) |
| expr = check_range (expr, expr, type_min, type_max); |
| } |
| } |
| result = convert (type, expr); |
| |
| /* If the type is a array of PACK bits and the expression is an array |
| constructor, then build a CONSTRUCTOR for a bitstring. Bitstrings are |
| zero based, so decrement the value of each CONSTRUCTOR element by the |
| amount of the lower bound of the array. */ |
| if (TREE_CODE (type) == ARRAY_TYPE && TYPE_PACKED (type) |
| && TREE_CODE (result) == CONSTRUCTOR) |
| { |
| tree domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); |
| tree new_list = NULL_TREE; |
| unsigned HOST_WIDE_INT index; |
| tree element; |
| |
| for (element = TREE_OPERAND (result, 1); |
| element != NULL_TREE; |
| element = TREE_CHAIN (element)) |
| { |
| if (!tree_int_cst_equal (TREE_VALUE (element), integer_zero_node)) |
| { |
| tree purpose = TREE_PURPOSE (element); |
| switch (TREE_CODE (purpose)) |
| { |
| case INTEGER_CST: |
| new_list |
| = tree_cons (NULL_TREE, |
| fold (build (MINUS_EXPR, TREE_TYPE (purpose), |
| purpose, domain_min)), |
| new_list); |
| break; |
| case RANGE_EXPR: |
| for (index = TREE_INT_CST_LOW (TREE_OPERAND (purpose, 0)); |
| index <= TREE_INT_CST_LOW (TREE_OPERAND (purpose, 1)); |
| index++) |
| new_list = tree_cons (NULL_TREE, |
| fold (build (MINUS_EXPR, |
| integer_type_node, |
| build_int_2 (index, 0), |
| domain_min)), |
| new_list); |
| break; |
| default: |
| abort (); |
| } |
| } |
| } |
| result = copy_node (result); |
| TREE_OPERAND (result, 1) = nreverse (new_list); |
| TREE_TYPE (result) = build_bitstring_type (TYPE_SIZE (type)); |
| } |
| |
| return result; |
| } |
| |
| /* Check that EXPR has valid type for a RETURN or RESULT expression, |
| converting to the right type. ACTION is "RESULT" or "RETURN". */ |
| |
| static tree |
| adjust_return_value (expr, action) |
| tree expr; |
| const char *action; |
| { |
| tree type = TREE_TYPE (TREE_TYPE (current_function_decl)); |
| |
| if (TREE_CODE (type) == REFERENCE_TYPE) |
| { |
| if (CH_LOCATION_P (expr)) |
| { |
| if (! CH_READ_COMPATIBLE (TREE_TYPE (type), |
| TREE_TYPE (expr))) |
| { |
| error ("mode mismatch in %s expression", action); |
| return error_mark_node; |
| } |
| return convert (type, expr); |
| } |
| else |
| { |
| error ("%s expression must be referable", action); |
| return error_mark_node; |
| } |
| } |
| else if (! CH_COMPATIBLE (expr, type)) |
| { |
| error ("mode mismatch in %s expression", action); |
| return error_mark_node; |
| } |
| return convert (type, expr); |
| } |
| |
| void |
| chill_expand_result (expr, result_or_return) |
| tree expr; |
| int result_or_return; |
| { |
| tree type; |
| const char *action_name = result_or_return ? "RESULT" : "RETURN"; |
| |
| if (pass == 1) |
| return; |
| |
| if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) |
| return; |
| |
| CH_FUNCTION_SETS_RESULT (current_function_decl) = 1; |
| |
| if (chill_at_module_level || global_bindings_p ()) |
| error ("%s not allowed outside a PROC", action_name); |
| |
| result_never_set = 0; |
| |
| if (chill_result_decl == NULL_TREE) |
| { |
| error ("%s action in PROC with no declared RESULTS", action_name); |
| return; |
| } |
| type = TREE_TYPE (chill_result_decl); |
| |
| if (TREE_CODE (type) == ERROR_MARK) |
| return; |
| |
| expr = adjust_return_value (expr, action_name); |
| |
| expand_expr_stmt (build_chill_modify_expr (chill_result_decl, expr)); |
| } |
| |
| /* |
| * error if EXPR not NULL and procedure doesn't |
| * have a return type; |
| * warning if EXPR NULL, |
| * procedure *has* a return type, and a previous |
| * RESULT actions hasn't saved a return value. |
| */ |
| void |
| chill_expand_return (expr, implicit) |
| tree expr; |
| int implicit; /* 1 if an implicit return at end of function. */ |
| { |
| tree valtype; |
| |
| if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK) |
| return; |
| if (chill_at_module_level || global_bindings_p ()) |
| { |
| error ("RETURN not allowed outside PROC"); |
| return; |
| } |
| |
| if (pass == 1) |
| return; |
| |
| result_never_set = 0; |
| |
| valtype = TREE_TYPE (TREE_TYPE (current_function_decl)); |
| if (TREE_CODE (valtype) == VOID_TYPE) |
| { |
| if (expr != NULL_TREE) |
| error ("RETURN with a value, in PROC returning void"); |
| expand_null_return (); |
| } |
| else if (TREE_CODE (valtype) != ERROR_MARK) |
| { |
| if (expr == NULL_TREE) |
| { |
| if (!CH_FUNCTION_SETS_RESULT (current_function_decl) |
| && !implicit) |
| warning ("RETURN with no value and no RESULT action in procedure"); |
| expr = chill_result_decl; |
| } |
| else |
| expr = adjust_return_value (expr, "RETURN"); |
| expr = build (MODIFY_EXPR, valtype, |
| DECL_RESULT (current_function_decl), |
| expr); |
| TREE_SIDE_EFFECTS (expr) = 1; |
| expand_return (expr); |
| } |
| } |
| |
| void |
| lookup_and_expand_goto (name) |
| tree name; |
| { |
| if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK) |
| return; |
| if (!ignoring) |
| { |
| tree decl = lookup_name (name); |
| if (decl == NULL || TREE_CODE (decl) != LABEL_DECL) |
| error ("no label named `%s'", IDENTIFIER_POINTER (name)); |
| else if (DECL_CONTEXT (decl) != current_function_decl) |
| error ("cannot GOTO label `%s' outside current function", |
| IDENTIFIER_POINTER (name)); |
| else |
| { |
| TREE_USED (decl) = 1; |
| expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl)); |
| expand_goto (decl); |
| } |
| } |
| } |
| |
| void |
| lookup_and_handle_exit (name) |
| tree name; |
| { |
| if (name == NULL_TREE || TREE_CODE (name) == ERROR_MARK) |
| return; |
| if (!ignoring) |
| { |
| tree label = munge_exit_label (name); |
| tree decl = lookup_name (label); |
| if (decl == NULL || TREE_CODE (decl) != LABEL_DECL) |
| error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name)); |
| else if (DECL_CONTEXT (decl) != current_function_decl) |
| error ("cannot EXIT label `%s' outside current function", |
| IDENTIFIER_POINTER (name)); |
| else |
| { |
| TREE_USED (decl) = 1; |
| expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl)); |
| expand_goto (decl); |
| } |
| } |
| } |
| |
| /* ELSE-range handling: The else-range is a chain of trees which collectively |
| represent the ranges to be tested for the (ELSE) case label. Each element in |
| the chain represents a range to be tested. The boundaries of the range are |
| represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */ |
| |
| /* This function updates the else-range by removing the given integer constant. */ |
| static tree |
| update_else_range_for_int_const (else_range, label) |
| tree else_range, label; |
| { |
| int lowval = 0, highval = 0; |
| int label_value = TREE_INT_CST_LOW (label); |
| tree this_range, prev_range, new_range; |
| |
| /* First, find the range element containing the integer, if it exists. */ |
| prev_range = NULL_TREE; |
| for (this_range = else_range ; |
| this_range != NULL_TREE; |
| this_range = TREE_CHAIN (this_range)) |
| { |
| lowval = TREE_INT_CST_LOW (TREE_PURPOSE (this_range)); |
| highval = TREE_INT_CST_LOW (TREE_VALUE (this_range)); |
| if (label_value >= lowval && label_value <= highval) |
| break; |
| prev_range = this_range; |
| } |
| |
| /* If a range element containing the integer was found, then update the range. */ |
| if (this_range != NULL_TREE) |
| { |
| tree next = TREE_CHAIN (this_range); |
| if (label_value == lowval) |
| { |
| /* The integer is the lower bound of the range element. If it is also the |
| upper bound, then remove this range element, otherwise update it. */ |
| if (label_value == highval) |
| { |
| if (prev_range == NULL_TREE) |
| else_range = next; |
| else |
| TREE_CHAIN (prev_range) = next; |
| } |
| else |
| TREE_PURPOSE (this_range) = build_int_2 (label_value + 1, 0); |
| } |
| else if (label_value == highval) |
| { |
| /* The integer is the upper bound of the range element, so ajust it. */ |
| TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0); |
| } |
| else |
| { |
| /* The integer is in the middle of the range element, so split it. */ |
| new_range = tree_cons ( |
| build_int_2 (label_value + 1, 0), TREE_VALUE (this_range), next); |
| TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0); |
| TREE_CHAIN (this_range) = new_range; |
| } |
| } |
| return else_range; |
| } |
| |
| /* Update the else-range to remove a range of values/ */ |
| static tree |
| update_else_range_for_range (else_range, low_target, high_target) |
| tree else_range, low_target, high_target; |
| { |
| tree this_range, prev_range, new_range, next_range; |
| int low_range_val = 0, high_range_val = 0; |
| int low_target_val = TREE_INT_CST_LOW (low_target); |
| int high_target_val = TREE_INT_CST_LOW (high_target); |
| |
| /* find the first else-range element which overlaps the target range. */ |
| prev_range = NULL_TREE; |
| for (this_range = else_range ; |
| this_range != NULL_TREE; |
| this_range = TREE_CHAIN (this_range)) |
| { |
| low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range)); |
| high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range)); |
| if ((low_target_val >= low_range_val && low_target_val <= high_range_val) |
| || (high_target_val >= low_range_val && high_target_val <= high_range_val)) |
| break; |
| prev_range = this_range; |
| } |
| if (this_range == NULL_TREE) |
| return else_range; |
| |
| /* This first else-range element might be truncated at the top or completely |
| contain the target range. */ |
| if (low_range_val < low_target_val) |
| { |
| next_range = TREE_CHAIN (this_range); |
| if (high_range_val > high_target_val) |
| { |
| new_range = tree_cons ( |
| build_int_2 (high_target_val + 1, 0), TREE_VALUE (this_range), next_range); |
| TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0); |
| TREE_CHAIN (this_range) = new_range; |
| return else_range; |
| } |
| |
| TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0); |
| if (next_range == NULL_TREE) |
| return else_range; |
| |
| prev_range = this_range; |
| this_range = next_range; |
| high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range)); |
| } |
| |
| /* There may then follow zero or more else-range elements which are completely |
| contained in the target range. */ |
| while (high_range_val <= high_target_val) |
| { |
| this_range = TREE_CHAIN (this_range); |
| if (prev_range == NULL_TREE) |
| else_range = this_range; |
| else |
| TREE_CHAIN (prev_range) = this_range; |
| |
| if (this_range == NULL_TREE) |
| return else_range; |
| high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range)); |
| } |
| |
| /* Finally, there may be a else-range element which is truncated at the bottom. */ |
| low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range)); |
| if (low_range_val <= high_target_val) |
| TREE_PURPOSE (this_range) = build_int_2 (high_target_val + 1, 0); |
| |
| return else_range; |
| } |
| |
| static tree |
| update_else_range_for_range_expr (else_range, label) |
| tree else_range, label; |
| { |
| if (TREE_OPERAND (label, 0) == NULL_TREE) |
| { |
| if (TREE_OPERAND (label, 1) == NULL_TREE) |
| else_range = NULL_TREE; /* (*) -- matches everything */ |
| } |
| else |
| else_range = update_else_range_for_range ( |
| else_range, TREE_OPERAND (label, 0), TREE_OPERAND (label, 1)); |
| |
| return else_range; |
| } |
| |
| static tree |
| update_else_range_for_type (else_range, label) |
| tree else_range, label; |
| { |
| tree type = TREE_TYPE (label); |
| else_range = update_else_range_for_range ( |
| else_range, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type)); |
| return else_range; |
| } |
| |
| static tree |
| compute_else_range (selector, alternatives, selector_no) |
| tree selector, alternatives; |
| int selector_no; |
| { |
| /* Start with an else-range that spans the entire range of the selector type. */ |
| tree type = TREE_TYPE (TREE_VALUE (selector)); |
| tree range = tree_cons (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), NULL_TREE); |
| |
| /* Now remove the values represented by each case lebel specified for that |
| selector. The remaining range is the else-range. */ |
| for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives)) |
| { |
| tree label; |
| tree label_list = TREE_PURPOSE (alternatives); |
| int this_selector; |
| for (this_selector = 0; this_selector < selector_no ; ++this_selector) |
| label_list = TREE_CHAIN (label_list); |
| |
| for (label = TREE_VALUE (label_list); |
| label != NULL_TREE; |
| label = TREE_CHAIN (label)) |
| { |
| tree label_value = TREE_VALUE (label); |
| if (TREE_CODE (label_value) == INTEGER_CST) |
| range = update_else_range_for_int_const (range, label_value); |
| else if (TREE_CODE (label_value) == RANGE_EXPR) |
| range = update_else_range_for_range_expr (range, label_value); |
| else if (TREE_CODE (label_value) == TYPE_DECL) |
| range = update_else_range_for_type (range, label_value); |
| |
| if (range == NULL_TREE) |
| break; |
| } |
| } |
| |
| return range; |
| } |
| |
| void |
| compute_else_ranges (selectors, alternatives) |
| tree selectors, alternatives; |
| { |
| tree selector; |
| int selector_no = 0; |
| |
| for (selector = selectors; selector != NULL_TREE; selector = TREE_CHAIN (selector)) |
| { |
| if (ELSE_LABEL_SPECIFIED (selector)) |
| TREE_PURPOSE (selector) = |
| compute_else_range (selector, alternatives, selector_no); |
| selector_no++; |
| } |
| } |
| |
| static tree |
| check_case_value (label_value, selector) |
| tree label_value, selector; |
| { |
| if (TREE_CODE (label_value) == ERROR_MARK) |
| return label_value; |
| if (TREE_CODE (selector) == ERROR_MARK) |
| return selector; |
| |
| /* Z.200 (6.4 Case action) says: "The class of any discrete expression |
| in the case selector list must be compatible with the corresponding |
| (by position) class of the resulting list of classes of the case label |
| list occurrences ...". We don't actually construct the resulting |
| list of classes, but this test should be more-or-less equivalent. |
| I think... */ |
| if (!CH_COMPATIBLE_CLASSES (selector, label_value)) |
| { |
| error ("case selector not compatible with label"); |
| return error_mark_node; |
| } |
| |
| /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */ |
| STRIP_TYPE_NOPS (label_value); |
| |
| if (TREE_CODE (label_value) != INTEGER_CST) |
| { |
| error ("case label does not reduce to an integer constant"); |
| return error_mark_node; |
| } |
| |
| constant_expression_warning (label_value); |
| return label_value; |
| } |
| |
| void |
| chill_handle_case_default () |
| { |
| tree duplicate; |
| register tree label = build_decl (LABEL_DECL, NULL_TREE, |
| NULL_TREE); |
| int success = pushcase (NULL_TREE, 0, label, &duplicate); |
| |
| if (success == 1) |
| error ("ELSE label not within a CASE statement"); |
| #if 0 |
| else if (success == 2) |
| { |
| error ("multiple default labels found in a CASE statement"); |
| error_with_decl (duplicate, "this is the first ELSE label"); |
| } |
| #endif |
| } |
| |
| /* Handle cases label such as (I:J): or (modename): */ |
| |
| static void |
| chill_handle_case_label_range (min_value, max_value, selector) |
| tree min_value, max_value, selector; |
| { |
| register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); |
| min_value = check_case_value (min_value, selector); |
| max_value = check_case_value (max_value, selector); |
| if (TREE_CODE (min_value) != ERROR_MARK |
| && TREE_CODE (max_value) != ERROR_MARK) |
| { |
| tree duplicate; |
| int success = pushcase_range (min_value, max_value, |
| convert, label, &duplicate); |
| if (success == 1) |
| error ("label found outside of CASE statement"); |
| else if (success == 2) |
| { |
| error ("duplicate CASE value"); |
| error_with_decl (duplicate, "this is the first entry for that value"); |
| } |
| else if (success == 3) |
| error ("CASE value out of range"); |
| else if (success == 4) |
| error ("empty range"); |
| else if (success == 5) |
| error ("label within scope of cleanup or variable array"); |
| } |
| } |
| |
| void |
| chill_handle_case_label (label_value, selector) |
| tree label_value, selector; |
| { |
| if (label_value == NULL_TREE |
| || TREE_CODE (label_value) == ERROR_MARK) |
| return; |
| if (TREE_CODE (label_value) == RANGE_EXPR) |
| { |
| if (TREE_OPERAND (label_value, 0) == NULL_TREE) |
| chill_handle_case_default (); /* i.e. (ELSE): or (*): */ |
| else |
| chill_handle_case_label_range (TREE_OPERAND (label_value, 0), |
| TREE_OPERAND (label_value, 1), |
| selector); |
| } |
| else if (TREE_CODE (label_value) == TYPE_DECL) |
| { |
| tree type = TREE_TYPE (label_value); |
| if (! discrete_type_p (type)) |
| error ("mode in label is not discrete"); |
| else |
| chill_handle_case_label_range (TYPE_MIN_VALUE (type), |
| TYPE_MAX_VALUE (type), |
| selector); |
| } |
| else |
| { |
| register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); |
| |
| label_value = check_case_value (label_value, selector); |
| |
| if (TREE_CODE (label_value) != ERROR_MARK) |
| { |
| tree duplicate; |
| int success = pushcase (label_value, convert, label, &duplicate); |
| if (success == 1) |
| error ("label not within a CASE statement"); |
| else if (success == 2) |
| { |
| error ("duplicate case value"); |
| error_with_decl (duplicate, |
| "this is the first entry for that value"); |
| } |
| else if (success == 3) |
| error ("CASE value out of range"); |
| else if (success == 4) |
| error ("empty range"); |
| else if (success == 5) |
| error ("label within scope of cleanup or variable array"); |
| } |
| } |
| } |
| |
| int |
| chill_handle_single_dimension_case_label ( |
| selector, label_spec, expand_exit_needed, caseaction_flag |
| ) |
| tree selector, label_spec; |
| int *expand_exit_needed, *caseaction_flag; |
| { |
| tree labels, one_label; |
| int no_completeness_check = 0; |
| |
| if (*expand_exit_needed || *caseaction_flag == 1) |
| { |
| expand_exit_something (); |
| *expand_exit_needed = 0; |
| } |
| |
| for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels)) |
| for (one_label = TREE_VALUE (labels); one_label != NULL_TREE; |
| one_label = TREE_CHAIN (one_label)) |
| { |
| if (TREE_VALUE (one_label) == case_else_node) |
| no_completeness_check = 1; |
| |
| chill_handle_case_label (TREE_VALUE (one_label), selector); |
| } |
| |
| *caseaction_flag = 1; |
| |
| return no_completeness_check; |
| } |
| |
| static tree |
| chill_handle_multi_case_label_range (low, high, selector) |
| tree low, high, selector; |
| { |
| tree low_expr, high_expr, and_expr; |
| tree selector_type; |
| int low_target_val, high_target_val; |
| int low_type_val, high_type_val; |
| |
| /* we can eliminate some tests is the low and/or high value in the given range |
| are outside the range of the selector type. */ |
| low_target_val = TREE_INT_CST_LOW (low); |
| high_target_val = TREE_INT_CST_LOW (high); |
| selector_type = TREE_TYPE (selector); |
| low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type)); |
| high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type)); |
| |
| if (low_target_val > high_type_val || high_target_val < low_type_val) |
| return boolean_false_node; /* selector never in range */ |
| |
| if (low_type_val >= low_target_val) |
| { |
| if (high_type_val <= high_target_val) |
| return boolean_true_node; /* always in the range */ |
| return build_compare_expr (LE_EXPR, selector, high); |
| } |
| |
| if (high_type_val <= high_target_val) |
| return build_compare_expr (GE_EXPR, selector, low); |
| |
| /* The target range in completely within the range of the selector, but we |
| might be able to save a test if the upper bound is the same as the lower |
| bound. */ |
| if (low_target_val == high_target_val) |
| return build_compare_expr (EQ_EXPR, selector, low); |
| |
| /* No optimizations possible. Just generate tests against the upper and lower |
| bound of the target */ |
| low_expr = build_compare_expr (GE_EXPR, selector, low); |
| high_expr = build_compare_expr (LE_EXPR, selector, high); |
| and_expr = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr); |
| |
| return and_expr; |
| } |
| |
| static tree |
| chill_handle_multi_case_else_label (selector) |
| tree selector; |
| { |
| tree else_range, selector_value, selector_type; |
| tree low, high, larg; |
| |
| else_range = TREE_PURPOSE (selector); |
| if (else_range == NULL_TREE) |
| return boolean_false_node; /* no values in ELSE range */ |
| |
| /* Test each of the ranges in the else-range chain */ |
| selector_value = TREE_VALUE (selector); |
| selector_type = TREE_TYPE (selector_value); |
| low = convert (selector_type, TREE_PURPOSE (else_range)); |
| high = convert (selector_type, TREE_VALUE (else_range)); |
| larg = chill_handle_multi_case_label_range (low, high, selector_value); |
| |
| for (else_range = TREE_CHAIN (else_range); |
| else_range != NULL_TREE; |
| else_range = TREE_CHAIN (else_range)) |
| { |
| tree rarg; |
| low = convert (selector_type, TREE_PURPOSE (else_range)); |
| high = convert (selector_type, TREE_VALUE (else_range)); |
| rarg = chill_handle_multi_case_label_range (low, high, selector_value); |
| larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg); |
| } |
| |
| return larg; |
| } |
| |
| static tree |
| chill_handle_multi_case_label (selector, label) |
| tree selector, label; |
| { |
| tree expr = NULL_TREE; |
| |
| if (label == NULL_TREE || TREE_CODE (label) == ERROR_MARK) |
| return NULL_TREE; |
| |
| if (TREE_CODE (label) == INTEGER_CST) |
| { |
| int target_val = TREE_INT_CST_LOW (label); |
| tree selector_type = TREE_TYPE (TREE_VALUE (selector)); |
| int low_type_val = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type)); |
| int high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type)); |
| if (target_val < low_type_val || target_val > high_type_val) |
| expr = boolean_false_node; |
| else |
| expr = build_compare_expr (EQ_EXPR, TREE_VALUE (selector), label); |
| } |
| else if (TREE_CODE (label) == RANGE_EXPR) |
| { |
| if (TREE_OPERAND (label, 0) == NULL_TREE) |
| { |
| if (TREE_OPERAND (label, 1) == NULL_TREE) |
| expr = boolean_true_node; /* (*) -- matches everything */ |
| else |
| expr = chill_handle_multi_case_else_label (selector); |
| } |
| else |
| { |
| tree low = TREE_OPERAND (label, 0); |
| tree high = TREE_OPERAND (label, 1); |
| if (TREE_CODE (low) != INTEGER_CST) |
| { |
| error ("Lower bound of range must be a discrete literal expression"); |
| expr = error_mark_node; |
| } |
| if (TREE_CODE (high) != INTEGER_CST) |
| { |
| error ("Upper bound of range must be a discrete literal expression"); |
| expr = error_mark_node; |
| } |
| if (expr != error_mark_node) |
| { |
| expr = chill_handle_multi_case_label_range ( |
| low, high, TREE_VALUE (selector)); |
| } |
| } |
| } |
| else if (TREE_CODE (label) == TYPE_DECL) |
| { |
| tree type = TREE_TYPE (label); |
| if (! discrete_type_p (type)) |
| { |
| error ("mode in label is not discrete"); |
| expr = error_mark_node; |
| } |
| else |
| expr = chill_handle_multi_case_label_range ( |
| TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), TREE_VALUE (selector)); |
| } |
| else |
| { |
| error ("The CASE label is not valid"); |
| expr = error_mark_node; |
| } |
| |
| return expr; |
| } |
| |
| static tree |
| chill_handle_multi_case_label_list (selector, labels) |
| tree selector, labels; |
| { |
| tree one_label, larg, rarg; |
| |
| one_label = TREE_VALUE (labels); |
| larg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label)); |
| |
| for (one_label = TREE_CHAIN (one_label); |
| one_label != NULL_TREE; |
| one_label = TREE_CHAIN (one_label)) |
| { |
| rarg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label)); |
| larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg); |
| } |
| |
| return larg; |
| } |
| |
| tree |
| build_multi_case_selector_expression (selector_list, label_spec) |
| tree selector_list, label_spec; |
| { |
| tree labels, selector, larg, rarg; |
| |
| labels = label_spec; |
| selector = selector_list; |
| larg = chill_handle_multi_case_label_list(selector, labels); |
| |
| for (labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector); |
| labels != NULL_TREE && selector != NULL_TREE; |
| labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector)) |
| { |
| rarg = chill_handle_multi_case_label_list(selector, labels); |
| larg = build_chill_binary_op (TRUTH_ANDIF_EXPR, larg, rarg); |
| } |
| |
| if (labels != NULL_TREE || selector != NULL_TREE) |
| error ("The number of CASE selectors does not match the number of CASE label lists"); |
| |
| return larg; |
| } |
| |
| #define BITARRAY_TEST(ARRAY, INDEX) \ |
| ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\ |
| & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))) |
| #define BITARRAY_SET(ARRAY, INDEX) \ |
| ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\ |
| |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)) |
| |
| /* CASES_SEEN is a set (bitarray) of length COUNT. |
| For each element that is zero, print an error message, |
| assume the element have the given TYPE. */ |
| |
| static void |
| print_missing_cases (type, cases_seen, count) |
| tree type; |
| const unsigned char *cases_seen; |
| long count; |
| { |
| long i; |
| for (i = 0; i < count; i++) |
| { |
| if (BITARRAY_TEST(cases_seen, i) == 0) |
| { |
| char buf[20]; |
| long x = i; |
| long j; |
| tree t = type; |
| const char *err_val_name = "???"; |
| if (TYPE_MIN_VALUE (t) |
| && TREE_CODE (TYPE_MIN_VALUE (t)) == INTEGER_CST) |
| x += TREE_INT_CST_LOW (TYPE_MIN_VALUE (t)); |
| while (TREE_TYPE (t) != NULL_TREE) |
| t = TREE_TYPE (t); |
| switch (TREE_CODE (t)) |
| { |
| tree v; |
| case BOOLEAN_TYPE: |
| err_val_name = x ? "TRUE" : "FALSE"; |
| break; |
| case CHAR_TYPE: |
| { |
| char *bufptr; |
| if ((x >= ' ' && x < 127) && x != '\'' && x != '^') |
| sprintf (buf, "'%c'", (char)x); |
| else |
| sprintf (buf, "'^(%ld)'", x); |
| bufptr = buf; |
| j = i; |
| while (j < count && !BITARRAY_TEST(cases_seen, j)) |
| j++; |
| if (j > i + 1) |
| { |
| long y = x+j-i-1; |
| bufptr += strlen (bufptr); |
| if ((y >= ' ' && y < 127) && y != '\'' && y != '^') |
| sprintf (bufptr, "%s:'%c'", buf, (char)y); |
| else |
| sprintf (bufptr, "%s:'^(%ld)'", buf, y); |
| i = j - 1; |
| } |
| err_val_name = bufptr; |
| } |
| break; |
| case ENUMERAL_TYPE: |
| for (v = TYPE_VALUES (t); v && x; v = TREE_CHAIN (v)) |
| x--; |
| if (v) |
| err_val_name = IDENTIFIER_POINTER (TREE_PURPOSE (v)); |
| break; |
| default: |
| j = i; |
| while (j < count && !BITARRAY_TEST(cases_seen, j)) |
| j++; |
| if (j == i + 1) |
| sprintf (buf, "%ld", x); |
| else |
| sprintf (buf, "%ld:%ld", x, x+j-i-1); |
| i = j - 1; |
| err_val_name = buf; |
| break; |
| } |
| error ("incomplete CASE - %s not handled", err_val_name); |
| } |
| } |
| } |
| |
| void |
| check_missing_cases (type) |
| tree type; |
| { |
| int is_sparse; |
| /* For each possible selector value. a one iff it has been matched |
| by a case value alternative. */ |
| unsigned char *cases_seen; |
| /* The number of possible selector values. */ |
| HOST_WIDE_INT size = all_cases_count (type, &is_sparse); |
| HOST_WIDE_INT bytes_needed |
| = (size + HOST_BITS_PER_CHAR) / HOST_BITS_PER_CHAR; |
| |
| if (size == -1) |
| warning ("CASE selector with variable range"); |
| else if (size < 0 || size > 600000 |
| /* We deliberately use malloc here - not xmalloc. */ |
| || (cases_seen = (char*) malloc (bytes_needed)) == NULL) |
| warning ("too many cases to do CASE completeness testing"); |
| else |
| { |
| memset (cases_seen, 0, bytes_needed); |
| mark_seen_cases (type, cases_seen, size, is_sparse); |
| print_missing_cases (type, cases_seen, size); |
| free (cases_seen); |
| } |
| } |
| |
| /* |
| * We build an expression tree here because, in many contexts, |
| * we don't know the type of result that's desired. By the |
| * time we get to expanding the tree, we do know. |
| */ |
| tree |
| build_chill_case_expr (exprlist, casealtlist_expr, |
| optelsecase_expr) |
| tree exprlist, casealtlist_expr, optelsecase_expr; |
| { |
| return build (CASE_EXPR, NULL_TREE, exprlist, |
| optelsecase_expr ? |
| tree_cons (NULL_TREE, |
| optelsecase_expr, |
| casealtlist_expr) : |
| casealtlist_expr); |
| } |
| |
| /* This function transforms the selector_list and alternatives into a COND_EXPR. */ |
| tree |
| build_chill_multi_dimension_case_expr (selector_list, alternatives, else_expr) |
| tree selector_list, alternatives, else_expr; |
| { |
| tree expr; |
| |
| selector_list = check_case_selector_list (selector_list); |
| |
| if (alternatives == NULL_TREE) |
| return NULL_TREE; |
| |
| alternatives = nreverse (alternatives); |
| /* alternatives represents the CASE label specifications and resulting values in |
| the reverse order in which they appeared. |
| If there is an ELSE expression, then use it. If there is no |
| ELSE expression, make the last alternative (which is the first in the list) |
| into the ELSE expression. This is safe because, if the CASE is complete |
| (as required), then the last condition need not be checked anyway. */ |
| if (else_expr != NULL_TREE) |
| expr = else_expr; |
| else |
| { |
| expr = TREE_VALUE (alternatives); |
| alternatives = TREE_CHAIN (alternatives); |
| } |
| |
| for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives)) |
| { |
| tree value = TREE_VALUE (alternatives); |
| tree labels = TREE_PURPOSE (alternatives); |
| tree cond = build_multi_case_selector_expression(selector_list, labels); |
| expr = build_nt (COND_EXPR, cond, value, expr); |
| } |
| |
| return expr; |
| } |
| |
| |
| /* This is called with the assumption that RHS has been stabilized. |
| It has one purpose: to iterate through the CHILL list of LHS's */ |
| void |
| expand_assignment_action (loclist, modifycode, rhs) |
| tree loclist; |
| enum chill_tree_code modifycode; |
| tree rhs; |
| { |
| if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK |
| || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK) |
| return; |
| |
| if (TREE_CHAIN (loclist) != NULL_TREE) |
| { /* Multiple assignment */ |
| tree target; |
| if (TREE_TYPE (rhs) != NULL_TREE) |
| rhs = save_expr (rhs); |
| else if (TREE_CODE (rhs) == CONSTRUCTOR) |
| error ("type of tuple cannot be implicit in multiple assignent"); |
| else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR) |
| error ("conditional expression cannot be used in multiple assignent"); |
| else |
| error ("internal error - unknown type in multiple assignment"); |
| |
| if (modifycode != NOP_EXPR) |
| { |
| error ("no operator allowed in multiple assignment,"); |
| modifycode = NOP_EXPR; |
| } |
| |
| for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target)) |
| { |
| if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)), |
| TREE_TYPE (TREE_VALUE (loclist)))) |
| { |
| error |
| ("location modes in multiple assignment are not equivalent"); |
| break; |
| } |
| } |
| } |
| for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist)) |
| chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs); |
| } |
| |
| void |
| chill_expand_assignment (lhs, modifycode, rhs) |
| tree lhs; |
| enum chill_tree_code modifycode; |
| tree rhs; |
| { |
| tree loc; |
| |
| while (TREE_CODE (lhs) == COMPOUND_EXPR) |
| { |
| expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0); |
| emit_queue (); |
| lhs = TREE_OPERAND (lhs, 1); |
| } |
| |
| if (TREE_CODE (lhs) == ERROR_MARK) |
| return; |
| |
| /* errors for assignment to BUFFER, EVENT locations. |
| what about SIGNALs? FIXME: Need similar test in |
| build_chill_function_call. */ |
| if (TREE_CODE (lhs) == IDENTIFIER_NODE) |
| { |
| tree decl = lookup_name (lhs); |
| if (decl) |
| { |
| tree type = TREE_TYPE (decl); |
| if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type)) |
| { |
| error ("You may not assign a value to a BUFFER or EVENT location"); |
| return; |
| } |
| } |
| } |
| |
| if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs)) |
| { |
| error ("can't assign value to READonly location"); |
| return; |
| } |
| if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs))) |
| { |
| error ("cannot assign to location with non-value property"); |
| return; |
| } |
| |
| if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE) |
| lhs = convert_from_reference (lhs); |
| |
| /* check for lhs is a location */ |
| loc = lhs; |
| while (1) |
| { |
| if (TREE_CODE (loc) == SLICE_EXPR) |
| loc = TREE_OPERAND (loc, 0); |
| else if (TREE_CODE (loc) == SET_IN_EXPR) |
| loc = TREE_OPERAND (loc, 1); |
| else |
| break; |
| } |
| if (! CH_LOCATION_P (loc)) |
| { |
| error ("lefthand side of assignment is not a location"); |
| return; |
| } |
| |
| /* If a binary op has been requested, combine the old LHS value with |
| the RHS producing the value we should actually store into the LHS. */ |
| |
| if (modifycode != NOP_EXPR) |
| { |
| lhs = stabilize_reference (lhs); |
| /* This is to handle border-line cases such |
| as: LHS OR := [I]. This seems to be permitted |
| by the letter of Z.200, though it violates |
| its spirit, since LHS:=LHS OR [I] is |
| *not* legal. */ |
| if (TREE_TYPE (rhs) == NULL_TREE) |
| rhs = convert (TREE_TYPE (lhs), rhs); |
| rhs = build_chill_binary_op (modifycode, lhs, rhs); |
| } |
| |
| rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment"); |
| |
| /* handle the LENGTH (vary_array) := expr action */ |
| loc = lhs; |
| if (TREE_CODE (loc) == NOP_EXPR) |
| loc = TREE_OPERAND (loc, 0); |
| if (TREE_CODE (loc) == COMPONENT_REF |
| && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0))) |
| && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id) |
| { |
| expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs); |
| } |
| else if (TREE_CODE (lhs) == SLICE_EXPR) |
| { |
| tree func = lookup_name (get_identifier ("__pscpy")); |
| tree dst = TREE_OPERAND (lhs, 0); |
| tree dst_offset = TREE_OPERAND (lhs, 1); |
| tree length = TREE_OPERAND (lhs, 2); |
| tree src, src_offset; |
| if (TREE_CODE (rhs) == SLICE_EXPR) |
| { |
| src = TREE_OPERAND (rhs, 0); |
| /* Should check that the TREE_OPERAND (src, 0) is |
| the same as length and powerserlen (src). FIXME */ |
| src_offset = TREE_OPERAND (rhs, 1); |
| } |
| else |
| { |
| src = rhs; |
| src_offset = integer_zero_node; |
| } |
| expand_expr_stmt (build_chill_function_call (func, |
| tree_cons (NULL_TREE, force_addr_of (dst), |
| tree_cons (NULL_TREE, powersetlen (dst), |
| tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset), |
| tree_cons (NULL_TREE, force_addr_of (src), |
| tree_cons (NULL_TREE, powersetlen (src), |
| tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset), |
| tree_cons (NULL_TREE, convert (long_unsigned_type_node, length), |
| NULL_TREE))))))))); |
| } |
| |
| else if (TREE_CODE (lhs) == SET_IN_EXPR) |
| { |
| tree from_pos = save_expr (TREE_OPERAND (lhs, 0)); |
| tree set = TREE_OPERAND (lhs, 1); |
| tree domain = TYPE_DOMAIN (TREE_TYPE (set)); |
| tree set_length |
| = fold (build (PLUS_EXPR, integer_type_node, |
| fold (build (MINUS_EXPR, integer_type_node, |
| TYPE_MAX_VALUE (domain), |
| TYPE_MIN_VALUE (domain))), |
| integer_one_node)); |
| tree filename = force_addr_of (get_chill_filename()); |
| |
| if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE) |
| sorry("bitstring slice"); |
| expand_expr_stmt ( |
| build_chill_function_call (lookup_name ( |
| get_identifier ("__setbitpowerset")), |
| tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"), |
| tree_cons (NULL_TREE, set_length, |
| tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain), |
| tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos), |
| tree_cons (NULL_TREE, rhs, |
| tree_cons (NULL_TREE, filename, |
| tree_cons (NULL_TREE, get_chill_linenumber(), |
| NULL_TREE))))))))); |
| } |
| |
| /* Handle arrays of packed bitfields. Currently, this is limited to bitfields |
| which are 1 bit wide, so use the powerset runtime function. */ |
| else if (TREE_CODE (lhs) == PACKED_ARRAY_REF) |
| { |
| tree from_pos = save_expr (TREE_OPERAND (lhs, 1)); |
| tree array = TREE_OPERAND (lhs, 0); |
| tree domain = TYPE_DOMAIN (TREE_TYPE (array)); |
| tree array_length = powersetlen (array); |
| tree filename = force_addr_of (get_chill_filename()); |
| expand_expr_stmt ( |
| build_chill_function_call (lookup_name ( |
| get_identifier ("__setbitpowerset")), |
| tree_cons (NULL_TREE, build_chill_addr_expr (array, "packed bitfield array"), |
| tree_cons (NULL_TREE, convert (long_unsigned_type_node, array_length), |
| tree_cons (NULL_TREE, convert (long_integer_type_node, |
| TYPE_MIN_VALUE (domain)), |
| tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos), |
| tree_cons (NULL_TREE, build1 (CONVERT_EXPR, boolean_type_node, rhs), |
| tree_cons (NULL_TREE, filename, |
| tree_cons (NULL_TREE, get_chill_linenumber(), |
| NULL_TREE))))))))); |
| } |
| |
| /* The following is probably superceded by the |
| above code for SET_IN_EXPR. FIXME! */ |
| else if (TREE_CODE (lhs) == BIT_FIELD_REF) |
| { |
| tree set = TREE_OPERAND (lhs, 0); |
| tree numbits = TREE_OPERAND (lhs, 1); |
| tree from_pos = save_expr (TREE_OPERAND (lhs, 2)); |
| tree domain = TYPE_DOMAIN (TREE_TYPE (set)); |
| tree set_length |
| = fold (build (PLUS_EXPR, integer_type_node, |
| fold (build (MINUS_EXPR, integer_type_node, |
| TYPE_MAX_VALUE (domain), |
| TYPE_MIN_VALUE (domain))), |
| integer_one_node)); |
| tree filename = force_addr_of (get_chill_filename()); |
| tree to_pos; |
| |
| switch (TREE_CODE (TREE_TYPE (rhs))) |
| { |
| case SET_TYPE: |
| to_pos = fold (build (MINUS_EXPR, integer_type_node, |
| fold (build (PLUS_EXPR, integer_type_node, |
| from_pos, numbits)), |
| integer_one_node)); |
| break; |
| case BOOLEAN_TYPE: |
| to_pos = from_pos; |
| break; |
| default: |
| abort (); |
| } |
| |
| if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE) |
| sorry("bitstring slice"); |
| expand_expr_stmt ( |
| build_chill_function_call( lookup_name ( |
| get_identifier ("__setbitpowerset")), |
| tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"), |
| tree_cons (NULL_TREE, set_length, |
| tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain), |
| tree_cons (NULL_TREE, from_pos, |
| tree_cons (NULL_TREE, rhs, |
| tree_cons (NULL_TREE, filename, |
| tree_cons (NULL_TREE, get_chill_linenumber(), |
| NULL_TREE))))))))); |
| } |
| |
| else |
| expand_expr_stmt (build_chill_modify_expr (lhs, rhs)); |
| } |
| |
| /* Also assumes that rhs has been stabilized */ |
| void |
| expand_varying_length_assignment (lhs, rhs) |
| tree lhs, rhs; |
| { |
| tree base_array, min_domain_val; |
| |
| pedwarn ("LENGTH on left-hand-side is non-portable"); |
| |
| if (! CH_LOCATION_P (lhs)) |
| { |
| error ("Can only set LENGTH of array location"); |
| return; |
| } |
| |
| /* cause a RANGE exception if rhs would cause a 'hole' in the array. */ |
| rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1); |
| |
| base_array = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)); |
| min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array)); |
| |
| lhs = build_component_ref (lhs, var_length_id); |
| rhs = fold (build (MINUS_EXPR, TREE_TYPE (rhs), rhs, min_domain_val)); |
| |
| expand_expr_stmt (build_chill_modify_expr (lhs, rhs)); |
| } |
| |
| void |
| push_action () |
| { |
| push_handler (); |
| if (ignoring) |
| return; |
| emit_line_note (input_filename, lineno); |
| } |