| /* Build expressions with type checking for CHILL compiler. |
| Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 |
| Free Software Foundation, Inc. |
| |
| 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. */ |
| |
| |
| /* This file is part of the CHILL front end. |
| It contains routines to build C expressions given their operands, |
| including computing the modes of the result, C-specific error checks, |
| and some optimization. |
| |
| There are also routines to build RETURN_STMT nodes and CASE_STMT nodes, |
| and to process initializations in declarations (since they work |
| like a strange sort of assignment). */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "tree.h" |
| #include "ch-tree.h" |
| #include "flags.h" |
| #include "rtl.h" |
| #include "expr.h" |
| #include "lex.h" |
| #include "toplev.h" |
| #include "output.h" |
| |
| /* forward declarations */ |
| static int chill_l_equivalent PARAMS ((tree, tree, struct mode_chain*)); |
| static tree extract_constant_from_buffer PARAMS ((tree, const unsigned char *, int)); |
| static int expand_constant_to_buffer PARAMS ((tree, unsigned char *, int)); |
| static tree build_empty_string PARAMS ((tree)); |
| static tree make_chill_pointer_type PARAMS ((tree, enum tree_code)); |
| static unsigned int min_precision PARAMS ((tree, int)); |
| static tree make_chill_range_type PARAMS ((tree, tree, tree)); |
| static void apply_chill_array_layout PARAMS ((tree)); |
| static int field_decl_cmp PARAMS ((tree *, tree*)); |
| static tree make_chill_struct_type PARAMS ((tree)); |
| static int apply_chill_field_layout PARAMS ((tree, int *)); |
| |
| /* |
| * This function checks an array access. |
| * It calls error (ERROR_MESSAGE) if the condition (index <= domain max value |
| * index >= domain min value) |
| * is not met at compile time, |
| * If a runtime test is required and permitted, |
| * check_expression is used to do so. |
| * the global RANGE_CHECKING flags controls the |
| * generation of runtime checking code. |
| */ |
| tree |
| valid_array_index_p (array, idx, error_message, is_varying_lhs) |
| tree array, idx; |
| const char *error_message; |
| int is_varying_lhs; |
| { |
| tree cond, low_limit, high_cond, atype, domain; |
| tree orig_index = idx; |
| enum chill_tree_code condition; |
| |
| if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK |
| || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK) |
| return error_mark_node; |
| |
| if (TREE_CODE (idx) == TYPE_DECL |
| || TREE_CODE_CLASS (TREE_CODE (idx)) == 't') |
| { |
| error ("array or string index is a mode (instead of a value)"); |
| return error_mark_node; |
| } |
| |
| atype = TREE_TYPE (array); |
| |
| if (chill_varying_type_p (atype)) |
| { |
| domain = TYPE_DOMAIN (CH_VARYING_ARRAY_TYPE (atype)); |
| high_cond = build_component_ref (array, var_length_id); |
| if (chill_varying_string_type_p (atype)) |
| { |
| if (is_varying_lhs) |
| condition = GT_EXPR; |
| else |
| condition = GE_EXPR; |
| } |
| else |
| condition = GT_EXPR; |
| } |
| else |
| { |
| domain = TYPE_DOMAIN (atype); |
| high_cond = TYPE_MAX_VALUE (domain); |
| condition = GT_EXPR; |
| } |
| |
| if (CH_STRING_TYPE_P (atype)) |
| { |
| if (! CH_SIMILAR (TREE_TYPE (orig_index), integer_type_node)) |
| { |
| error ("index is not an integer expression"); |
| return error_mark_node; |
| } |
| } |
| else |
| { |
| if (! CH_COMPATIBLE (orig_index, domain)) |
| { |
| error ("index not compatible with index mode"); |
| return error_mark_node; |
| } |
| } |
| |
| /* Convert BOOLS(1) to BOOL and CHARS(1) to CHAR. */ |
| if (flag_old_strings) |
| { |
| idx = convert_to_discrete (idx); |
| if (idx == NULL) /* should never happen */ |
| error ("index is not discrete"); |
| } |
| |
| /* we know we'll refer to this value twice */ |
| if (range_checking) |
| idx = save_expr (idx); |
| |
| low_limit = TYPE_MIN_VALUE (domain); |
| high_cond = build_compare_discrete_expr (condition, idx, high_cond); |
| |
| /* an invalid index expression meets this condition */ |
| cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, |
| build_compare_discrete_expr (LT_EXPR, idx, low_limit), |
| high_cond)); |
| |
| /* strip a redundant NOP_EXPR */ |
| if (TREE_CODE (cond) == NOP_EXPR |
| && TREE_TYPE (cond) == boolean_type_node |
| && TREE_CODE (TREE_OPERAND (cond, 0)) == INTEGER_CST) |
| cond = TREE_OPERAND (cond, 0); |
| |
| idx = convert (CH_STRING_TYPE_P (atype) ? integer_type_node : domain, |
| idx); |
| |
| if (TREE_CODE (cond) == INTEGER_CST) |
| { |
| if (tree_int_cst_equal (cond, boolean_false_node)) |
| return idx; /* condition met at compile time */ |
| error ("%s", error_message); /* condition failed at compile time */ |
| return error_mark_node; |
| } |
| else if (range_checking) |
| { |
| /* FIXME: often, several of these conditions will |
| be generated for the same source file and line number. |
| A great optimization would be to share the |
| cause_exception function call among them rather |
| than generating a cause_exception call for each. */ |
| return check_expression (idx, cond, |
| ridpointers[(int) RID_RANGEFAIL]); |
| } |
| else |
| return idx; /* don't know at compile time */ |
| } |
| |
| /* |
| * Extract a slice from an array, which could look like a |
| * SET_TYPE if it's a bitstring. The array could also be VARYING |
| * if the element type is CHAR. The min_value and length values |
| * must have already been checked with valid_array_index_p. No |
| * checking is done here. |
| */ |
| tree |
| build_chill_slice (array, min_value, length) |
| tree array, min_value, length; |
| { |
| tree result; |
| tree array_type = TREE_TYPE (array); |
| |
| if (!CH_REFERABLE (array) && TREE_CODE (array) != SAVE_EXPR |
| && (TREE_CODE (array) != COMPONENT_REF |
| || TREE_CODE (TREE_OPERAND (array, 0)) != SAVE_EXPR)) |
| { |
| if (!TREE_CONSTANT (array)) |
| warning ("possible internal error - slice argument is neither referable nor constant"); |
| else |
| { |
| /* Force to storage. |
| NOTE: This could mean multiple identical copies of |
| the same constant. FIXME. */ |
| tree mydecl = decl_temp1 (get_unique_identifier("SLICEE"), |
| array_type, 1, array, 0, 0); |
| TREE_READONLY (mydecl) = 1; |
| /* mark_addressable (mydecl); FIXME: necessary? */ |
| array = mydecl; |
| } |
| } |
| |
| /* |
| The code-generation which uses a slice tree needs not only to |
| know the dynamic upper and lower limits of that slice, but the |
| original static allocation, to use to build temps where one or both |
| of the dynamic limits must be calculated at runtime.. We pass the |
| dynamic size by building a new array_type whose limits are the |
| min_value and min_value + length values passed to us. |
| |
| The static allocation info is passed by using the parent array's |
| limits to compute a temp_size, which is passed in the lang_specific |
| field of the slice_type. */ |
| |
| if (TREE_CODE (array_type) == ARRAY_TYPE) |
| { |
| tree domain_type = TYPE_DOMAIN (array_type); |
| tree domain_min = TYPE_MIN_VALUE (domain_type); |
| tree domain_max |
| = fold (build (PLUS_EXPR, domain_type, |
| domain_min, |
| fold (build (MINUS_EXPR, integer_type_node, |
| length, integer_one_node)))); |
| tree index_type = build_chill_range_type (TYPE_DOMAIN (array_type), |
| domain_min, |
| domain_max); |
| |
| tree element_type = TREE_TYPE (array_type); |
| tree slice_type = build_simple_array_type (element_type, index_type, NULL_TREE); |
| tree slice_pointer_type; |
| tree max_size; |
| |
| if (CH_CHARS_TYPE_P (array_type)) |
| MARK_AS_STRING_TYPE (slice_type); |
| else |
| TYPE_PACKED (slice_type) = TYPE_PACKED (array_type); |
| |
| SET_CH_NOVELTY (slice_type, CH_NOVELTY (array_type)); |
| |
| if (TREE_CONSTANT (array) && host_integerp (min_value, 0) |
| && host_integerp (length, 0)) |
| { |
| unsigned HOST_WIDE_INT type_size = int_size_in_bytes (array_type); |
| unsigned char *buffer = (unsigned char *) alloca (type_size); |
| int delta = (int_size_in_bytes (element_type) |
| * (tree_low_cst (min_value, 0) |
| - tree_low_cst (domain_min, 0))); |
| |
| memset (buffer, 0, type_size); |
| if (expand_constant_to_buffer (array, buffer, type_size)) |
| { |
| result = extract_constant_from_buffer (slice_type, |
| buffer + delta, |
| type_size - delta); |
| if (result) |
| return result; |
| } |
| } |
| |
| /* Kludge used by case CONCAT_EXPR in chill_expand_expr. |
| Set TYPE_ARRAY_MAX_SIZE to a constant upper bound on the |
| bytes needed. */ |
| max_size = size_in_bytes (slice_type); |
| if (TREE_CODE (max_size) != INTEGER_CST) |
| { |
| max_size = TYPE_ARRAY_MAX_SIZE (array_type); |
| if (max_size == NULL_TREE) |
| max_size = size_in_bytes (array_type); |
| } |
| TYPE_ARRAY_MAX_SIZE (slice_type) = max_size; |
| |
| mark_addressable (array); |
| /* Contruct a SLICE_EXPR to represent a slice of a packed array of bits. */ |
| if (TYPE_PACKED (array_type)) |
| { |
| if (pass == 2 && TREE_CODE (length) != INTEGER_CST) |
| { |
| sorry ("bit array slice with non-constant length"); |
| return error_mark_node; |
| } |
| if (domain_min && ! integer_zerop (domain_min)) |
| min_value = size_binop (MINUS_EXPR, min_value, |
| convert (sizetype, domain_min)); |
| result = build (SLICE_EXPR, slice_type, array, min_value, length); |
| TREE_READONLY (result) |
| = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type)); |
| return result; |
| } |
| |
| slice_pointer_type = build_chill_pointer_type (slice_type); |
| if (TREE_CODE (min_value) == INTEGER_CST |
| && domain_min && TREE_CODE (domain_min) == INTEGER_CST |
| && compare_int_csts (EQ_EXPR, min_value, domain_min)) |
| result = fold (build1 (ADDR_EXPR, slice_pointer_type, array)); |
| else |
| { |
| min_value = convert (sizetype, min_value); |
| if (domain_min && ! integer_zerop (domain_min)) |
| min_value = size_binop (MINUS_EXPR, min_value, |
| convert (sizetype, domain_min)); |
| min_value = size_binop (MULT_EXPR, min_value, |
| size_in_bytes (element_type)); |
| result = fold (build (PLUS_EXPR, slice_pointer_type, |
| build1 (ADDR_EXPR, slice_pointer_type, |
| array), |
| convert (slice_pointer_type, min_value))); |
| } |
| /* Return the final array value. */ |
| result = fold (build1 (INDIRECT_REF, slice_type, result)); |
| TREE_READONLY (result) |
| = TREE_READONLY (array) | TYPE_READONLY (element_type); |
| return result; |
| } |
| else if (TREE_CODE (array_type) == SET_TYPE) /* actually a bitstring */ |
| { |
| if (pass == 2 && TREE_CODE (length) != INTEGER_CST) |
| { |
| sorry ("bitstring slice with non-constant length"); |
| return error_mark_node; |
| } |
| result = build (SLICE_EXPR, build_bitstring_type (length), |
| array, min_value, length); |
| TREE_READONLY (result) |
| = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type)); |
| return result; |
| } |
| else if (chill_varying_type_p (array_type)) |
| return build_chill_slice (varying_to_slice (array), min_value, length); |
| else |
| { |
| error ("slice operation on non-array, non-bitstring value not supported"); |
| return error_mark_node; |
| } |
| } |
| |
| static tree |
| build_empty_string (type) |
| tree type; |
| { |
| int orig_pass = pass; |
| tree range, result; |
| |
| range = build_chill_range_type (type, integer_zero_node, |
| integer_minus_one_node); |
| result = build_chill_array_type (type, |
| tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE); |
| pass = 2; |
| range = build_chill_range_type (type, integer_zero_node, |
| integer_minus_one_node); |
| result = build_chill_array_type (type, |
| tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE); |
| pass = orig_pass; |
| |
| return decl_temp1 (get_unique_identifier ("EMPTY_STRING"), |
| result, 0, NULL_TREE, 0, 0); |
| } |
| |
| /* We build the runtime range-checking as a separate list |
| * rather than making a compound_expr with min_value |
| * (for example), to control when that comparison gets |
| * generated. We cannot allow it in a TYPE_MAX_VALUE or |
| * TYPE_MIN_VALUE expression, for instance, because that code |
| * will get generated when the slice is laid out, which would |
| * put it outside the scope of an exception handler for the |
| * statement we're generating. I.e. we would be generating |
| * cause_exception calls which might execute before the |
| * necessary ch_link_handler call. |
| */ |
| tree |
| build_chill_slice_with_range (array, min_value, max_value) |
| tree array, min_value, max_value; |
| { |
| if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK |
| || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK |
| || max_value == NULL_TREE || TREE_CODE(max_value) == ERROR_MARK) |
| return error_mark_node; |
| |
| if (TREE_TYPE (array) == NULL_TREE |
| || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE |
| && TREE_CODE (TREE_TYPE (array)) != SET_TYPE |
| && !chill_varying_type_p (TREE_TYPE (array)))) |
| { |
| error ("can only take slice of array or string"); |
| return error_mark_node; |
| } |
| |
| array = save_if_needed (array); |
| |
| /* FIXME: test here for max_value >= min_value, except |
| for max_value == -1, min_value == 0 (empty string) */ |
| min_value = valid_array_index_p (array, min_value, |
| "slice lower limit out-of-range", 0); |
| if (TREE_CODE (min_value) == ERROR_MARK) |
| return min_value; |
| |
| /* FIXME: suppress this test if max_value is the LENGTH of a |
| varying array, which has presumably already been checked. */ |
| max_value = valid_array_index_p (array, max_value, |
| "slice upper limit out-of-range", 0); |
| if (TREE_CODE (max_value) == ERROR_MARK) |
| return error_mark_node; |
| |
| if (TREE_CODE (min_value) == INTEGER_CST |
| && TREE_CODE (max_value) == INTEGER_CST |
| && tree_int_cst_lt (max_value, min_value)) |
| return build_empty_string (TREE_TYPE (TREE_TYPE (array))); |
| |
| return |
| build_chill_slice |
| (array, min_value, |
| save_expr (fold (build (PLUS_EXPR, integer_type_node, |
| fold (build (MINUS_EXPR, integer_type_node, |
| max_value, min_value)), |
| integer_one_node)))); |
| } |
| |
| tree |
| build_chill_slice_with_length (array, min_value, length) |
| tree array, min_value, length; |
| { |
| tree max_index; |
| tree cond, high_cond, atype; |
| |
| if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK |
| || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK |
| || length == NULL_TREE || TREE_CODE(length) == ERROR_MARK) |
| return error_mark_node; |
| |
| if (TREE_TYPE (array) == NULL_TREE |
| || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE |
| && TREE_CODE (TREE_TYPE (array)) != SET_TYPE |
| && !chill_varying_type_p (TREE_TYPE (array)))) |
| { |
| error ("can only take slice of array or string"); |
| return error_mark_node; |
| } |
| |
| if (TREE_CONSTANT (length) |
| && tree_int_cst_lt (length, integer_zero_node)) |
| return build_empty_string (TREE_TYPE (TREE_TYPE (array))); |
| |
| array = save_if_needed (array); |
| min_value = save_expr (min_value); |
| length = save_expr (length); |
| |
| if (! CH_SIMILAR (TREE_TYPE (length), integer_type_node)) |
| { |
| error ("slice length is not an integer"); |
| length = integer_one_node; |
| } |
| |
| max_index = fold (build (MINUS_EXPR, integer_type_node, |
| fold (build (PLUS_EXPR, integer_type_node, |
| length, min_value)), |
| integer_one_node)); |
| max_index = convert_to_class (chill_expr_class (min_value), max_index); |
| |
| min_value = valid_array_index_p (array, min_value, |
| "slice start index out-of-range", 0); |
| if (TREE_CODE (min_value) == ERROR_MARK) |
| return error_mark_node; |
| |
| atype = TREE_TYPE (array); |
| |
| if (chill_varying_type_p (atype)) |
| high_cond = build_component_ref (array, var_length_id); |
| else |
| high_cond = TYPE_MAX_VALUE (TYPE_DOMAIN (atype)); |
| |
| /* an invalid index expression meets this condition */ |
| cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, |
| build_compare_discrete_expr (LT_EXPR, |
| length, integer_zero_node), |
| build_compare_discrete_expr (GT_EXPR, |
| max_index, high_cond))); |
| |
| if (TREE_CODE (cond) == INTEGER_CST) |
| { |
| if (! tree_int_cst_equal (cond, boolean_false_node)) |
| { |
| error ("slice length out-of-range"); |
| return error_mark_node; |
| } |
| |
| } |
| else if (range_checking) |
| { |
| min_value = check_expression (min_value, cond, |
| ridpointers[(int) RID_RANGEFAIL]); |
| } |
| |
| return build_chill_slice (array, min_value, length); |
| } |
| |
| tree |
| build_chill_array_ref (array, indexlist) |
| tree array, indexlist; |
| { |
| tree idx; |
| |
| if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK) |
| return error_mark_node; |
| if (indexlist == NULL_TREE || TREE_CODE (indexlist) == ERROR_MARK) |
| return error_mark_node; |
| |
| idx = TREE_VALUE (indexlist); /* handle first index */ |
| |
| idx = valid_array_index_p (array, idx, |
| "array index out-of-range", 0); |
| if (TREE_CODE (idx) == ERROR_MARK) |
| return error_mark_node; |
| |
| array = build_chill_array_ref_1 (array, idx); |
| |
| if (array && TREE_CODE (array) != ERROR_MARK |
| && TREE_CHAIN (indexlist)) |
| { |
| /* Z.200 (1988) section 4.2.8 says that: |
| <array> '(' <expression {',' <expression> }* ')' |
| is derived syntax (i.e. syntactic sugar) for: |
| <array> '(' <expression ')' { '(' <expression> ')' }* |
| The intent is clear if <array> has mode: ARRAY (...) ARRAY (...) XXX. |
| But what if <array> has mode: ARRAY (...) CHARS (N) |
| or: ARRAY (...) BOOLS (N). |
| Z.200 doesn't explicitly prohibit it, but the intent is unclear. |
| We'll allow it, since it seems reasonable and useful. |
| However, we won't allow it if <array> is: |
| ARRAY (...) PROC (...). |
| (The latter would make sense if we allowed general |
| Currying, which Chill doesn't.) */ |
| if (TREE_CODE (TREE_TYPE (array)) == ARRAY_TYPE |
| || chill_varying_type_p (TREE_TYPE (array)) |
| || CH_BOOLS_TYPE_P (TREE_TYPE (array))) |
| array = build_generalized_call (array, TREE_CHAIN (indexlist)); |
| else |
| error ("too many index expressions"); |
| } |
| return array; |
| } |
| |
| /* |
| * Don't error check the index in here. It's supposed to be |
| * checked by the caller. |
| */ |
| tree |
| build_chill_array_ref_1 (array, idx) |
| tree array, idx; |
| { |
| tree type; |
| tree domain; |
| tree rval; |
| |
| if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK |
| || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK) |
| return error_mark_node; |
| |
| if (chill_varying_type_p (TREE_TYPE (array))) |
| array = varying_to_slice (array); |
| |
| domain = TYPE_DOMAIN (TREE_TYPE (array)); |
| |
| #if 0 |
| if (! integer_zerop (TYPE_MIN_VALUE (domain))) |
| { |
| /* The C part of the compiler doesn't understand how to do |
| arithmetic with dissimilar enum types. So we check compatibility |
| here, and perform the math in INTEGER_TYPE. */ |
| if (TREE_CODE (TREE_TYPE (idx)) == ENUMERAL_TYPE |
| && chill_comptypes (TREE_TYPE (idx), domain, 0)) |
| idx = convert (TREE_TYPE (TYPE_MIN_VALUE (domain)), idx); |
| idx = build_binary_op (MINUS_EXPR, idx, TYPE_MIN_VALUE (domain), 0); |
| } |
| #endif |
| |
| if (CH_STRING_TYPE_P (TREE_TYPE (array))) |
| { |
| /* Could be bitstring or char string. */ |
| if (TREE_TYPE (TREE_TYPE (array)) == boolean_type_node) |
| { |
| rval = build (SET_IN_EXPR, boolean_type_node, idx, array); |
| TREE_READONLY (rval) = TREE_READONLY (array); |
| return rval; |
| } |
| } |
| |
| if (!discrete_type_p (TREE_TYPE (idx))) |
| { |
| error ("array index is not discrete"); |
| return error_mark_node; |
| } |
| |
| /* An array that is indexed by a non-constant |
| cannot be stored in a register; we must be able to do |
| address arithmetic on its address. |
| Likewise an array of elements of variable size. */ |
| if (TREE_CODE (idx) != INTEGER_CST |
| || (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))) != 0 |
| && TREE_CODE (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array)))) != INTEGER_CST)) |
| { |
| if (mark_addressable (array) == 0) |
| return error_mark_node; |
| } |
| |
| type = TREE_TYPE (TREE_TYPE (array)); |
| |
| /* Do constant folding */ |
| if (TREE_CODE (idx) == INTEGER_CST && TREE_CONSTANT (array)) |
| { |
| struct ch_class class; |
| class.kind = CH_VALUE_CLASS; |
| class.mode = type; |
| |
| if (TREE_CODE (array) == CONSTRUCTOR) |
| { |
| tree list = CONSTRUCTOR_ELTS (array); |
| for ( ; list != NULL_TREE; list = TREE_CHAIN (list)) |
| { |
| if (tree_int_cst_equal (TREE_PURPOSE (list), idx)) |
| return convert_to_class (class, TREE_VALUE (list)); |
| } |
| } |
| else if (TREE_CODE (array) == STRING_CST |
| && CH_CHARS_TYPE_P (TREE_TYPE (array))) |
| { |
| HOST_WIDE_INT i = tree_low_cst (idx, 0); |
| |
| if (i >= 0 && i < TREE_STRING_LENGTH (array)) |
| return |
| convert_to_class |
| (class, |
| build_int_2 |
| ((unsigned char) TREE_STRING_POINTER (array) [i], 0)); |
| } |
| } |
| |
| if (TYPE_PACKED (TREE_TYPE (array))) |
| rval = build (PACKED_ARRAY_REF, type, array, idx); |
| else |
| rval = build (ARRAY_REF, type, array, idx); |
| |
| /* Array ref is const/volatile if the array elements are |
| or if the array is. */ |
| TREE_READONLY (rval) = TREE_READONLY (array) | TYPE_READONLY (type); |
| TREE_SIDE_EFFECTS (rval) |
| |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array))) |
| | TREE_SIDE_EFFECTS (array)); |
| TREE_THIS_VOLATILE (rval) |
| |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array))) |
| /* This was added by rms on 16 Nov 91. |
| It fixes vol struct foo *a; a->elts[1] |
| in an inline function. |
| Hope it doesn't break something else. */ |
| | TREE_THIS_VOLATILE (array)); |
| return fold (rval); |
| } |
| |
| tree |
| build_chill_bitref (bitstring, indexlist) |
| tree bitstring, indexlist; |
| { |
| if (TREE_CODE (bitstring) == ERROR_MARK) |
| return bitstring; |
| if (TREE_CODE (indexlist) == ERROR_MARK) |
| return indexlist; |
| |
| if (TREE_CHAIN (indexlist) != NULL_TREE) |
| { |
| error ("invalid compound index for bitstring mode"); |
| return error_mark_node; |
| } |
| |
| if (TREE_CODE (indexlist) == TREE_LIST) |
| { |
| tree result = build (SET_IN_EXPR, boolean_type_node, |
| TREE_VALUE (indexlist), bitstring); |
| TREE_READONLY (result) = TREE_READONLY (bitstring); |
| return result; |
| } |
| else abort (); |
| } |
| |
| |
| int |
| discrete_type_p (type) |
| tree type; |
| { |
| return INTEGRAL_TYPE_P (type); |
| } |
| |
| /* Checks that EXP has discrete type, or can be converted to discrete. |
| Otherwise, returns NULL_TREE. |
| Normally returns the (possibly-converted) EXP. */ |
| |
| tree |
| convert_to_discrete (exp) |
| tree exp; |
| { |
| if (! discrete_type_p (TREE_TYPE (exp))) |
| { |
| if (flag_old_strings) |
| { |
| if (CH_CHARS_ONE_P (TREE_TYPE (exp))) |
| return convert (char_type_node, exp); |
| if (CH_BOOLS_ONE_P (TREE_TYPE (exp))) |
| return convert (boolean_type_node, exp); |
| } |
| return NULL_TREE; |
| } |
| return exp; |
| } |
| |
| /* Write into BUFFER the target-machine representation of VALUE. |
| Returns 1 on success, or 0 on failure. (Either the VALUE was |
| not constant, or we don't know how to do the conversion.) */ |
| |
| static int |
| expand_constant_to_buffer (value, buffer, buf_size) |
| tree value; |
| unsigned char *buffer; |
| int buf_size; |
| { |
| tree type = TREE_TYPE (value); |
| int size = int_size_in_bytes (type); |
| int i; |
| if (size < 0 || size > buf_size) |
| return 0; |
| switch (TREE_CODE (value)) |
| { |
| case INTEGER_CST: |
| { |
| unsigned HOST_WIDE_INT lo = TREE_INT_CST_LOW (value); |
| HOST_WIDE_INT hi = TREE_INT_CST_HIGH (value); |
| for (i = 0; i < size; i++) |
| { |
| /* Doesn't work if host and target BITS_PER_UNIT differ. */ |
| unsigned char byte = lo & ((1 << BITS_PER_UNIT) - 1); |
| |
| if (BYTES_BIG_ENDIAN) |
| buffer[size - i - 1] = byte; |
| else |
| buffer[i] = byte; |
| |
| rshift_double (lo, hi, BITS_PER_UNIT, BITS_PER_UNIT * size, |
| &lo, &hi, 0); |
| } |
| } |
| break; |
| case STRING_CST: |
| { |
| size = TREE_STRING_LENGTH (value); |
| if (size > buf_size) |
| return 0; |
| bcopy (TREE_STRING_POINTER (value), buffer, size); |
| break; |
| } |
| case CONSTRUCTOR: |
| if (TREE_CODE (type) == ARRAY_TYPE) |
| { |
| tree element_type = TREE_TYPE (type); |
| int element_size = int_size_in_bytes (element_type); |
| tree list = CONSTRUCTOR_ELTS (value); |
| HOST_WIDE_INT next_index; |
| HOST_WIDE_INT min_index = 0; |
| if (element_size < 0) |
| return 0; |
| |
| if (TYPE_DOMAIN (type) != 0) |
| { |
| tree min_val = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); |
| if (min_val) |
| { |
| if (! host_integerp (min_val, 0)) |
| return 0; |
| else |
| min_index = tree_low_cst (min_val, 0); |
| } |
| } |
| |
| next_index = min_index; |
| |
| for (; list != NULL_TREE; list = TREE_CHAIN (list)) |
| { |
| HOST_WIDE_INT offset; |
| HOST_WIDE_INT last_index; |
| tree purpose = TREE_PURPOSE (list); |
| |
| if (purpose) |
| { |
| if (host_integerp (purpose, 0)) |
| last_index = next_index = tree_low_cst (purpose, 0); |
| else if (TREE_CODE (purpose) == RANGE_EXPR) |
| { |
| next_index = tree_low_cst (TREE_OPERAND (purpose, 0), 0); |
| last_index = tree_low_cst (TREE_OPERAND (purpose, 1), 0); |
| } |
| else |
| return 0; |
| } |
| else |
| last_index = next_index; |
| for ( ; next_index <= last_index; next_index++) |
| { |
| offset = (next_index - min_index) * element_size; |
| if (!expand_constant_to_buffer (TREE_VALUE (list), |
| buffer + offset, |
| buf_size - offset)) |
| return 0; |
| } |
| } |
| break; |
| } |
| else if (TREE_CODE (type) == RECORD_TYPE) |
| { |
| tree list = CONSTRUCTOR_ELTS (value); |
| for (; list != NULL_TREE; list = TREE_CHAIN (list)) |
| { |
| tree field = TREE_PURPOSE (list); |
| HOST_WIDE_INT offset; |
| |
| if (field == NULL_TREE || TREE_CODE (field) != FIELD_DECL) |
| return 0; |
| |
| if (DECL_BIT_FIELD (field)) |
| return 0; |
| |
| offset = int_byte_position (field); |
| if (!expand_constant_to_buffer (TREE_VALUE (list), |
| buffer + offset, |
| buf_size - offset)) |
| return 0; |
| } |
| break; |
| } |
| else if (TREE_CODE (type) == SET_TYPE) |
| { |
| if (get_set_constructor_bytes (value, buffer, buf_size) |
| != NULL_TREE) |
| return 0; |
| } |
| break; |
| default: |
| return 0; |
| } |
| return 1; |
| } |
| |
| /* Given that BUFFER contains a target-machine representation of |
| a value of type TYPE, return that value as a tree. |
| Returns NULL_TREE on failure. (E.g. the TYPE might be variable size, |
| or perhaps we don't know how to do the conversion.) */ |
| |
| static tree |
| extract_constant_from_buffer (type, buffer, buf_size) |
| tree type; |
| const unsigned char *buffer; |
| int buf_size; |
| { |
| tree value; |
| HOST_WIDE_INT size = int_size_in_bytes (type); |
| HOST_WIDE_INT i; |
| |
| if (size < 0 || size > buf_size) |
| return 0; |
| |
| switch (TREE_CODE (type)) |
| { |
| case INTEGER_TYPE: |
| case CHAR_TYPE: |
| case BOOLEAN_TYPE: |
| case ENUMERAL_TYPE: |
| case POINTER_TYPE: |
| { |
| HOST_WIDE_INT lo = 0, hi = 0; |
| /* Accumulate (into (lo,hi) the bytes (from buffer). */ |
| for (i = size; --i >= 0; ) |
| { |
| unsigned char byte; |
| /* Get next byte (in big-endian order). */ |
| if (BYTES_BIG_ENDIAN) |
| byte = buffer[size - i - 1]; |
| else |
| byte = buffer[i]; |
| lshift_double (lo, hi, BITS_PER_UNIT, TYPE_PRECISION (type), |
| &lo, &hi, 0); |
| add_double (lo, hi, byte, 0, &lo, &hi); |
| } |
| value = build_int_2 (lo, hi); |
| TREE_TYPE (value) = type; |
| return value; |
| } |
| case ARRAY_TYPE: |
| { |
| tree element_type = TREE_TYPE (type); |
| int element_size = int_size_in_bytes (element_type); |
| tree list = NULL_TREE; |
| HOST_WIDE_INT min_index = 0, max_index, cur_index; |
| if (element_size == 1 && CH_CHARS_TYPE_P (type)) |
| { |
| value = build_string (size, buffer); |
| CH_DERIVED_FLAG (value) = 1; |
| TREE_TYPE (value) = type; |
| return value; |
| } |
| if (TYPE_DOMAIN (type) == 0) |
| return 0; |
| value = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); |
| if (value) |
| { |
| if (! host_integerp (value, 0)) |
| return 0; |
| else |
| min_index = tree_low_cst (value, 0); |
| } |
| |
| value = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); |
| if (value == NULL_TREE || ! host_integerp (value, 0)) |
| return 0; |
| else |
| max_index = tree_low_cst (value, 0); |
| |
| for (cur_index = max_index; cur_index >= min_index; cur_index--) |
| { |
| HOST_WIDE_INT offset = (cur_index - min_index) * element_size; |
| value = extract_constant_from_buffer (element_type, |
| buffer + offset, |
| buf_size - offset); |
| if (value == NULL_TREE) |
| return NULL_TREE; |
| list = tree_cons (build_int_2 (cur_index, 0), value, list); |
| } |
| value = build (CONSTRUCTOR, type, NULL_TREE, list); |
| TREE_CONSTANT (value) = 1; |
| TREE_STATIC (value) = 1; |
| return value; |
| } |
| case RECORD_TYPE: |
| { |
| tree list = NULL_TREE; |
| tree field = TYPE_FIELDS (type); |
| for (; field != NULL_TREE; field = TREE_CHAIN (field)) |
| { |
| HOST_WIDE_INT offset = int_byte_position (field); |
| |
| if (DECL_BIT_FIELD (field)) |
| return 0; |
| value = extract_constant_from_buffer (TREE_TYPE (field), |
| buffer + offset, |
| buf_size - offset); |
| if (value == NULL_TREE) |
| return NULL_TREE; |
| list = tree_cons (field, value, list); |
| } |
| value = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list)); |
| TREE_CONSTANT (value) = 1; |
| TREE_STATIC (value) = 1; |
| return value; |
| } |
| |
| case UNION_TYPE: |
| { |
| tree longest_variant = NULL_TREE; |
| unsigned HOST_WIDE_INT longest_size = 0; |
| tree field = TYPE_FIELDS (type); |
| |
| /* This is a kludge. We assume that converting the data to te |
| longest variant will provide valid data for the "correct" |
| variant. This is usually the case, but is not guaranteed. |
| For example, the longest variant may include holes. |
| Also incorrect interpreting the given value as the longest |
| variant may confuse the compiler if that should happen |
| to yield invalid values. ??? */ |
| |
| for (; field != NULL_TREE; field = TREE_CHAIN (field)) |
| { |
| unsigned HOST_WIDE_INT size |
| = int_size_in_bytes (TREE_TYPE (field)); |
| |
| if (size > longest_size) |
| { |
| longest_size = size; |
| longest_variant = field; |
| } |
| } |
| |
| if (longest_variant == NULL_TREE) |
| return NULL_TREE; |
| |
| return |
| extract_constant_from_buffer (TREE_TYPE (longest_variant), |
| buffer, buf_size); |
| } |
| |
| case SET_TYPE: |
| { |
| tree list = NULL_TREE; |
| int i; |
| HOST_WIDE_INT min_index, max_index; |
| |
| if (TYPE_DOMAIN (type) == 0) |
| return 0; |
| |
| value = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); |
| if (value == NULL_TREE) |
| min_index = 0; |
| |
| else if (! host_integerp (value, 0)) |
| return 0; |
| else |
| min_index = tree_low_cst (value, 0); |
| |
| value = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); |
| if (value == NULL_TREE) |
| max_index = 0; |
| else if (! host_integerp (value, 0)) |
| return 0; |
| else |
| max_index = tree_low_cst (value, 0); |
| |
| for (i = max_index + 1 - min_index; --i >= 0; ) |
| { |
| unsigned char byte = (unsigned char) buffer[i / BITS_PER_UNIT]; |
| unsigned bit_pos = (unsigned) i % (unsigned) BITS_PER_UNIT; |
| |
| if (BYTES_BIG_ENDIAN |
| ? (byte & (1 << (BITS_PER_UNIT - 1 - bit_pos))) |
| : (byte & (1 << bit_pos))) |
| list = tree_cons (NULL_TREE, |
| build_int_2 (i + min_index, 0), list); |
| } |
| value = build (CONSTRUCTOR, type, NULL_TREE, list); |
| TREE_CONSTANT (value) = 1; |
| TREE_STATIC (value) = 1; |
| return value; |
| } |
| |
| default: |
| return NULL_TREE; |
| } |
| } |
| |
| tree |
| build_chill_cast (type, expr) |
| tree type, expr; |
| { |
| tree expr_type; |
| int expr_type_size; |
| int type_size; |
| int type_is_discrete; |
| int expr_type_is_discrete; |
| |
| if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) |
| return error_mark_node; |
| if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) |
| return error_mark_node; |
| |
| /* if expression was untyped because of its context (an |
| if_expr or case_expr in a tuple, perhaps) just apply |
| the type */ |
| expr_type = TREE_TYPE (expr); |
| if (expr_type == NULL_TREE |
| || TREE_CODE (expr_type) == ERROR_MARK) |
| return convert (type, expr); |
| |
| if (expr_type == type) |
| return expr; |
| |
| expr_type_size = int_size_in_bytes (expr_type); |
| type_size = int_size_in_bytes (type); |
| |
| if (expr_type_size == -1) |
| { |
| error ("conversions from variable_size value"); |
| return error_mark_node; |
| } |
| if (type_size == -1) |
| { |
| error ("conversions to variable_size mode"); |
| return error_mark_node; |
| } |
| |
| /* FIXME: process REAL ==> INT && INT ==> REAL && REAL ==> REAL. I hope this is correct. */ |
| if ((TREE_CODE (expr_type) == INTEGER_TYPE && TREE_CODE (type) == REAL_TYPE) || |
| (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == INTEGER_TYPE) || |
| (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == REAL_TYPE)) |
| return convert (type, expr); |
| |
| /* FIXME: Don't know if this is correct */ |
| /* Don't allow conversions to or from REAL with others then integer */ |
| if (TREE_CODE (type) == REAL_TYPE) |
| { |
| error ("cannot convert to float"); |
| return error_mark_node; |
| } |
| else if (TREE_CODE (expr_type) == REAL_TYPE) |
| { |
| error ("cannot convert float to this mode"); |
| return error_mark_node; |
| } |
| |
| if (expr_type_size == type_size && CH_REFERABLE (expr)) |
| goto do_location_conversion; |
| |
| type_is_discrete |
| = discrete_type_p (type) || TREE_CODE (type) == POINTER_TYPE; |
| expr_type_is_discrete |
| = discrete_type_p (expr_type) || TREE_CODE (expr_type) == POINTER_TYPE; |
| if (expr_type_is_discrete && type_is_discrete) |
| { |
| /* do an overflow check |
| FIXME: is this always necessary ??? */ |
| /* FIXME: don't do range chacking when target type is PTR. |
| PTR doesn't have MIN and MAXVALUE. result is sigsegv. */ |
| if (range_checking && type != ptr_type_node) |
| { |
| tree tmp = expr; |
| |
| STRIP_NOPS (tmp); |
| if (TREE_CONSTANT (tmp) && TREE_CODE (tmp) != ADDR_EXPR) |
| { |
| if (compare_int_csts (LT_EXPR, tmp, TYPE_MIN_VALUE (type)) || |
| compare_int_csts (GT_EXPR, tmp, TYPE_MAX_VALUE (type))) |
| { |
| error ("OVERFLOW in expression conversion"); |
| return error_mark_node; |
| } |
| } |
| else |
| { |
| int cond1 = tree_int_cst_lt (TYPE_SIZE (type), |
| TYPE_SIZE (expr_type)); |
| int cond2 = TREE_UNSIGNED (type) && (! TREE_UNSIGNED (expr_type)); |
| int cond3 = (! TREE_UNSIGNED (type)) |
| && TREE_UNSIGNED (expr_type) |
| && tree_int_cst_equal (TYPE_SIZE (type), |
| TYPE_SIZE (expr_type)); |
| int cond4 = TREE_TYPE (type) && type_is_discrete; |
| |
| if (cond1 || cond2 || cond3 || cond4) |
| { |
| tree type_min = TYPE_MIN_VALUE (type); |
| tree type_max = TYPE_MAX_VALUE (type); |
| |
| expr = save_if_needed (expr); |
| if (expr && type_min && type_max) |
| { |
| tree check = test_range (expr, type_min, type_max); |
| if (!integer_zerop (check)) |
| { |
| if (current_function_decl == NULL_TREE) |
| { |
| if (TREE_CODE (check) == INTEGER_CST) |
| error ("overflow (not inside function)"); |
| else |
| warning ("possible overflow (not inside function)"); |
| } |
| else |
| { |
| if (TREE_CODE (check) == INTEGER_CST) |
| warning ("expression will always cause OVERFLOW"); |
| expr = check_expression (expr, check, |
| ridpointers[(int) RID_OVERFLOW]); |
| } |
| } |
| } |
| } |
| } |
| } |
| return convert (type, expr); |
| } |
| |
| if (TREE_CODE (expr) == INTEGER_CST && expr_type_size != type_size) |
| { |
| /* There should probably be a pedwarn here ... */ |
| tree itype = type_for_size (type_size * BITS_PER_UNIT, 1); |
| if (itype) |
| { |
| expr = convert (itype, expr); |
| expr_type = TREE_TYPE (expr); |
| expr_type_size= type_size; |
| } |
| } |
| |
| /* If expr is a constant of the right size, use it to to |
| initialize a static variable. */ |
| if (expr_type_size == type_size && TREE_CONSTANT (expr) && !pedantic) |
| { |
| unsigned char *buffer = (unsigned char*) alloca (type_size); |
| tree value; |
| memset (buffer, 0, type_size); |
| if (!expand_constant_to_buffer (expr, buffer, type_size)) |
| { |
| error ("not implemented: constant conversion from that kind of expression"); |
| return error_mark_node; |
| } |
| value = extract_constant_from_buffer (type, buffer, type_size); |
| if (value == NULL_TREE) |
| { |
| error ("not implemented: constant conversion to that kind of mode"); |
| return error_mark_node; |
| } |
| return value; |
| } |
| |
| if (!CH_REFERABLE (expr) && expr_type_size == type_size) |
| { |
| tree temp = decl_temp1 (get_unique_identifier ("CAST"), |
| TREE_TYPE (expr), 0, 0, 0, 0); |
| tree convert1 = build_chill_modify_expr (temp, expr); |
| pedwarn ("non-standard, non-portable value conversion"); |
| return build (COMPOUND_EXPR, type, convert1, |
| build_chill_cast (type, temp)); |
| } |
| |
| if (CH_REFERABLE (expr) && expr_type_size != type_size) |
| error ("location conversion between differently-sized modes"); |
| else |
| error ("unsupported value conversion"); |
| return error_mark_node; |
| |
| do_location_conversion: |
| /* To avoid confusing other parts of gcc, |
| represent this as the C expression: *(TYPE*)EXPR. */ |
| mark_addressable (expr); |
| expr = build1 (INDIRECT_REF, type, |
| build1 (NOP_EXPR, build_pointer_type (type), |
| build1 (ADDR_EXPR, build_pointer_type (expr_type), |
| expr))); |
| TREE_READONLY (expr) = TYPE_READONLY (type); |
| return expr; |
| } |
| |
| /* Given a set_type, build an integer array from it that C will grok. */ |
| |
| tree |
| build_array_from_set (type) |
| tree type; |
| { |
| tree bytespint, bit_array_size, int_array_count; |
| |
| if (type == NULL_TREE || type == error_mark_node |
| || TREE_CODE (type) != SET_TYPE) |
| return error_mark_node; |
| |
| /* ??? Should this really be *HOST*?? */ |
| bytespint = size_int (HOST_BITS_PER_INT / HOST_BITS_PER_CHAR); |
| bit_array_size = size_in_bytes (type); |
| int_array_count = size_binop (TRUNC_DIV_EXPR, bit_array_size, bytespint); |
| if (integer_zerop (int_array_count)) |
| int_array_count = size_one_node; |
| type = build_array_type (integer_type_node, |
| build_index_type (int_array_count)); |
| return type; |
| } |
| |
| |
| tree |
| build_chill_bin_type (size) |
| tree size; |
| { |
| #if 0 |
| HOST_WIDE_INT isize; |
| |
| if (! host_integerp (size, 1)) |
| { |
| error ("operand to bin must be a non-negative integer literal"); |
| return error_mark_node; |
| } |
| |
| isize = tree_low_cst (size, 1); |
| |
| if (isize <= TYPE_PRECISION (unsigned_char_type_node)) |
| return unsigned_char_type_node; |
| if (isize <= TYPE_PRECISION (short_unsigned_type_node)) |
| return short_unsigned_type_node; |
| if (isize <= TYPE_PRECISION (unsigned_type_node)) |
| return unsigned_type_node; |
| if (isize <= TYPE_PRECISION (long_unsigned_type_node)) |
| return long_unsigned_type_node; |
| if (isize <= TYPE_PRECISION (long_long_unsigned_type_node)) |
| return long_long_unsigned_type_node; |
| error ("size %d of BIN too big - no such integer mode", isize); |
| return error_mark_node; |
| #endif |
| tree bintype; |
| |
| if (pass == 1) |
| { |
| bintype = make_node (INTEGER_TYPE); |
| TREE_TYPE (bintype) = ridpointers[(int) RID_BIN]; |
| TYPE_MIN_VALUE (bintype) = size; |
| TYPE_MAX_VALUE (bintype) = size; |
| } |
| else |
| { |
| error ("BIN in pass 2"); |
| return error_mark_node; |
| } |
| return bintype; |
| } |
| |
| tree |
| chill_expand_tuple (type, constructor) |
| tree type, constructor; |
| { |
| const char *name; |
| tree nonreft = type; |
| |
| if (TYPE_NAME (type) != NULL_TREE) |
| { |
| if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE) |
| name = IDENTIFIER_POINTER (TYPE_NAME (type)); |
| else |
| name = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type))); |
| } |
| else |
| name = ""; |
| |
| /* get to actual underlying type for digest_init */ |
| while (nonreft && TREE_CODE (nonreft) == REFERENCE_TYPE) |
| nonreft = TREE_TYPE (nonreft); |
| |
| if (TREE_CODE (nonreft) == ARRAY_TYPE |
| || TREE_CODE (nonreft) == RECORD_TYPE |
| || TREE_CODE (nonreft) == SET_TYPE) |
| return convert (nonreft, constructor); |
| else |
| { |
| error ("mode of tuple is neither ARRAY, STRUCT, nor POWERSET"); |
| return error_mark_node; |
| } |
| } |
| |
| /* This function classifies an expr into the Null class, |
| the All class, the M-Value, the M-derived, or the M-reference class. |
| It probably has some inaccuracies. */ |
| |
| struct ch_class |
| chill_expr_class (expr) |
| tree expr; |
| { |
| struct ch_class class; |
| /* The Null class contains the NULL pointer constant (only). */ |
| if (expr == null_pointer_node) |
| { |
| class.kind = CH_NULL_CLASS; |
| class.mode = NULL_TREE; |
| return class; |
| } |
| |
| /* The All class contains the <undefined value> "*". */ |
| if (TREE_CODE (expr) == UNDEFINED_EXPR) |
| { |
| class.kind = CH_ALL_CLASS; |
| class.mode = NULL_TREE; |
| return class; |
| } |
| |
| if (CH_DERIVED_FLAG (expr)) |
| { |
| class.kind = CH_DERIVED_CLASS; |
| class.mode = TREE_TYPE (expr); |
| return class; |
| } |
| |
| /* The M-Reference contains <references location> (address-of) expressions. |
| Note that something that's been converted to a reference doesn't count. */ |
| if (TREE_CODE (expr) == ADDR_EXPR |
| && TREE_CODE (TREE_TYPE (expr)) != REFERENCE_TYPE) |
| { |
| class.kind = CH_REFERENCE_CLASS; |
| class.mode = TREE_TYPE (TREE_TYPE (expr)); |
| return class; |
| } |
| |
| /* The M-Value class contains expressions with a known, specific mode M. */ |
| class.kind = CH_VALUE_CLASS; |
| class.mode = TREE_TYPE (expr); |
| return class; |
| } |
| |
| /* Returns >= 1 iff REF is a location. Return 2 if it is referable. */ |
| |
| int chill_location (ref) |
| tree ref; |
| { |
| register enum tree_code code = TREE_CODE (ref); |
| |
| switch (code) |
| { |
| case REALPART_EXPR: |
| case IMAGPART_EXPR: |
| case ARRAY_REF: |
| case PACKED_ARRAY_REF: |
| case COMPONENT_REF: |
| case NOP_EXPR: /* RETYPE_EXPR */ |
| return chill_location (TREE_OPERAND (ref, 0)); |
| case COMPOUND_EXPR: |
| return chill_location (TREE_OPERAND (ref, 1)); |
| |
| case BIT_FIELD_REF: |
| case SLICE_EXPR: |
| /* A bit-string slice is nor referable. */ |
| return chill_location (TREE_OPERAND (ref, 0)) == 0 ? 0 : 1; |
| |
| case CONSTRUCTOR: |
| case STRING_CST: |
| return 0; |
| |
| case INDIRECT_REF: |
| case VAR_DECL: |
| case PARM_DECL: |
| case RESULT_DECL: |
| case ERROR_MARK: |
| if (TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE |
| && TREE_CODE (TREE_TYPE (ref)) != METHOD_TYPE) |
| return 2; |
| break; |
| |
| default: |
| break; |
| } |
| return 0; |
| } |
| |
| int |
| chill_referable (val) |
| tree val; |
| { |
| return chill_location (val) > 1; |
| } |
| |
| /* Make a copy of MODE, but with the given NOVELTY. */ |
| |
| tree |
| copy_novelty (novelty, mode) |
| tree novelty, mode; |
| { |
| if (CH_NOVELTY (mode) != novelty) |
| { |
| mode = copy_node (mode); |
| TYPE_MAIN_VARIANT (mode) = mode; |
| TYPE_NEXT_VARIANT (mode) = 0; |
| TYPE_POINTER_TO (mode) = 0; |
| TYPE_REFERENCE_TO (mode) = 0; |
| SET_CH_NOVELTY (mode, novelty); |
| } |
| return mode; |
| } |
| |
| |
| struct mode_chain |
| { |
| struct mode_chain *prev; |
| tree mode1, mode2; |
| }; |
| |
| /* Tests if MODE1 and MODE2 are SIMILAR. |
| This is more or less as defined in the Blue Book, though |
| see FIXME for parts that are unfinished. |
| CHAIN is used to catch infinite recursion: It is a list of pairs |
| of mode arguments to calls to chill_similar "outer" to this call. */ |
| |
| int |
| chill_similar (mode1, mode2, chain) |
| tree mode1, mode2; |
| struct mode_chain *chain; |
| { |
| int varying1, varying2; |
| tree t1, t2; |
| struct mode_chain *link, node; |
| if (mode1 == NULL_TREE || mode2 == NULL_TREE) |
| return 0; |
| |
| while (TREE_CODE (mode1) == REFERENCE_TYPE) |
| mode1 = TREE_TYPE (mode1); |
| while (TREE_CODE (mode2) == REFERENCE_TYPE) |
| mode2 = TREE_TYPE (mode2); |
| |
| /* Range modes are similar to their parent types. */ |
| while (TREE_CODE (mode1) == INTEGER_TYPE && TREE_TYPE (mode1) != NULL_TREE) |
| mode1 = TREE_TYPE (mode1); |
| while (TREE_CODE (mode2) == INTEGER_TYPE && TREE_TYPE (mode2) != NULL_TREE) |
| mode2 = TREE_TYPE (mode2); |
| |
| |
| /* see Z.200 sections 12.1.2.2 and 13.2 - all integer precisions |
| are similar to INT and to each other */ |
| if (mode1 == mode2 || |
| (TREE_CODE (mode1) == INTEGER_TYPE && TREE_CODE (mode2) == INTEGER_TYPE)) |
| return 1; |
| |
| /* This guards against certain kinds of recursion. |
| For example: |
| SYNMODE a = STRUCT ( next REF a ); |
| SYNMODE b = STRUCT ( next REF b ); |
| These moes are similar, but will get an infite recursion trying |
| to prove that. So, if we are recursing, assume the moes are similar. |
| If they are not, we'll find some other discrepancy. */ |
| for (link = chain; link != NULL; link = link->prev) |
| { |
| if (link->mode1 == mode1 && link->mode2 == mode2) |
| return 1; |
| } |
| |
| node.mode1 = mode1; |
| node.mode2 = mode2; |
| node.prev = chain; |
| |
| varying1 = chill_varying_type_p (mode1); |
| varying2 = chill_varying_type_p (mode2); |
| /* FIXME: This isn't quite strict enough. */ |
| if ((varying1 && varying2) |
| || (varying1 && TREE_CODE (mode2) == ARRAY_TYPE) |
| || (varying2 && TREE_CODE (mode1) == ARRAY_TYPE)) |
| return 1; |
| |
| if (TREE_CODE(mode1) != TREE_CODE(mode2)) |
| { |
| if (flag_old_strings) |
| { |
| /* The recursion is to handle varying strings. */ |
| if ((TREE_CODE (mode1) == CHAR_TYPE |
| && CH_SIMILAR (mode2, string_one_type_node)) |
| || (TREE_CODE (mode2) == CHAR_TYPE |
| && CH_SIMILAR (mode1, string_one_type_node))) |
| return 1; |
| if ((TREE_CODE (mode1) == BOOLEAN_TYPE |
| && CH_SIMILAR (mode2, bitstring_one_type_node)) |
| || (TREE_CODE (mode2) == BOOLEAN_TYPE |
| && CH_SIMILAR (mode1, bitstring_one_type_node))) |
| return 1; |
| } |
| if (TREE_CODE (mode1) == FUNCTION_TYPE |
| && TREE_CODE (mode2) == POINTER_TYPE |
| && TREE_CODE (TREE_TYPE (mode2)) == FUNCTION_TYPE) |
| mode2 = TREE_TYPE (mode2); |
| else if (TREE_CODE (mode2) == FUNCTION_TYPE |
| && TREE_CODE (mode1) == POINTER_TYPE |
| && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE) |
| mode1 = TREE_TYPE (mode1); |
| else |
| return 0; |
| } |
| |
| if (CH_IS_BUFFER_MODE (mode1) && CH_IS_BUFFER_MODE (mode2)) |
| { |
| tree len1 = max_queue_size (mode1); |
| tree len2 = max_queue_size (mode2); |
| return tree_int_cst_equal (len1, len2); |
| } |
| else if (CH_IS_EVENT_MODE (mode1) && CH_IS_EVENT_MODE (mode2)) |
| { |
| tree len1 = max_queue_size (mode1); |
| tree len2 = max_queue_size (mode2); |
| return tree_int_cst_equal (len1, len2); |
| } |
| else if (CH_IS_ACCESS_MODE (mode1) && CH_IS_ACCESS_MODE (mode2)) |
| { |
| tree index1 = access_indexmode (mode1); |
| tree index2 = access_indexmode (mode2); |
| tree record1 = access_recordmode (mode1); |
| tree record2 = access_recordmode (mode2); |
| if (! chill_read_compatible (index1, index2)) |
| return 0; |
| return chill_read_compatible (record1, record2); |
| } |
| switch ((enum chill_tree_code)TREE_CODE (mode1)) |
| { |
| case INTEGER_TYPE: |
| case BOOLEAN_TYPE: |
| case CHAR_TYPE: |
| return 1; |
| case ENUMERAL_TYPE: |
| if (TYPE_VALUES (mode1) == TYPE_VALUES (mode2)) |
| return 1; |
| else |
| { |
| /* FIXME: This is more strict than z.200, which seems to |
| allow the elements to be reordered, as long as they |
| have the same values. */ |
| |
| tree field1 = TYPE_VALUES (mode1); |
| tree field2 = TYPE_VALUES (mode2); |
| |
| while (field1 != NULL_TREE && field2 != NULL_TREE) |
| { |
| tree value1, value2; |
| /* Check that the names are equal. */ |
| if (TREE_PURPOSE (field1) != TREE_PURPOSE (field2)) |
| break; |
| |
| value1 = TREE_VALUE (field1); |
| value2 = TREE_VALUE (field2); |
| /* This isn't quite sufficient in general, but will do ... */ |
| /* Note that proclaim_decl can cause the SET modes to be |
| compared BEFORE they are satisfied, but otherwise |
| chill_similar is mostly called after satisfaction. */ |
| if (TREE_CODE (value1) == CONST_DECL) |
| value1 = DECL_INITIAL (value1); |
| if (TREE_CODE (value2) == CONST_DECL) |
| value2 = DECL_INITIAL (value2); |
| /* Check that the values are equal or both NULL. */ |
| if (!(value1 == NULL_TREE && value2 == NULL_TREE) |
| && (value1 == NULL_TREE || value2 == NULL_TREE |
| || ! tree_int_cst_equal (value1, value2))) |
| break; |
| field1 = TREE_CHAIN (field1); |
| field2 = TREE_CHAIN (field2); |
| } |
| return field1 == NULL_TREE && field2 == NULL_TREE; |
| } |
| case SET_TYPE: |
| /* check for bit strings */ |
| if (CH_BOOLS_TYPE_P (mode1)) |
| return CH_BOOLS_TYPE_P (mode2); |
| if (CH_BOOLS_TYPE_P (mode2)) |
| return CH_BOOLS_TYPE_P (mode1); |
| /* both are powerset modes */ |
| return CH_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2)); |
| |
| case POINTER_TYPE: |
| /* Are the referenced modes equivalent? */ |
| return !integer_zerop (chill_equivalent (TREE_TYPE (mode1), |
| TREE_TYPE (mode2), |
| &node)); |
| |
| case ARRAY_TYPE: |
| /* char for char strings */ |
| if (CH_CHARS_TYPE_P (mode1)) |
| return CH_CHARS_TYPE_P (mode2); |
| if (CH_CHARS_TYPE_P (mode2)) |
| return CH_CHARS_TYPE_P (mode1); |
| /* array modes */ |
| if (CH_V_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2)) |
| /* Are the elements modes equivalent? */ |
| && !integer_zerop (chill_equivalent (TREE_TYPE (mode1), |
| TREE_TYPE (mode2), |
| &node))) |
| { |
| /* FIXME: Check that element layouts are equivalent */ |
| |
| tree count1 = fold (build (MINUS_EXPR, sizetype, |
| TYPE_MAX_VALUE (TYPE_DOMAIN (mode1)), |
| TYPE_MIN_VALUE (TYPE_DOMAIN (mode1)))); |
| tree count2 = fold (build (MINUS_EXPR, sizetype, |
| TYPE_MAX_VALUE (TYPE_DOMAIN (mode2)), |
| TYPE_MIN_VALUE (TYPE_DOMAIN (mode2)))); |
| tree cond = build_compare_discrete_expr (EQ_EXPR, count1, count2); |
| if (TREE_CODE (cond) == INTEGER_CST) |
| return !integer_zerop (cond); |
| else |
| { |
| #if 0 |
| extern int ignoring; |
| if (!ignoring |
| && range_checking |
| && current_function_decl) |
| return cond; |
| #endif |
| return 1; |
| } |
| } |
| return 0; |
| |
| case RECORD_TYPE: |
| case UNION_TYPE: |
| for (t1 = TYPE_FIELDS (mode1), t2 = TYPE_FIELDS (mode2); |
| t1 && t2; t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2)) |
| { |
| if (TREE_CODE (t1) != TREE_CODE (t2)) |
| return 0; |
| /* Are the field modes equivalent? */ |
| if (integer_zerop (chill_equivalent (TREE_TYPE (t1), |
| TREE_TYPE (t2), |
| &node))) |
| return 0; |
| } |
| return t1 == t2; |
| |
| case FUNCTION_TYPE: |
| if (!chill_l_equivalent (TREE_TYPE (mode1), TREE_TYPE (mode2), &node)) |
| return 0; |
| for (t1 = TYPE_ARG_TYPES (mode1), t2 = TYPE_ARG_TYPES (mode2); |
| t1 != NULL_TREE && t2 != NULL_TREE; |
| t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2)) |
| { |
| tree attr1 = TREE_PURPOSE (t1) |
| ? TREE_PURPOSE (t1) : ridpointers[(int) RID_IN]; |
| tree attr2 = TREE_PURPOSE (t2) |
| ? TREE_PURPOSE (t2) : ridpointers[(int) RID_IN]; |
| if (attr1 != attr2) |
| return 0; |
| if (!chill_l_equivalent (TREE_VALUE (t1), TREE_VALUE (t2), &node)) |
| return 0; |
| } |
| if (t1 != t2) /* Both NULL_TREE */ |
| return 0; |
| /* check list of exception names */ |
| t1 = TYPE_RAISES_EXCEPTIONS (mode1); |
| t2 = TYPE_RAISES_EXCEPTIONS (mode2); |
| if (t1 == NULL_TREE && t2 != NULL_TREE) |
| return 0; |
| if (t1 != NULL_TREE && t2 == NULL_TREE) |
| return 0; |
| if (list_length (t1) != list_length (t2)) |
| return 0; |
| while (t1 != NULL_TREE) |
| { |
| if (value_member (TREE_VALUE (t1), t2) == NULL_TREE) |
| return 0; |
| t1 = TREE_CHAIN (t1); |
| } |
| /* FIXME: Should also check they have the same RECURSIVITY */ |
| return 1; |
| |
| default: |
| ; |
| /* Need to handle row modes, instance modes, |
| association modes, access modes, text modes, |
| duration modes, absolute time modes, structure modes, |
| parameterized structure modes */ |
| } |
| return 1; |
| } |
| |
| /* Return a node that is true iff MODE1 and MODE2 are equivalent. |
| This is normally boolean_true_node or boolean_false_node, |
| but can be dynamic for dynamic types. |
| CHAIN is as for chill_similar. */ |
| |
| tree |
| chill_equivalent (mode1, mode2, chain) |
| tree mode1, mode2; |
| struct mode_chain *chain; |
| { |
| int varying1, varying2; |
| int is_string1, is_string2; |
| tree base_mode1, base_mode2; |
| |
| /* Are the modes v-equivalent? */ |
| #if 0 |
| if (!chill_similar (mode1, mode2, chain) |
| || CH_NOVELTY(mode1) != CH_NOVELTY(mode2)) |
| return boolean_false_node; |
| #endif |
| if (!chill_similar (mode1, mode2, chain)) |
| return boolean_false_node; |
| else if (TREE_CODE (mode2) == FUNCTION_TYPE |
| && TREE_CODE (mode1) == POINTER_TYPE |
| && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE) |
| /* don't check novelty in this case to avoid error in case of |
| NEWMODE'd proceduremode gets assigned a function */ |
| return boolean_true_node; |
| else if (CH_NOVELTY(mode1) != CH_NOVELTY(mode2)) |
| return boolean_false_node; |
| |
| varying1 = chill_varying_type_p (mode1); |
| varying2 = chill_varying_type_p (mode2); |
| |
| if (varying1 != varying2) |
| return boolean_false_node; |
| base_mode1 = varying1 ? CH_VARYING_ARRAY_TYPE (mode1) : mode1; |
| base_mode2 = varying2 ? CH_VARYING_ARRAY_TYPE (mode2) : mode2; |
| is_string1 = CH_STRING_TYPE_P (base_mode1); |
| is_string2 = CH_STRING_TYPE_P (base_mode2); |
| if (is_string1 || is_string2) |
| { |
| if (is_string1 != is_string2) |
| return boolean_false_node; |
| return fold (build (EQ_EXPR, boolean_type_node, |
| TYPE_SIZE (base_mode1), |
| TYPE_SIZE (base_mode2))); |
| } |
| |
| /* && some more stuff FIXME! */ |
| if (TREE_CODE(mode1) == INTEGER_TYPE || TREE_CODE(mode2) == INTEGER_TYPE) |
| { |
| if (TREE_CODE(mode1) != INTEGER_TYPE || TREE_CODE(mode2) != INTEGER_TYPE) |
| return boolean_false_node; |
| /* If one is a range, the other has to be a range. */ |
| if ((TREE_TYPE (mode1) != NULL_TREE) != (TREE_TYPE (mode2) != NULL_TREE)) |
| return boolean_false_node; |
| if (TYPE_PRECISION (mode1) != TYPE_PRECISION (mode2)) |
| return boolean_false_node; |
| if (!tree_int_cst_equal (TYPE_MIN_VALUE (mode1), TYPE_MIN_VALUE (mode2))) |
| return boolean_false_node; |
| if (!tree_int_cst_equal (TYPE_MAX_VALUE (mode1), TYPE_MAX_VALUE (mode2))) |
| return boolean_false_node; |
| } |
| return boolean_true_node; |
| } |
| |
| static int |
| chill_l_equivalent (mode1, mode2, chain) |
| tree mode1, mode2; |
| struct mode_chain *chain; |
| { |
| /* Are the modes equivalent? */ |
| if (integer_zerop (chill_equivalent (mode1, mode2, chain))) |
| return 0; |
| if (TYPE_READONLY (mode1) != TYPE_READONLY (mode2)) |
| return 0; |
| /* |
| ... other conditions ...; |
| */ |
| return 1; |
| } |
| |
| /* See Z200 12.1.2.12 */ |
| |
| int |
| chill_read_compatible (modeM, modeN) |
| tree modeM, modeN; |
| { |
| while (TREE_CODE (modeM) == REFERENCE_TYPE) |
| modeM = TREE_TYPE (modeM); |
| while (TREE_CODE (modeN) == REFERENCE_TYPE) |
| modeN = TREE_TYPE (modeN); |
| |
| if (!CH_EQUIVALENT (modeM, modeN)) |
| return 0; |
| if (TYPE_READONLY (modeN)) |
| { |
| if (!TYPE_READONLY (modeM)) |
| return 0; |
| if (CH_IS_BOUND_REFERENCE_MODE (modeM) |
| && CH_IS_BOUND_REFERENCE_MODE (modeN)) |
| { |
| return chill_l_equivalent (TREE_TYPE (modeM), TREE_TYPE (modeN), 0); |
| } |
| /* |
| ...; |
| */ |
| } |
| return 1; |
| } |
| |
| /* Tests if MODE is compatible with the class of EXPR. |
| Cfr. Chill Blue Book 12.1.2.15. */ |
| |
| int |
| chill_compatible (expr, mode) |
| tree expr, mode; |
| { |
| struct ch_class class; |
| |
| if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) |
| return 0; |
| if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK) |
| return 0; |
| |
| while (TREE_CODE (mode) == REFERENCE_TYPE) |
| mode = TREE_TYPE (mode); |
| |
| if (TREE_TYPE (expr) == NULL_TREE) |
| { |
| if (TREE_CODE (expr) == CONSTRUCTOR) |
| return TREE_CODE (mode) == RECORD_TYPE |
| || ((TREE_CODE (mode) == SET_TYPE || TREE_CODE (mode) == ARRAY_TYPE) |
| && ! TYPE_STRING_FLAG (mode)); |
| else |
| return TREE_CODE (expr) == CASE_EXPR || TREE_CODE (expr) == COND_EXPR; |
| } |
| |
| class = chill_expr_class (expr); |
| switch (class.kind) |
| { |
| case CH_ALL_CLASS: |
| return 1; |
| case CH_NULL_CLASS: |
| return CH_IS_REFERENCE_MODE (mode) || CH_IS_PROCEDURE_MODE (mode) |
| || CH_IS_INSTANCE_MODE (mode); |
| case CH_VALUE_CLASS: |
| if (CH_HAS_REFERENCING_PROPERTY (mode)) |
| return CH_RESTRICTABLE_TO(mode, class.mode); |
| else |
| return CH_V_EQUIVALENT(mode, class.mode); |
| case CH_DERIVED_CLASS: |
| return CH_SIMILAR (class.mode, mode); |
| case CH_REFERENCE_CLASS: |
| if (!CH_IS_REFERENCE_MODE (mode)) |
| return 0; |
| /* FIXME! |
| if (class.mode is a row mode) |
| ...; |
| else if (class.mode is not a static mode) |
| return 0; is this possible? |
| */ |
| return !CH_IS_BOUND_REFERENCE_MODE(mode) |
| || CH_READ_COMPATIBLE (TREE_TYPE (mode), class.mode); |
| } |
| return 0; /* ERROR! */ |
| } |
| |
| /* Tests if the class of of EXPR1 and EXPR2 are compatible. |
| Cfr. Chill Blue Book 12.1.2.16. */ |
| |
| int |
| chill_compatible_classes (expr1, expr2) |
| tree expr1, expr2; |
| { |
| struct ch_class temp; |
| struct ch_class class1, class2; |
| class1 = chill_expr_class (expr1); |
| class2 = chill_expr_class (expr2); |
| |
| switch (class1.kind) |
| { |
| case CH_ALL_CLASS: |
| return 1; |
| case CH_NULL_CLASS: |
| switch (class2.kind) |
| { |
| case CH_ALL_CLASS: |
| case CH_NULL_CLASS: |
| case CH_REFERENCE_CLASS: |
| return 1; |
| case CH_VALUE_CLASS: |
| case CH_DERIVED_CLASS: |
| goto rule4; |
| } |
| case CH_REFERENCE_CLASS: |
| switch (class2.kind) |
| { |
| case CH_ALL_CLASS: |
| case CH_NULL_CLASS: |
| return 1; |
| case CH_REFERENCE_CLASS: |
| return CH_EQUIVALENT (class1.mode, class2.mode); |
| case CH_VALUE_CLASS: |
| goto rule6; |
| case CH_DERIVED_CLASS: |
| return 0; |
| } |
| case CH_DERIVED_CLASS: |
| switch (class2.kind) |
| { |
| case CH_ALL_CLASS: |
| return 1; |
| case CH_VALUE_CLASS: |
| case CH_DERIVED_CLASS: |
| return CH_SIMILAR (class1.mode, class2.mode); |
| case CH_NULL_CLASS: |
| class2 = class1; |
| goto rule4; |
| case CH_REFERENCE_CLASS: |
| return 0; |
| } |
| case CH_VALUE_CLASS: |
| switch (class2.kind) |
| { |
| case CH_ALL_CLASS: |
| return 1; |
| case CH_DERIVED_CLASS: |
| return CH_SIMILAR (class1.mode, class2.mode); |
| case CH_VALUE_CLASS: |
| return CH_V_EQUIVALENT (class1.mode, class2.mode); |
| case CH_NULL_CLASS: |
| class2 = class1; |
| goto rule4; |
| case CH_REFERENCE_CLASS: |
| temp = class1; class1 = class2; class2 = temp; |
| goto rule6; |
| } |
| } |
| rule4: |
| /* The Null class is Compatible with the M-derived class or M-value class |
| if and only if M is a reference mdoe, procedure mode or instance mode.*/ |
| return CH_IS_REFERENCE_MODE (class2.mode) |
| || CH_IS_PROCEDURE_MODE (class2.mode) |
| || CH_IS_INSTANCE_MODE (class2.mode); |
| |
| rule6: |
| /* The M-reference class is compatible with the N-value class if and |
| only if N is a reference mode and ... */ |
| if (!CH_IS_REFERENCE_MODE (class2.mode)) |
| return 0; |
| if (1) /* If M is a static mode - FIXME */ |
| { |
| if (!CH_IS_BOUND_REFERENCE_MODE (class2.mode)) |
| return 1; |
| if (CH_EQUIVALENT (TREE_TYPE (class2.mode), class1.mode)) |
| return 1; |
| } |
| /* If N is a row mode whose .... FIXME */ |
| return 0; |
| } |
| |
| /* Cfr. Blue Book 12.1.1.6, with some "extensions." */ |
| |
| tree |
| chill_root_mode (mode) |
| tree mode; |
| { |
| /* Reference types are not user-visible types. |
| This seems like a good place to get rid of them. */ |
| if (TREE_CODE (mode) == REFERENCE_TYPE) |
| mode = TREE_TYPE (mode); |
| |
| while (TREE_CODE (mode) == INTEGER_TYPE && TREE_TYPE (mode) != NULL_TREE) |
| mode = TREE_TYPE (mode); /* a sub-range */ |
| |
| /* This extension in not in the Blue Book - which only has a |
| single Integer type. |
| We should probably use chill_integer_type_node rather |
| than integer_type_node, but that is likely to bomb. |
| At some point, these will become the same, I hope. FIXME */ |
| if (TREE_CODE (mode) == INTEGER_TYPE |
| && TYPE_PRECISION (mode) < TYPE_PRECISION (integer_type_node) |
| && CH_NOVELTY (mode) == NULL_TREE) |
| mode = integer_type_node; |
| |
| if (TREE_CODE (mode) == FUNCTION_TYPE) |
| return build_pointer_type (mode); |
| |
| return mode; |
| } |
| |
| /* Cfr. Blue Book 12.1.1.7. */ |
| |
| tree |
| chill_resulting_mode (mode1, mode2) |
| tree mode1, mode2; |
| { |
| mode1 = CH_ROOT_MODE (mode1); |
| mode2 = CH_ROOT_MODE (mode2); |
| if (chill_varying_type_p (mode1)) |
| return mode1; |
| if (chill_varying_type_p (mode2)) |
| return mode2; |
| return mode1; |
| } |
| |
| /* Cfr. Blue Book (z200, 1988) 12.1.1.7 Resulting class. */ |
| |
| struct ch_class |
| chill_resulting_class (class1, class2) |
| struct ch_class class1, class2; |
| { |
| struct ch_class class; |
| switch (class1.kind) |
| { |
| case CH_VALUE_CLASS: |
| switch (class2.kind) |
| { |
| case CH_DERIVED_CLASS: |
| case CH_ALL_CLASS: |
| class.kind = CH_VALUE_CLASS; |
| class.mode = CH_ROOT_MODE (class1.mode); |
| return class; |
| case CH_VALUE_CLASS: |
| class.kind = CH_VALUE_CLASS; |
| class.mode |
| = CH_ROOT_MODE (CH_RESULTING_MODE (class1.mode, class2.mode)); |
| return class; |
| default: |
| break; |
| } |
| break; |
| case CH_DERIVED_CLASS: |
| switch (class2.kind) |
| { |
| case CH_VALUE_CLASS: |
| class.kind = CH_VALUE_CLASS; |
| class.mode = CH_ROOT_MODE (class2.mode); |
| return class; |
| case CH_DERIVED_CLASS: |
| class.kind = CH_DERIVED_CLASS; |
| class.mode = CH_RESULTING_MODE (class1.mode, class2.mode); |
| return class; |
| case CH_ALL_CLASS: |
| class.kind = CH_DERIVED_CLASS; |
| class.mode = CH_ROOT_MODE (class1.mode); |
| return class; |
| default: |
| break; |
| } |
| break; |
| case CH_ALL_CLASS: |
| switch (class2.kind) |
| { |
| case CH_VALUE_CLASS: |
| class.kind = CH_VALUE_CLASS; |
| class.mode = CH_ROOT_MODE (class2.mode); |
| return class; |
| case CH_ALL_CLASS: |
| class.kind = CH_ALL_CLASS; |
| class.mode = NULL_TREE; |
| return class; |
| case CH_DERIVED_CLASS: |
| class.kind = CH_DERIVED_CLASS; |
| class.mode = CH_ROOT_MODE (class2.mode); |
| return class; |
| default: |
| break; |
| } |
| break; |
| default: |
| break; |
| } |
| error ("internal error in chill_root_resulting_mode"); |
| class.kind = CH_VALUE_CLASS; |
| class.mode = CH_ROOT_MODE (class1.mode); |
| return class; |
| } |
| |
| |
| /* |
| * See Z.200, section 6.3, static conditions. This function |
| * returns bool_false_node if the condition is not met at compile time, |
| * bool_true_node if the condition is detectably met at compile time |
| * an expression if a runtime check would be required or was generated. |
| * It should only be called with string modes and values. |
| */ |
| tree |
| string_assignment_condition (lhs_mode, rhs_value) |
| tree lhs_mode, rhs_value; |
| { |
| tree lhs_size, rhs_size, cond; |
| tree rhs_mode = TREE_TYPE (rhs_value); |
| int lhs_varying = chill_varying_type_p (lhs_mode); |
| |
| if (lhs_varying) |
| lhs_size = size_in_bytes (CH_VARYING_ARRAY_TYPE (lhs_mode)); |
| else if (CH_BOOLS_TYPE_P (lhs_mode)) |
| lhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (lhs_mode)); |
| else |
| lhs_size = size_in_bytes (lhs_mode); |
| lhs_size = convert (chill_unsigned_type_node, lhs_size); |
| |
| if (rhs_mode && TREE_CODE (rhs_mode) == REFERENCE_TYPE) |
| rhs_mode = TREE_TYPE (rhs_mode); |
| if (rhs_mode == NULL_TREE) |
| { |
| /* actually, count constructor's length */ |
| abort (); |
| } |
| else if (chill_varying_type_p (rhs_mode)) |
| rhs_size = build_component_ref (rhs_value, var_length_id); |
| else if (CH_BOOLS_TYPE_P (rhs_mode)) |
| rhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (rhs_mode)); |
| else |
| rhs_size = size_in_bytes (rhs_mode); |
| rhs_size = convert (chill_unsigned_type_node, rhs_size); |
| |
| /* validity condition */ |
| cond = fold (build (lhs_varying ? GE_EXPR : EQ_EXPR, |
| boolean_type_node, lhs_size, rhs_size)); |
| return cond; |
| } |
| |
| /* |
| * take a basic CHILL type and wrap it in a VARYING structure. |
| * Be sure the length field is initialized. Return the wrapper. |
| */ |
| tree |
| build_varying_struct (type) |
| tree type; |
| { |
| tree decl1, decl2, result; |
| |
| if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) |
| return error_mark_node; |
| |
| decl1 = build_decl (FIELD_DECL, var_length_id, chill_integer_type_node); |
| decl2 = build_decl (FIELD_DECL, var_data_id, type); |
| TREE_CHAIN (decl1) = decl2; |
| TREE_CHAIN (decl2) = NULL_TREE; |
| result = build_chill_struct_type (decl1); |
| |
| /* mark this so we don't complain about missing initializers. |
| It's fine for a VARYING array to be partially initialized.. */ |
| C_TYPE_VARIABLE_SIZE(type) = 1; |
| return result; |
| } |
| |
| |
| /* |
| * This is the struct type that forms the runtime initializer |
| * list. There's at least one of these generated per module. |
| * It's attached to the global initializer list by the module's |
| * 'constructor' code. Should only be called in pass 2. |
| */ |
| tree |
| build_init_struct () |
| { |
| tree decl1, decl2, result; |
| /* We temporarily reset the maximum_field_alignment to zero so the |
| compiler's init data structures can be compatible with the |
| run-time system, even when we're compiling with -fpack. */ |
| unsigned int save_maximum_field_alignment = maximum_field_alignment; |
| maximum_field_alignment = 0; |
| |
| decl1 = build_decl (FIELD_DECL, get_identifier ("__INIT_ENTRY"), |
| build_chill_pointer_type ( |
| build_function_type (void_type_node, NULL_TREE))); |
| |
| decl2 = build_decl (FIELD_DECL, get_identifier ("__INIT_NEXT"), |
| build_chill_pointer_type (void_type_node)); |
| |
| TREE_CHAIN (decl1) = decl2; |
| TREE_CHAIN (decl2) = NULL_TREE; |
| result = build_chill_struct_type (decl1); |
| maximum_field_alignment = save_maximum_field_alignment; |
| return result; |
| } |
| |
| |
| /* |
| * Return 1 if the given type is a single-bit boolean set, |
| * in which the domain's min and max values |
| * are both zero, |
| * 0 if not. This can become a macro later.. |
| */ |
| int |
| ch_singleton_set (type) |
| tree type; |
| { |
| if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) |
| return 0; |
| if (TREE_CODE (type) != SET_TYPE) |
| return 0; |
| if (TREE_TYPE (type) == NULL_TREE |
| || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE) |
| return 0; |
| if (TYPE_DOMAIN (type) == NULL_TREE) |
| return 0; |
| if (! tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), |
| integer_zero_node)) |
| return 0; |
| if (! tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), |
| integer_zero_node)) |
| return 0; |
| return 1; |
| } |
| |
| /* return non-zero if TYPE is a compiler-generated VARYING |
| array of some base type */ |
| int |
| chill_varying_type_p (type) |
| tree type; |
| { |
| if (type == NULL_TREE) |
| return 0; |
| if (TREE_CODE (type) != RECORD_TYPE) |
| return 0; |
| if (TYPE_FIELDS (type) == NULL_TREE |
| || TREE_CHAIN (TYPE_FIELDS (type)) == NULL_TREE) |
| return 0; |
| if (DECL_NAME (TYPE_FIELDS (type)) != var_length_id) |
| return 0; |
| if (DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) != var_data_id) |
| return 0; |
| if (TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))) != NULL_TREE) |
| return 0; |
| return 1; |
| } |
| |
| /* return non-zero if TYPE is a compiler-generated VARYING |
| string record */ |
| int |
| chill_varying_string_type_p (type) |
| tree type; |
| { |
| tree var_data_type; |
| |
| if (!chill_varying_type_p (type)) |
| return 0; |
| |
| var_data_type = CH_VARYING_ARRAY_TYPE (type); |
| return CH_CHARS_TYPE_P (var_data_type); |
| } |
| |
| /* swiped from c-typeck.c */ |
| /* Build an assignment expression of lvalue LHS from value RHS. */ |
| |
| tree |
| build_chill_modify_expr (lhs, rhs) |
| tree lhs, rhs; |
| { |
| register tree result; |
| |
| |
| tree lhstype = TREE_TYPE (lhs); |
| |
| /* Avoid duplicate error messages from operands that had errors. */ |
| if (lhs == NULL_TREE || TREE_CODE (lhs) == ERROR_MARK || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK) |
| return error_mark_node; |
| |
| /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */ |
| /* Do not use STRIP_NOPS here. We do not want an enumerator |
| whose value is 0 to count as a null pointer constant. */ |
| if (TREE_CODE (rhs) == NON_LVALUE_EXPR) |
| rhs = TREE_OPERAND (rhs, 0); |
| |
| #if 0 |
| /* Handle a cast used as an "lvalue". |
| We have already performed any binary operator using the value as cast. |
| Now convert the result to the cast type of the lhs, |
| and then true type of the lhs and store it there; |
| then convert result back to the cast type to be the value |
| of the assignment. */ |
| |
| switch (TREE_CODE (lhs)) |
| { |
| case NOP_EXPR: |
| case CONVERT_EXPR: |
| case FLOAT_EXPR: |
| case FIX_TRUNC_EXPR: |
| case FIX_FLOOR_EXPR: |
| case FIX_ROUND_EXPR: |
| case FIX_CEIL_EXPR: |
| { |
| tree inner_lhs = TREE_OPERAND (lhs, 0); |
| tree result; |
| result = build_chill_modify_expr (inner_lhs, |
| convert (TREE_TYPE (inner_lhs), |
| convert (lhstype, rhs))); |
| pedantic_lvalue_warning (CONVERT_EXPR); |
| return convert (TREE_TYPE (lhs), result); |
| } |
| } |
| |
| /* Now we have handled acceptable kinds of LHS that are not truly lvalues. |
| Reject anything strange now. */ |
| |
| if (!lvalue_or_else (lhs, "assignment")) |
| return error_mark_node; |
| #endif |
| /* FIXME: need to generate a RANGEFAIL if the RHS won't |
| fit into the LHS. */ |
| |
| if (TREE_CODE (lhs) != VAR_DECL |
| && ((TREE_CODE (TREE_TYPE (lhs)) == ARRAY_TYPE && |
| (TREE_TYPE (rhs) && TREE_CODE (TREE_TYPE (rhs)) == ARRAY_TYPE)) || |
| chill_varying_type_p (TREE_TYPE (lhs)) || |
| chill_varying_type_p (TREE_TYPE (rhs)))) |
| { |
| int lhs_varying = chill_varying_type_p (TREE_TYPE (lhs)); |
| int rhs_varying = chill_varying_type_p (TREE_TYPE (rhs)); |
| |
| /* point at actual RHS data's type */ |
| tree rhs_data_type = rhs_varying ? |
| CH_VARYING_ARRAY_TYPE (TREE_TYPE (rhs)) : |
| TREE_TYPE (rhs); |
| { |
| /* point at actual LHS data's type */ |
| tree lhs_data_type = lhs_varying ? |
| CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)) : |
| TREE_TYPE (lhs); |
| |
| int lhs_bytes = int_size_in_bytes (lhs_data_type); |
| int rhs_bytes = int_size_in_bytes (rhs_data_type); |
| |
| /* if both sides not varying, and sizes not dynamically |
| computed, sizes must *match* */ |
| if (! lhs_varying && ! rhs_varying && lhs_bytes != rhs_bytes |
| && lhs_bytes > 0 && rhs_bytes > 0) |
| { |
| error ("string lengths not equal"); |
| return error_mark_node; |
| } |
| /* Must have enough space on LHS for static size of RHS */ |
| |
| if (lhs_bytes > 0 && rhs_bytes > 0 |
| && lhs_bytes < rhs_bytes) |
| { |
| if (rhs_varying) |
| { |
| /* FIXME: generate runtime test for room */ |
| ; |
| } |
| else |
| { |
| error ("can't do ARRAY assignment - too large"); |
| return error_mark_node; |
| } |
| } |
| } |
| |
| /* now we know the RHS will fit in LHS, build trees for the |
| emit_block_move parameters */ |
| |
| if (lhs_varying) |
| rhs = convert (TREE_TYPE (lhs), rhs); |
| else |
| { |
| if (rhs_varying) |
| rhs = build_component_ref (rhs, var_data_id); |
| |
| if (! mark_addressable (rhs)) |
| { |
| error ("rhs of array assignment is not addressable"); |
| return error_mark_node; |
| } |
| |
| lhs = force_addr_of (lhs); |
| rhs = build1 (ADDR_EXPR, const_ptr_type_node, rhs); |
| return |
| build_chill_function_call (lookup_name (get_identifier ("memmove")), |
| tree_cons (NULL_TREE, lhs, |
| tree_cons (NULL_TREE, rhs, |
| tree_cons (NULL_TREE, size_in_bytes (rhs_data_type), |
| NULL_TREE)))); |
| } |
| } |
| |
| result = build (MODIFY_EXPR, lhstype, lhs, rhs); |
| TREE_SIDE_EFFECTS (result) = 1; |
| |
| return result; |
| } |
| |
| /* Constructors for pointer, array and function types. |
| (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are |
| constructed by language-dependent code, not here.) */ |
| |
| /* Construct, lay out and return the type of pointers to TO_TYPE. |
| If such a type has already been constructed, reuse it. */ |
| |
| static tree |
| make_chill_pointer_type (to_type, code) |
| tree to_type; |
| enum tree_code code; /* POINTER_TYPE or REFERENCE_TYPE */ |
| { |
| extern struct obstack *current_obstack; |
| extern struct obstack *saveable_obstack; |
| extern struct obstack permanent_obstack; |
| tree t; |
| register struct obstack *ambient_obstack = current_obstack; |
| register struct obstack *ambient_saveable_obstack = saveable_obstack; |
| |
| /* If TO_TYPE is permanent, make this permanent too. */ |
| if (TREE_PERMANENT (to_type)) |
| { |
| current_obstack = &permanent_obstack; |
| saveable_obstack = &permanent_obstack; |
| } |
| |
| t = make_node (code); |
| TREE_TYPE (t) = to_type; |
| |
| current_obstack = ambient_obstack; |
| saveable_obstack = ambient_saveable_obstack; |
| return t; |
| } |
| |
| |
| tree |
| build_chill_pointer_type (to_type) |
| tree to_type; |
| { |
| int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't'; |
| register tree t = is_type_node ? TYPE_POINTER_TO (to_type) : NULL_TREE; |
| |
| /* First, if we already have a type for pointers to TO_TYPE, use it. */ |
| |
| if (t) |
| return t; |
| |
| /* We need a new one. */ |
| t = make_chill_pointer_type (to_type, POINTER_TYPE); |
| |
| /* Lay out the type. This function has many callers that are concerned |
| with expression-construction, and this simplifies them all. |
| Also, it guarantees the TYPE_SIZE is permanent if the type is. */ |
| if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE)) |
| || pass == 2) |
| { |
| /* Record this type as the pointer to TO_TYPE. */ |
| TYPE_POINTER_TO (to_type) = t; |
| layout_type (t); |
| } |
| |
| return t; |
| } |
| |
| tree |
| build_chill_reference_type (to_type) |
| tree to_type; |
| { |
| int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't'; |
| register tree t = is_type_node ? TYPE_REFERENCE_TO (to_type) : NULL_TREE; |
| |
| /* First, if we already have a type for references to TO_TYPE, use it. */ |
| |
| if (t) |
| return t; |
| |
| /* We need a new one. */ |
| t = make_chill_pointer_type (to_type, REFERENCE_TYPE); |
| |
| /* Lay out the type. This function has many callers that are concerned |
| with expression-construction, and this simplifies them all. |
| Also, it guarantees the TYPE_SIZE is permanent if the type is. */ |
| if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE)) |
| || pass == 2) |
| { |
| /* Record this type as the reference to TO_TYPE. */ |
| TYPE_REFERENCE_TO (to_type) = t; |
| layout_type (t); |
| CH_NOVELTY (t) = CH_NOVELTY (to_type); |
| } |
| |
| return t; |
| } |
| |
| static tree |
| make_chill_range_type (type, lowval, highval) |
| tree type, lowval, highval; |
| { |
| register tree itype = make_node (INTEGER_TYPE); |
| TREE_TYPE (itype) = type; |
| TYPE_MIN_VALUE (itype) = lowval; |
| TYPE_MAX_VALUE (itype) = highval; |
| return itype; |
| } |
| |
| |
| /* Return the minimum number of bits needed to represent VALUE in a |
| signed or unsigned type, UNSIGNEDP says which. */ |
| |
| static unsigned int |
| min_precision (value, unsignedp) |
| tree value; |
| int unsignedp; |
| { |
| int log; |
| |
| /* If the value is negative, compute its negative minus 1. The latter |
| adjustment is because the absolute value of the largest negative value |
| is one larger than the largest positive value. This is equivalent to |
| a bit-wise negation, so use that operation instead. */ |
| |
| if (tree_int_cst_sgn (value) < 0) |
| value = fold (build1 (BIT_NOT_EXPR, TREE_TYPE (value), value)); |
| |
| /* Return the number of bits needed, taking into account the fact |
| that we need one more bit for a signed than unsigned type. */ |
| |
| if (integer_zerop (value)) |
| log = 0; |
| else |
| log = tree_floor_log2 (value); |
| |
| return log + 1 + ! unsignedp; |
| } |
| |
| tree |
| layout_chill_range_type (rangetype, must_be_const) |
| tree rangetype; |
| int must_be_const; |
| { |
| tree type = TREE_TYPE (rangetype); |
| tree lowval = TYPE_MIN_VALUE (rangetype); |
| tree highval = TYPE_MAX_VALUE (rangetype); |
| int bad_limits = 0; |
| |
| if (TYPE_SIZE (rangetype) != NULL_TREE) |
| return rangetype; |
| |
| /* process BIN */ |
| if (type == ridpointers[(int) RID_BIN]) |
| { |
| int binsize; |
| |
| /* Make a range out of it */ |
| if (TREE_CODE (highval) != INTEGER_CST) |
| { |
| error ("non-constant expression for BIN"); |
| return error_mark_node; |
| } |
| else if (tree_int_cst_sgn (highval) < 0) |
| { |
| error ("expression for BIN must not be negative"); |
| return error_mark_node; |
| } |
| else if (compare_tree_int (highval, 32) > 0) |
| { |
| error ("cannot process BIN (>32)"); |
| return error_mark_node; |
| } |
| |
| binsize = tree_low_cst (highval, 1); |
| type = ridpointers [(int) RID_RANGE]; |
| lowval = integer_zero_node; |
| highval = build_int_2 ((1 << binsize) - 1, 0); |
| } |
| |
| if (TREE_CODE (lowval) == ERROR_MARK |
| || TREE_CODE (highval) == ERROR_MARK) |
| return error_mark_node; |
| |
| if (!CH_COMPATIBLE_CLASSES (lowval, highval)) |
| { |
| error ("bounds of range are not compatible"); |
| return error_mark_node; |
| } |
| |
| if (type == string_index_type_dummy) |
| { |
| if (TREE_CODE (highval) == INTEGER_CST |
| && compare_int_csts (LT_EXPR, highval, integer_minus_one_node)) |
| { |
| error ("negative string length"); |
| highval = integer_minus_one_node; |
| } |
| if (compare_int_csts (EQ_EXPR, highval, integer_minus_one_node)) |
| type = integer_type_node; |
| else |
| type = sizetype; |
| TREE_TYPE (rangetype) = type; |
| } |
| else if (type == ridpointers[(int) RID_RANGE]) |
| { |
| /* This isn't 100% right, since the Blue Book definition |
| uses Resulting Class, rather than Resulting Mode, |
| but it's close enough. */ |
| type = CH_ROOT_RESULTING_CLASS (lowval, highval).mode; |
| |
| /* The default TYPE is the type of the constants - |
| except if the constants are integers, we choose an |
| integer type that fits. */ |
| if (TREE_CODE (type) == INTEGER_TYPE |
| && TREE_CODE (lowval) == INTEGER_CST |
| && TREE_CODE (highval) == INTEGER_CST) |
| { |
| int unsignedp = tree_int_cst_sgn (lowval) >= 0; |
| unsigned int precision = MAX (min_precision (highval, unsignedp), |
| min_precision (lowval, unsignedp)); |
| |
| type = type_for_size (precision, unsignedp); |
| |
| } |
| |
| TREE_TYPE (rangetype) = type; |
| } |
| else |
| { |
| if (!CH_COMPATIBLE (lowval, type)) |
| { |
| error ("range's lower bound and parent mode don't match"); |
| return integer_type_node; /* an innocuous fake */ |
| } |
| if (!CH_COMPATIBLE (highval, type)) |
| { |
| error ("range's upper bound and parent mode don't match"); |
| return integer_type_node; /* an innocuous fake */ |
| } |
| } |
| |
| if (TREE_CODE (type) == ERROR_MARK) |
| return type; |
| else if (TREE_CODE_CLASS (TREE_CODE (type)) != 't') |
| { |
| error ("making range from non-mode"); |
| return error_mark_node; |
| } |
| |
| if (TREE_CODE (lowval) == REAL_CST || TREE_CODE (highval) == REAL_CST) |
| { |
| sorry ("floating point ranges"); |
| return integer_type_node; /* another fake */ |
| } |
| |
| if (TREE_CODE (lowval) != INTEGER_CST || TREE_CODE (highval) != INTEGER_CST) |
| { |
| if (must_be_const) |
| { |
| error ("range mode has non-constant limits"); |
| bad_limits = 1; |
| } |
| } |
| else if (tree_int_cst_equal (lowval, integer_zero_node) |
| && tree_int_cst_equal (highval, integer_minus_one_node)) |
| ; /* do nothing - this is the index type for an empty string */ |
| else if (compare_int_csts (LT_EXPR, highval, TYPE_MIN_VALUE (type))) |
| { |
| error ("range's high bound < mode's low bound"); |
| bad_limits = 1; |
| } |
| else if (compare_int_csts (GT_EXPR, highval, TYPE_MAX_VALUE (type))) |
| { |
| error ("range's high bound > mode's high bound"); |
| bad_limits = 1; |
| } |
| else if (compare_int_csts (LT_EXPR, highval, lowval)) |
| { |
| error ("range mode high bound < range mode low bound"); |
| bad_limits = 1; |
| } |
| else if (compare_int_csts (LT_EXPR, lowval, TYPE_MIN_VALUE (type))) |
| { |
| error ("range's low bound < mode's low bound"); |
| bad_limits = 1; |
| } |
| else if (compare_int_csts (GT_EXPR, lowval, TYPE_MAX_VALUE (type))) |
| { |
| error ("range's low bound > mode's high bound"); |
| bad_limits = 1; |
| } |
| |
| if (bad_limits) |
| { |
| lowval = TYPE_MIN_VALUE (type); |
| highval = lowval; |
| } |
| |
| highval = convert (type, highval); |
| lowval = convert (type, lowval); |
| TYPE_MIN_VALUE (rangetype) = lowval; |
| TYPE_MAX_VALUE (rangetype) = highval; |
| TYPE_PRECISION (rangetype) = TYPE_PRECISION (type); |
| TYPE_MODE (rangetype) = TYPE_MODE (type); |
| TYPE_SIZE (rangetype) = TYPE_SIZE (type); |
| TYPE_SIZE_UNIT (rangetype) = TYPE_SIZE_UNIT (type); |
| TYPE_ALIGN (rangetype) = TYPE_ALIGN (type); |
| TYPE_USER_ALIGN (rangetype) = TYPE_USER_ALIGN (type); |
| TREE_UNSIGNED (rangetype) = TREE_UNSIGNED (type); |
| CH_NOVELTY (rangetype) = CH_NOVELTY (type); |
| return rangetype; |
| } |
| |
| /* Build a _TYPE node that has range bounds associated with its values. |
| TYPE is the base type for the range type. */ |
| tree |
| build_chill_range_type (type, lowval, highval) |
| tree type, lowval, highval; |
| { |
| tree rangetype; |
| |
| if (type == NULL_TREE) |
| type = ridpointers[(int) RID_RANGE]; |
| else if (TREE_CODE (type) == ERROR_MARK) |
| return error_mark_node; |
| |
| rangetype = make_chill_range_type (type, lowval, highval); |
| if (pass != 1) |
| rangetype = layout_chill_range_type (rangetype, 0); |
| |
| return rangetype; |
| } |
| |
| /* Build a CHILL array type, but with minimal checking etc. */ |
| |
| tree |
| build_simple_array_type (type, idx, layout) |
| tree type, idx, layout; |
| { |
| tree array_type = make_node (ARRAY_TYPE); |
| TREE_TYPE (array_type) = type; |
| TYPE_DOMAIN (array_type) = idx; |
| TYPE_ATTRIBUTES (array_type) = layout; |
| if (pass != 1) |
| array_type = layout_chill_array_type (array_type); |
| return array_type; |
| } |
| |
| static void |
| apply_chill_array_layout (array_type) |
| tree array_type; |
| { |
| tree layout, temp, what, element_type; |
| HOST_WIDE_INT stepsize = 0; |
| HOST_WIDE_INT word, start_bit = 0, length; |
| HOST_WIDE_INT natural_length; |
| int stepsize_specified; |
| int start_bit_error = 0; |
| int length_error = 0; |
| |
| layout = TYPE_ATTRIBUTES (array_type); |
| if (layout == NULL_TREE) |
| return; |
| |
| if (layout == integer_zero_node) /* NOPACK */ |
| { |
| TYPE_PACKED (array_type) = 0; |
| return; |
| } |
| |
| /* Allow for the packing of 1 bit discrete modes at the bit level. */ |
| element_type = TREE_TYPE (array_type); |
| if (discrete_type_p (element_type) |
| && get_type_precision (TYPE_MIN_VALUE (element_type), |
| TYPE_MAX_VALUE (element_type)) == 1) |
| natural_length = 1; |
| else if (host_integerp (TYPE_SIZE (element_type), 1)) |
| natural_length = tree_low_cst (TYPE_SIZE (element_type), 1); |
| else |
| natural_length = -1; |
| |
| if (layout == integer_one_node) /* PACK */ |
| { |
| if (natural_length == 1) |
| TYPE_PACKED (array_type) = 1; |
| return; |
| } |
| |
| /* The layout is a STEP (...). |
| The current implementation restricts STEP specifications to be of the form |
| STEP(POS(0,0,n),n) where n is the natural size of the element mode. */ |
| stepsize_specified = 0; |
| temp = TREE_VALUE (layout); |
| if (TREE_VALUE (temp) != NULL_TREE) |
| { |
| if (! host_integerp (TREE_VALUE (temp), 0)) |
| error ("stepsize in STEP must be an integer constant"); |
| else |
| { |
| if (tree_int_cst_sgn (TREE_VALUE (temp)) <= 0) |
| error ("stepsize in STEP must be > 0"); |
| else |
| stepsize_specified = 1; |
| |
| stepsize = tree_low_cst (TREE_VALUE (temp), 1); |
| if (stepsize != natural_length) |
| sorry ("stepsize in STEP must be the natural width of the array element mode"); |
| } |
| } |
| |
| temp = TREE_PURPOSE (temp); |
| if (! host_integerp (TREE_PURPOSE (temp), 0)) |
| error ("starting word in POS must be an integer constant"); |
| else |
| { |
| if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) |
| error ("starting word in POS must be >= 0"); |
| if (! integer_zerop (TREE_PURPOSE (temp))) |
| sorry ("starting word in POS within STEP must be 0"); |
| |
| word = tree_low_cst (TREE_PURPOSE (temp), 0); |
| } |
| |
| length = natural_length; |
| temp = TREE_VALUE (temp); |
| if (temp != NULL_TREE) |
| { |
| int wordsize = TYPE_PRECISION (chill_integer_type_node); |
| if (! host_integerp (TREE_PURPOSE (temp), 0)) |
| { |
| error ("starting bit in POS must be an integer constant"); |
| start_bit_error = 1; |
| } |
| else |
| { |
| if (! integer_zerop (TREE_PURPOSE (temp))) |
| sorry ("starting bit in POS within STEP must be 0"); |
| |
| if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) |
| { |
| error ("starting bit in POS must be >= 0"); |
| start_bit = 0; |
| start_bit_error = 1; |
| } |
| |
| start_bit = tree_low_cst (TREE_PURPOSE (temp), 0); |
| if (start_bit >= wordsize) |
| { |
| error ("starting bit in POS must be < the width of a word"); |
| start_bit = 0; |
| start_bit_error = 1; |
| } |
| } |
| |
| temp = TREE_VALUE (temp); |
| if (temp != NULL_TREE) |
| { |
| what = TREE_PURPOSE (temp); |
| if (what == integer_zero_node) |
| { |
| if (! host_integerp (TREE_VALUE (temp), 0)) |
| { |
| error ("length in POS must be an integer constant"); |
| length_error = 1; |
| } |
| else |
| { |
| length = tree_low_cst (TREE_VALUE (temp), 0); |
| if (length <= 0) |
| error ("length in POS must be > 0"); |
| } |
| } |
| else |
| { |
| if (! host_integerp (TREE_VALUE (temp), 0)) |
| { |
| error ("end bit in POS must be an integer constant"); |
| length_error = 1; |
| } |
| else |
| { |
| HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0); |
| |
| if (end_bit < start_bit) |
| { |
| error ("end bit in POS must be >= the start bit"); |
| end_bit = wordsize - 1; |
| length_error = 1; |
| } |
| else if (end_bit >= wordsize) |
| { |
| error ("end bit in POS must be < the width of a word"); |
| end_bit = wordsize - 1; |
| length_error = 1; |
| } |
| else if (start_bit_error) |
| length_error = 1; |
| else |
| length = end_bit - start_bit + 1; |
| } |
| } |
| |
| if (! length_error && length != natural_length) |
| sorry ("the length specified on POS within STEP must be the natural length of the array element type"); |
| } |
| } |
| |
| if (! length_error && stepsize_specified && stepsize < length) |
| error ("step size in STEP must be >= the length in POS"); |
| |
| if (length == 1) |
| TYPE_PACKED (array_type) = 1; |
| } |
| |
| tree |
| layout_chill_array_type (array_type) |
| tree array_type; |
| { |
| tree itype; |
| tree element_type = TREE_TYPE (array_type); |
| |
| if (TREE_CODE (element_type) == ARRAY_TYPE |
| && TYPE_SIZE (element_type) == 0) |
| layout_chill_array_type (element_type); |
| |
| itype = TYPE_DOMAIN (array_type); |
| |
| if (TREE_CODE (itype) == ERROR_MARK |
| || TREE_CODE (element_type) == ERROR_MARK) |
| return error_mark_node; |
| |
| /* do a lower/upper bound check. */ |
| if (TREE_CODE (itype) == INTEGER_CST) |
| { |
| error ("array index must be a range, not a single integer"); |
| return error_mark_node; |
| } |
| if (TREE_CODE_CLASS (TREE_CODE (itype)) != 't' |
| || !discrete_type_p (itype)) |
| { |
| error ("array index is not a discrete mode"); |
| return error_mark_node; |
| } |
| |
| /* apply the array layout, if specified. */ |
| apply_chill_array_layout (array_type); |
| TYPE_ATTRIBUTES (array_type) = NULL_TREE; |
| |
| /* Make sure TYPE_POINTER_TO (element_type) is filled in. */ |
| build_pointer_type (element_type); |
| |
| if (TYPE_SIZE (array_type) == 0) |
| layout_type (array_type); |
| |
| if (TYPE_READONLY_PROPERTY (element_type)) |
| TYPE_FIELDS_READONLY (array_type) = 1; |
| |
| TYPE_ARRAY_MAX_SIZE (array_type) = size_in_bytes (array_type); |
| return array_type; |
| } |
| |
| /* Build a CHILL array type. |
| |
| TYPE is the element type of the array. |
| IDXLIST is the list of dimensions of the array. |
| VARYING_P is non-zero if the array is a varying array. |
| LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list), |
| meaning (default, pack, nopack, STEP (...) ). */ |
| tree |
| build_chill_array_type (type, idxlist, varying_p, layouts) |
| tree type, idxlist; |
| int varying_p; |
| tree layouts; |
| { |
| tree array_type = type; |
| |
| if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) |
| return error_mark_node; |
| if (idxlist == NULL_TREE || TREE_CODE (idxlist) == ERROR_MARK) |
| return error_mark_node; |
| |
| /* We have to walk down the list of index decls, building inner |
| array types as we go. We need to reverse the list of layouts so that the |
| first layout applies to the last index etc. */ |
| layouts = nreverse (layouts); |
| for ( ; idxlist; idxlist = TREE_CHAIN (idxlist)) |
| { |
| if (layouts != NULL_TREE) |
| { |
| type = build_simple_array_type ( |
| type, TREE_VALUE (idxlist), TREE_VALUE (layouts)); |
| layouts = TREE_CHAIN (layouts); |
| } |
| else |
| type = build_simple_array_type (type, TREE_VALUE (idxlist), NULL_TREE); |
| } |
| array_type = type; |
| if (varying_p) |
| array_type = build_varying_struct (array_type); |
| return array_type; |
| } |
| |
| /* Function to help qsort sort FIELD_DECLs by name order. */ |
| |
| static int |
| field_decl_cmp (x, y) |
| tree *x, *y; |
| { |
| return (long)DECL_NAME (*x) - (long)DECL_NAME (*y); |
| } |
| |
| static tree |
| make_chill_struct_type (fieldlist) |
| tree fieldlist; |
| { |
| tree t, x; |
| |
| t = make_node (TREE_UNION_ELEM (fieldlist) ? UNION_TYPE : RECORD_TYPE); |
| |
| /* Install struct as DECL_CONTEXT of each field decl. */ |
| for (x = fieldlist; x; x = TREE_CHAIN (x)) |
| DECL_CONTEXT (x) = t; |
| |
| /* Delete all duplicate fields from the fieldlist */ |
| for (x = fieldlist; x && TREE_CHAIN (x);) |
| /* Anonymous fields aren't duplicates. */ |
| if (DECL_NAME (TREE_CHAIN (x)) == 0) |
| x = TREE_CHAIN (x); |
| else |
| { |
| register tree y = fieldlist; |
| |
| while (1) |
| { |
| if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x))) |
| break; |
| if (y == x) |
| break; |
| y = TREE_CHAIN (y); |
| } |
| if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x))) |
| { |
| error_with_decl (TREE_CHAIN (x), "duplicate member `%s'"); |
| TREE_CHAIN (x) = TREE_CHAIN (TREE_CHAIN (x)); |
| } |
| else x = TREE_CHAIN (x); |
| } |
| |
| TYPE_FIELDS (t) = fieldlist; |
| |
| return t; |
| } |
| |
| /* DECL is a FIELD_DECL. |
| DECL_INIT (decl) is |
| (NULL_TREE, integer_one_node, integer_zero_node, tree_list) |
| meaning |
| (default, pack, nopack, POS (...) ). |
| |
| The return value is a boolean: 1 if POS specified, 0 if not */ |
| |
| static int |
| apply_chill_field_layout (decl, next_struct_offset) |
| tree decl; |
| int *next_struct_offset; |
| { |
| tree layout = DECL_INITIAL (decl); |
| tree type = TREE_TYPE (decl); |
| tree temp, what; |
| HOST_WIDE_INT word = 0; |
| HOST_WIDE_INT wordsize, start_bit, offset, length, natural_length; |
| int pos_error = 0; |
| int is_discrete = discrete_type_p (type); |
| |
| if (is_discrete) |
| natural_length |
| = get_type_precision (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type)); |
| else if (host_integerp (TYPE_SIZE (type), 1)) |
| natural_length = tree_low_cst (TYPE_SIZE (type), 1); |
| else |
| natural_length = -1; |
| |
| if (layout == integer_zero_node) /* NOPACK */ |
| { |
| *next_struct_offset += natural_length; |
| return 0; /* not POS */ |
| } |
| |
| if (layout == integer_one_node) /* PACK */ |
| { |
| if (is_discrete) |
| { |
| DECL_BIT_FIELD (decl) = 1; |
| DECL_SIZE (decl) = bitsize_int (natural_length); |
| } |
| else |
| { |
| DECL_ALIGN (decl) = BITS_PER_UNIT; |
| DECL_USER_ALIGN (decl) = 0; |
| } |
| |
| DECL_PACKED (decl) = 1; |
| *next_struct_offset += natural_length; |
| return 0; /* not POS */ |
| } |
| |
| /* The layout is a POS (...). The current implementation restricts the use |
| of POS to monotonically increasing fields whose width must be the |
| natural width of the underlying type. */ |
| temp = TREE_PURPOSE (layout); |
| |
| if (! host_integerp (TREE_PURPOSE (temp), 0)) |
| { |
| error ("starting word in POS must be an integer constant"); |
| pos_error = 1; |
| } |
| else |
| { |
| if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) |
| { |
| error ("starting word in POS must be >= 0"); |
| word = 0; |
| pos_error = 1; |
| } |
| else |
| word = tree_low_cst (TREE_PURPOSE (temp), 0); |
| } |
| |
| wordsize = TYPE_PRECISION (chill_integer_type_node); |
| offset = word * wordsize; |
| length = natural_length; |
| |
| temp = TREE_VALUE (temp); |
| if (temp != NULL_TREE) |
| { |
| if (! host_integerp (TREE_PURPOSE (temp), 0)) |
| { |
| error ("starting bit in POS must be an integer constant"); |
| start_bit = *next_struct_offset - offset; |
| pos_error = 1; |
| } |
| else |
| { |
| if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) |
| { |
| error ("starting bit in POS must be >= 0"); |
| start_bit = *next_struct_offset - offset; |
| pos_error = 1; |
| } |
| |
| start_bit = tree_low_cst (TREE_PURPOSE (temp), 0); |
| if (start_bit >= wordsize) |
| { |
| error ("starting bit in POS must be < the width of a word"); |
| start_bit = *next_struct_offset - offset; |
| pos_error = 1; |
| } |
| } |
| |
| temp = TREE_VALUE (temp); |
| if (temp != NULL_TREE) |
| { |
| what = TREE_PURPOSE (temp); |
| if (what == integer_zero_node) |
| { |
| if (! host_integerp (TREE_VALUE (temp), 0)) |
| { |
| error ("length in POS must be an integer constant"); |
| pos_error = 1; |
| } |
| else |
| { |
| if (tree_int_cst_sgn (TREE_VALUE (temp)) < 0) |
| { |
| error ("length in POS must be > 0"); |
| length = natural_length; |
| pos_error = 1; |
| } |
| else |
| length = tree_low_cst (TREE_VALUE (temp), 0); |
| |
| } |
| } |
| else |
| { |
| if (! host_integerp (TREE_VALUE (temp), 0)) |
| { |
| error ("end bit in POS must be an integer constant"); |
| pos_error = 1; |
| } |
| else |
| { |
| HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0); |
| |
| if (end_bit < start_bit) |
| { |
| error ("end bit in POS must be >= the start bit"); |
| pos_error = 1; |
| } |
| else if (end_bit >= wordsize) |
| { |
| error ("end bit in POS must be < the width of a word"); |
| pos_error = 1; |
| } |
| else |
| length = end_bit - start_bit + 1; |
| } |
| } |
| |
| if (length != natural_length && ! pos_error) |
| { |
| sorry ("the length specified on POS must be the natural length of the field type"); |
| length = natural_length; |
| } |
| } |
| |
| offset += start_bit; |
| } |
| |
| if (offset != *next_struct_offset && ! pos_error) |
| sorry ("STRUCT fields must be layed out in monotonically increasing order"); |
| |
| DECL_PACKED (decl) = 1; |
| DECL_BIT_FIELD (decl) = is_discrete; |
| |
| if (is_discrete) |
| DECL_SIZE (decl) = bitsize_int (length); |
| |
| *next_struct_offset += natural_length; |
| |
| return 1; /* was POS */ |
| } |
| |
| tree |
| layout_chill_struct_type (t) |
| tree t; |
| { |
| tree fieldlist = TYPE_FIELDS (t); |
| tree x; |
| int old_momentary; |
| int was_pos; |
| int pos_seen = 0; |
| int pos_error = 0; |
| int next_struct_offset; |
| |
| old_momentary = suspend_momentary (); |
| |
| /* Process specified field sizes. */ |
| next_struct_offset = 0; |
| for (x = fieldlist; x; x = TREE_CHAIN (x)) |
| { |
| /* An EVENT or BUFFER mode is implemented as a RECORD_TYPE |
| which may contain a CONST_DECL for the maximum queue size. */ |
| if (TREE_CODE (x) == CONST_DECL) |
| continue; |
| |
| /* If any field is const, the structure type is pseudo-const. */ |
| /* A field that is pseudo-const makes the structure likewise. */ |
| if (TREE_READONLY (x) || TYPE_READONLY_PROPERTY (TREE_TYPE (x))) |
| TYPE_FIELDS_READONLY (t) = 1; |
| |
| /* Any field that is volatile means variables of this type must be |
| treated in some ways as volatile. */ |
| if (TREE_THIS_VOLATILE (x)) |
| C_TYPE_FIELDS_VOLATILE (t) = 1; |
| |
| if (DECL_INITIAL (x) != NULL_TREE) |
| { |
| was_pos = apply_chill_field_layout (x, &next_struct_offset); |
| DECL_INITIAL (x) = NULL_TREE; |
| } |
| else |
| { |
| unsigned int min_align = TYPE_ALIGN (TREE_TYPE (x)); |
| DECL_ALIGN (x) = MAX (DECL_ALIGN (x), min_align); |
| was_pos = 0; |
| } |
| if ((! was_pos && pos_seen) || (was_pos && ! pos_seen && x != fieldlist)) |
| pos_error = 1; |
| pos_seen |= was_pos; |
| } |
| |
| if (pos_error) |
| error ("if one field has a POS layout, then all fields must have a POS layout"); |
| |
| /* Now DECL_INITIAL is null on all fields. */ |
| |
| layout_type (t); |
| |
| /* Now we have the truly final field list. |
| Store it in this type and in the variants. */ |
| |
| TYPE_FIELDS (t) = fieldlist; |
| |
| /* If there are lots of fields, sort so we can look through them fast. |
| We arbitrarily consider 16 or more elts to be "a lot". */ |
| { |
| int len = 0; |
| |
| for (x = fieldlist; x; x = TREE_CHAIN (x)) |
| { |
| if (len > 15) |
| break; |
| len += 1; |
| } |
| if (len > 15) |
| { |
| tree *field_array; |
| char *space; |
| |
| len += list_length (x); |
| /* Use the same allocation policy here that make_node uses, to |
| ensure that this lives as long as the rest of the struct decl. |
| All decls in an inline function need to be saved. */ |
| if (allocation_temporary_p ()) |
| space = savealloc (sizeof (struct lang_type) + len * sizeof (tree)); |
| else |
| space = oballoc (sizeof (struct lang_type) + len * sizeof (tree)); |
| |
| TYPE_LANG_SPECIFIC (t) = (struct lang_type *) space; |
| TYPE_LANG_SPECIFIC (t)->foo.rec.len = len; |
| |
| field_array = &TYPE_LANG_SPECIFIC (t)->foo.rec.elts[0]; |
| len = 0; |
| for (x = fieldlist; x; x = TREE_CHAIN (x)) |
| field_array[len++] = x; |
| |
| qsort (field_array, len, sizeof (tree), |
| (int (*) PARAMS ((const void *, const void *))) field_decl_cmp); |
| } |
| } |
| |
| for (x = TYPE_MAIN_VARIANT (t); x; x = TYPE_NEXT_VARIANT (x)) |
| { |
| TYPE_FIELDS (x) = TYPE_FIELDS (t); |
| TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (t); |
| TYPE_ALIGN (x) = TYPE_ALIGN (t); |
| TYPE_USER_ALIGN (x) = TYPE_USER_ALIGN (t); |
| } |
| |
| resume_momentary (old_momentary); |
| |
| return t; |
| } |
| |
| /* Given a list of fields, FIELDLIST, return a structure |
| type that contains these fields. The returned type is |
| always a new type. */ |
| tree |
| build_chill_struct_type (fieldlist) |
| tree fieldlist; |
| { |
| register tree t; |
| |
| if (fieldlist == NULL_TREE || TREE_CODE (fieldlist) == ERROR_MARK) |
| return error_mark_node; |
| |
| t = make_chill_struct_type (fieldlist); |
| if (pass != 1) |
| t = layout_chill_struct_type (t); |
| |
| /* pushtag (NULL_TREE, t); */ |
| |
| return t; |
| } |
| |
| /* Fix a LANG_TYPE. These are used for three different uses: |
| - representing a 'READ M' (in which case TYPE_READONLY is set); |
| - for a NEWMODE or SYNMODE (CH_NOVELTY is set for a NEWMODE); and |
| - for a parameterised type (TREE_TYPE points to base type, |
| while TYPE_DOMAIN is the parameter or parameter list). |
| Called from satisfy. */ |
| tree |
| smash_dummy_type (type) |
| tree type; |
| { |
| /* Save fields that we don't want to copy from ORIGIN. */ |
| tree origin = TREE_TYPE (type); |
| tree main_tree = TYPE_MAIN_VARIANT (origin); |
| int save_uid = TYPE_UID (type); |
| struct obstack *save_obstack = TYPE_OBSTACK (type); |
| tree save_name = TYPE_NAME (type); |
| int save_permanent = TREE_PERMANENT (type); |
| int save_readonly = TYPE_READONLY (type); |
| tree save_novelty = CH_NOVELTY (type); |
| tree save_domain = TYPE_DOMAIN (type); |
| |
| if (origin == NULL_TREE) |
| abort (); |
| |
| if (save_domain) |
| { |
| if (TREE_CODE (save_domain) == ERROR_MARK) |
| return error_mark_node; |
| if (origin == char_type_node) |
| { /* Old-fashioned CHAR(N) declaration. */ |
| origin = build_string_type (origin, save_domain); |
| } |
| else |
| { /* Handle parameterised modes. */ |
| int is_varying = chill_varying_type_p (origin); |
| tree new_max = save_domain; |
| tree origin_novelty = CH_NOVELTY (origin); |
| if (is_varying) |
| origin = CH_VARYING_ARRAY_TYPE (origin); |
| if (CH_STRING_TYPE_P (origin)) |
| { |
| tree oldindex = TYPE_DOMAIN (origin); |
| new_max = check_range (new_max, new_max, NULL_TREE, |
| fold (build (PLUS_EXPR, integer_type_node, |
| TYPE_MAX_VALUE (oldindex), |
| integer_one_node))); |
| origin = build_string_type (TREE_TYPE (origin), new_max); |
| } |
| else if (TREE_CODE (origin) == ARRAY_TYPE) |
| { |
| tree oldindex = TYPE_DOMAIN (origin); |
| tree upper = check_range (new_max, new_max, NULL_TREE, |
| TYPE_MAX_VALUE (oldindex)); |
| tree newindex |
| = build_chill_range_type (TREE_TYPE (oldindex), |
| TYPE_MIN_VALUE (oldindex), upper); |
| origin = build_simple_array_type (TREE_TYPE (origin), newindex, NULL_TREE); |
| } |
| else if (TREE_CODE (origin) == RECORD_TYPE) |
| { |
| error ("parameterized structures not implemented"); |
| return error_mark_node; |
| } |
| else |
| { |
| error ("invalid parameterized type"); |
| return error_mark_node; |
| } |
| |
| SET_CH_NOVELTY (origin, origin_novelty); |
| if (is_varying) |
| { |
| origin = build_varying_struct (origin); |
| SET_CH_NOVELTY (origin, origin_novelty); |
| } |
| } |
| save_domain = NULL_TREE; |
| } |
| |
| if (TREE_CODE (origin) == ERROR_MARK) |
| return error_mark_node; |
| |
| *(struct tree_type*)type = *(struct tree_type*)origin; |
| /* The following is so that the debug code for |
| the copy is different from the original type. |
| The two statements usually duplicate each other |
| (because they clear fields of the same union), |
| but the optimizer should catch that. */ |
| TYPE_SYMTAB_POINTER (type) = 0; |
| TYPE_SYMTAB_ADDRESS (type) = 0; |
| |
| /* Restore fields that we didn't want copied from ORIGIN. */ |
| TYPE_UID (type) = save_uid; |
| TYPE_OBSTACK (type) = save_obstack; |
| TREE_PERMANENT (type) = save_permanent; |
| TYPE_NAME (type) = save_name; |
| |
| TREE_CHAIN (type) = NULL_TREE; |
| TYPE_VOLATILE (type) = 0; |
| TYPE_POINTER_TO (type) = 0; |
| TYPE_REFERENCE_TO (type) = 0; |
| |
| if (save_readonly) |
| { /* TYPE is READ ORIGIN. |
| Add this type to the chain of variants of TYPE. */ |
| TYPE_NEXT_VARIANT (type) = TYPE_NEXT_VARIANT (main_tree); |
| TYPE_NEXT_VARIANT (main_tree) = type; |
| TYPE_READONLY (type) = save_readonly; |
| } |
| else |
| { |
| /* TYPE is the copy of the RHS in a NEWMODE or SYNMODE. |
| We also get here after old-fashioned CHAR(N) declaration (see above). */ |
| TYPE_MAIN_VARIANT (type) = type; |
| TYPE_NEXT_VARIANT (type) = NULL_TREE; |
| if (save_name) |
| DECL_ORIGINAL_TYPE (save_name) = origin; |
| |
| if (save_novelty != NULL_TREE) /* A NEWMODE declaration. */ |
| { |
| CH_NOVELTY (type) = save_novelty; |
| |
| /* Z.200: "If the DEFINING mode of the NEWMODE name is a range mode, |
| then the virtual mode &name is introduced as the PARENT mode |
| of the NEWMODE name. The DEFINING mode of &name is the PARENT |
| mode of the range mode, and the NOVELTY of &name is that of |
| the NEWMODE name." */ |
| |
| if (TREE_CODE (type) == INTEGER_TYPE && TREE_TYPE (type)) |
| { |
| tree parent; |
| /* PARENT is the virtual mode &name mentioned above. */ |
| push_obstacks_nochange (); |
| end_temporary_allocation (); |
| parent = copy_novelty (save_novelty,TREE_TYPE (type)); |
| pop_obstacks (); |
| |
| TREE_TYPE (type) = parent; |
| TYPE_MIN_VALUE (type) = convert (parent, TYPE_MIN_VALUE (type)); |
| TYPE_MAX_VALUE (type) = convert (parent, TYPE_MAX_VALUE (type)); |
| } |
| } |
| } |
| return type; |
| } |
| |
| /* This generates a LANG_TYPE node that represents 'READ TYPE'. */ |
| |
| tree |
| build_readonly_type (type) |
| tree type; |
| { |
| tree node = make_node (LANG_TYPE); |
| TREE_TYPE (node) = type; |
| TYPE_READONLY (node) = 1; |
| if (pass != 1) |
| node = smash_dummy_type (node); |
| return node; |
| } |
| |
| |
| /* Return an unsigned type the same as TYPE in other respects. */ |
| |
| tree |
| unsigned_type (type) |
| tree type; |
| { |
| tree type1 = TYPE_MAIN_VARIANT (type); |
| if (type1 == signed_char_type_node || type1 == char_type_node) |
| return unsigned_char_type_node; |
| if (type1 == integer_type_node) |
| return unsigned_type_node; |
| if (type1 == short_integer_type_node) |
| return short_unsigned_type_node; |
| if (type1 == long_integer_type_node) |
| return long_unsigned_type_node; |
| if (type1 == long_long_integer_type_node) |
| return long_long_unsigned_type_node; |
| |
| return signed_or_unsigned_type (1, type); |
| } |
| |
| /* Return a signed type the same as TYPE in other respects. */ |
| |
| tree |
| signed_type (type) |
| tree type; |
| { |
| tree type1 = TYPE_MAIN_VARIANT (type); |
| while (TREE_CODE (type1) == INTEGER_TYPE && TREE_TYPE (type1) != NULL_TREE) |
| type1 = TREE_TYPE (type1); |
| if (type1 == unsigned_char_type_node || type1 == char_type_node) |
| return signed_char_type_node; |
| if (type1 == unsigned_type_node) |
| return integer_type_node; |
| if (type1 == short_unsigned_type_node) |
| return short_integer_type_node; |
| if (type1 == long_unsigned_type_node) |
| return long_integer_type_node; |
| if (type1 == long_long_unsigned_type_node) |
| return long_long_integer_type_node; |
| if (TYPE_PRECISION (type1) == 1) |
| return signed_boolean_type_node; |
| |
| return signed_or_unsigned_type (0, type); |
| } |
| |
| /* Return a type the same as TYPE except unsigned or |
| signed according to UNSIGNEDP. */ |
| |
| tree |
| signed_or_unsigned_type (unsignedp, type) |
| int unsignedp; |
| tree type; |
| { |
| if (! INTEGRAL_TYPE_P (type) |
| || TREE_UNSIGNED (type) == unsignedp) |
| return type; |
| |
| if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) |
| return unsignedp ? unsigned_char_type_node : signed_char_type_node; |
| if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) |
| return unsignedp ? unsigned_type_node : integer_type_node; |
| if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) |
| return unsignedp ? short_unsigned_type_node : short_integer_type_node; |
| if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) |
| return unsignedp ? long_unsigned_type_node : long_integer_type_node; |
| if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) |
| return (unsignedp ? long_long_unsigned_type_node |
| : long_long_integer_type_node); |
| return type; |
| } |
| |
| /* Mark EXP saying that we need to be able to take the |
| address of it; it should not be allocated in a register. |
| Value is 1 if successful. */ |
| |
| int |
| mark_addressable (exp) |
| tree exp; |
| { |
| register tree x = exp; |
| while (1) |
| switch (TREE_CODE (x)) |
| { |
| case ADDR_EXPR: |
| case COMPONENT_REF: |
| case ARRAY_REF: |
| case REALPART_EXPR: |
| case IMAGPART_EXPR: |
| x = TREE_OPERAND (x, 0); |
| break; |
| |
| case TRUTH_ANDIF_EXPR: |
| case TRUTH_ORIF_EXPR: |
| case COMPOUND_EXPR: |
| x = TREE_OPERAND (x, 1); |
| break; |
| |
| case COND_EXPR: |
| return mark_addressable (TREE_OPERAND (x, 1)) |
| & mark_addressable (TREE_OPERAND (x, 2)); |
| |
| case CONSTRUCTOR: |
| TREE_ADDRESSABLE (x) = 1; |
| return 1; |
| |
| case INDIRECT_REF: |
| /* We sometimes add a cast *(TYPE*)&FOO to handle type and mode |
| incompatibility problems. Handle this case by marking FOO. */ |
| if (TREE_CODE (TREE_OPERAND (x, 0)) == NOP_EXPR |
| && TREE_CODE (TREE_OPERAND (TREE_OPERAND (x, 0), 0)) == ADDR_EXPR) |
| { |
| x = TREE_OPERAND (TREE_OPERAND (x, 0), 0); |
| break; |
| } |
| if (TREE_CODE (TREE_OPERAND (x, 0)) == ADDR_EXPR) |
| { |
| x = TREE_OPERAND (x, 0); |
| break; |
| } |
| return 1; |
| |
| case VAR_DECL: |
| case CONST_DECL: |
| case PARM_DECL: |
| case RESULT_DECL: |
| if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) |
| && DECL_NONLOCAL (x)) |
| { |
| if (TREE_PUBLIC (x)) |
| { |
| error ("global register variable `%s' used in nested function", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| return 0; |
| } |
| pedwarn ("register variable `%s' used in nested function", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| } |
| else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) |
| { |
| if (TREE_PUBLIC (x)) |
| { |
| error ("address of global register variable `%s' requested", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| return 0; |
| } |
| |
| /* If we are making this addressable due to its having |
| volatile components, give a different error message. Also |
| handle the case of an unnamed parameter by not trying |
| to give the name. */ |
| |
| else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x))) |
| { |
| error ("cannot put object with volatile field into register"); |
| return 0; |
| } |
| |
| pedwarn ("address of register variable `%s' requested", |
| IDENTIFIER_POINTER (DECL_NAME (x))); |
| } |
| put_var_into_stack (x); |
| |
| /* drops through */ |
| case FUNCTION_DECL: |
| TREE_ADDRESSABLE (x) = 1; |
| #if 0 /* poplevel deals with this now. */ |
| if (DECL_CONTEXT (x) == 0) |
| TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; |
| #endif |
| /* drops through */ |
| default: |
| return 1; |
| } |
| } |
| |
| /* Return an integer type with BITS bits of precision, |
| that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ |
| |
| tree |
| type_for_size (bits, unsignedp) |
| unsigned bits; |
| int unsignedp; |
| { |
| if (bits == TYPE_PRECISION (integer_type_node)) |
| return unsignedp ? unsigned_type_node : integer_type_node; |
| |
| if (bits == TYPE_PRECISION (signed_char_type_node)) |
| return unsignedp ? unsigned_char_type_node : signed_char_type_node; |
| |
| if (bits == TYPE_PRECISION (short_integer_type_node)) |
| return unsignedp ? short_unsigned_type_node : short_integer_type_node; |
| |
| if (bits == TYPE_PRECISION (long_integer_type_node)) |
| return unsignedp ? long_unsigned_type_node : long_integer_type_node; |
| |
| if (bits == TYPE_PRECISION (long_long_integer_type_node)) |
| return (unsignedp ? long_long_unsigned_type_node |
| : long_long_integer_type_node); |
| |
| if (bits <= TYPE_PRECISION (intQI_type_node)) |
| return unsignedp ? unsigned_intQI_type_node : intQI_type_node; |
| |
| if (bits <= TYPE_PRECISION (intHI_type_node)) |
| return unsignedp ? unsigned_intHI_type_node : intHI_type_node; |
| |
| if (bits <= TYPE_PRECISION (intSI_type_node)) |
| return unsignedp ? unsigned_intSI_type_node : intSI_type_node; |
| |
| if (bits <= TYPE_PRECISION (intDI_type_node)) |
| return unsignedp ? unsigned_intDI_type_node : intDI_type_node; |
| |
| #if HOST_BITS_PER_WIDE_INT >= 64 |
| if (bits <= TYPE_PRECISION (intTI_type_node)) |
| return unsignedp ? unsigned_intTI_type_node : intTI_type_node; |
| #endif |
| |
| return 0; |
| } |
| |
| /* Return a data type that has machine mode MODE. |
| If the mode is an integer, |
| then UNSIGNEDP selects between signed and unsigned types. */ |
| |
| tree |
| type_for_mode (mode, unsignedp) |
| enum machine_mode mode; |
| int unsignedp; |
| { |
| if ((int)mode == (int)TYPE_MODE (integer_type_node)) |
| return unsignedp ? unsigned_type_node : integer_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (signed_char_type_node)) |
| return unsignedp ? unsigned_char_type_node : signed_char_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (short_integer_type_node)) |
| return unsignedp ? short_unsigned_type_node : short_integer_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (long_integer_type_node)) |
| return unsignedp ? long_unsigned_type_node : long_integer_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (long_long_integer_type_node)) |
| return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (intQI_type_node)) |
| return unsignedp ? unsigned_intQI_type_node : intQI_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (intHI_type_node)) |
| return unsignedp ? unsigned_intHI_type_node : intHI_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (intSI_type_node)) |
| return unsignedp ? unsigned_intSI_type_node : intSI_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (intDI_type_node)) |
| return unsignedp ? unsigned_intDI_type_node : intDI_type_node; |
| |
| #if HOST_BITS_PER_WIDE_INT >= 64 |
| if ((int)mode == (int)TYPE_MODE (intTI_type_node)) |
| return unsignedp ? unsigned_intTI_type_node : intTI_type_node; |
| #endif |
| |
| if ((int)mode == (int)TYPE_MODE (float_type_node)) |
| return float_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (double_type_node)) |
| return double_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (long_double_type_node)) |
| return long_double_type_node; |
| |
| if ((int)mode == (int)TYPE_MODE (build_pointer_type (char_type_node))) |
| return build_pointer_type (char_type_node); |
| |
| if ((int)mode == (int)TYPE_MODE (build_pointer_type (integer_type_node))) |
| return build_pointer_type (integer_type_node); |
| |
| return 0; |
| } |