/* Language-level data type conversion for GNU CHILL. Copyright (C) 1992, 93, 1994, 1998 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 contains the functions for converting CHILL expressions to different data types. The only entry point is `convert'. Every language front end must have a `convert' function but what kind of conversions it does will depend on the language. */ #include "config.h" #include "system.h" #include "tree.h" #include "ch-tree.h" #include "flags.h" #include "convert.h" #include "lex.h" #include "toplev.h" extern tree bit_one_node, bit_zero_node; extern tree string_one_type_node; extern tree bitstring_one_type_node; static tree convert_to_reference PROTO ((tree, tree)); static tree convert_to_boolean PROTO ((tree, tree)); static tree convert_to_char PROTO ((tree, tree)); #if 0 static tree base_type_size_in_bytes PROTO ((tree)); #endif static tree remove_tree_element PROTO ((tree, tree *)); static tree check_ps_range PROTO ((tree, tree, tree)); static tree digest_powerset_tuple PROTO ((tree, tree)); static tree digest_structure_tuple PROTO ((tree, tree)); static tree digest_array_tuple PROTO ((tree, tree, int)); static tree convert1 PROTO ((tree, tree)); static tree convert_to_reference (reftype, expr) tree reftype, expr; { while (TREE_CODE (expr) == NOP_EXPR) /* RETYPE_EXPR */ expr = TREE_OPERAND (expr, 0); if (! CH_LOCATION_P (expr)) error("internal error: trying to make loc-identity with non-location"); else { mark_addressable (expr); return fold (build1 (ADDR_EXPR, reftype, expr)); } return error_mark_node; } tree convert_from_reference (expr) tree expr; { tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr); TREE_READONLY (e) = TREE_READONLY (expr); return e; } /* Convert EXPR to a boolean type. */ static tree convert_to_boolean (type, expr) tree type, expr; { register tree intype = TREE_TYPE (expr); if (integer_zerop (expr)) return boolean_false_node; if (integer_onep (expr)) return boolean_true_node; /* Convert a singleton bitstring to a Boolean. Needed if flag_old_strings. */ if (CH_BOOLS_ONE_P (intype)) { if (TREE_CODE (expr) == CONSTRUCTOR) { tree valuelist = TREE_OPERAND (expr, 1); if (valuelist == NULL_TREE) return boolean_false_node; if (TREE_CHAIN (valuelist) == NULL_TREE && TREE_PURPOSE (valuelist) == NULL_TREE && integer_zerop (TREE_VALUE (valuelist))) return boolean_true_node; } return build_chill_bitref (expr, build_tree_list (NULL_TREE, integer_zero_node)); } if (INTEGRAL_TYPE_P (intype)) return build1 (CONVERT_EXPR, type, expr); error ("cannot convert to a boolean mode"); return boolean_false_node; } /* Convert EXPR to a char type. */ static tree convert_to_char (type, expr) tree type, expr; { register tree intype = TREE_TYPE (expr); register enum chill_tree_code form = TREE_CODE (intype); if (form == CHAR_TYPE) return build1 (NOP_EXPR, type, expr); /* Convert a singleton string to a char. Needed if flag_old_strings. */ if (CH_CHARS_ONE_P (intype)) { if (TREE_CODE (expr) == STRING_CST) { expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0); TREE_TYPE (expr) = char_type_node; return expr; } else return build (ARRAY_REF, char_type_node, expr, integer_zero_node); } /* For now, assume it will always fit */ if (form == INTEGER_TYPE) return build1 (CONVERT_EXPR, type, expr); error ("cannot convert to a char mode"); { register tree tem = build_int_2 (0, 0); TREE_TYPE (tem) = type; return tem; } } #if 0 static tree base_type_size_in_bytes (type) tree type; { if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK || TREE_CODE (type) != ARRAY_TYPE) return error_mark_node; return size_in_bytes (TREE_TYPE (type)); } #endif /* * build a singleton array type, of TYPE objects. */ tree build_array_type_for_scalar (type) tree type; { /* KLUDGE */ if (type == char_type_node) return build_string_type (type, integer_one_node); if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) return error_mark_node; return build_chill_array_type (type, tree_cons (NULL_TREE, build_chill_range_type (NULL_TREE, integer_zero_node, integer_zero_node), NULL_TREE), 0, NULL_TREE); } #if 0 static tree unreferenced_type_of (type) tree type; { if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) return error_mark_node; while (TREE_CODE (type) == REFERENCE_TYPE) type = TREE_TYPE (type); return type; } #endif /* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY. Return the TREE_LIST node, or NULL_TREE on failure. */ static tree remove_tree_element (key, listp) tree *listp; tree key; { tree node = *listp; for ( ; node; listp = &TREE_CHAIN (node), node = *listp) { if (TREE_PURPOSE (node) == key) { *listp = TREE_CHAIN (node); TREE_CHAIN (node) = NULL_TREE; return node; } } return NULL_TREE; } /* This is quite the same as check_range in actions.c, but with different error message. */ static tree check_ps_range (value, lo_limit, hi_limit) tree value; tree lo_limit; tree hi_limit; { tree check = test_range (value, lo_limit, hi_limit); if (!integer_zerop (check)) { if (TREE_CODE (check) == INTEGER_CST) { error ("powerset tuple element out of range"); return error_mark_node; } else value = check_expression (value, check, ridpointers[(int) RID_RANGEFAIL]); } return value; } static tree digest_powerset_tuple (type, inits) tree type; tree inits; { tree list; tree result; tree domain = TYPE_DOMAIN (type); int i = 0; int is_erroneous = 0, is_constant = 1, is_simple = 1; if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK) return error_mark_node; for (list = TREE_OPERAND (inits, 1); list; list = TREE_CHAIN (list), i++) { tree val = TREE_VALUE (list); if (TREE_CODE (val) == ERROR_MARK) { is_erroneous = 1; continue; } if (!TREE_CONSTANT (val)) is_constant = 0; else if (!initializer_constant_valid_p (val, TREE_TYPE (val))) is_simple = 0; if (! CH_COMPATIBLE (val, domain)) { error ("incompatible member of powerset tuple (at position #%d)", i); is_erroneous = 1; continue; } /* check range of value */ val = check_ps_range (val, TYPE_MIN_VALUE (domain), TYPE_MAX_VALUE (domain)); if (TREE_CODE (val) == ERROR_MARK) { is_erroneous = 1; continue; } /* Updating the list in place is in principle questionable, but I can't think how it could hurt. */ TREE_VALUE (list) = convert (domain, val); val = TREE_PURPOSE (list); if (val == NULL_TREE) continue; if (TREE_CODE (val) == ERROR_MARK) { is_erroneous = 1; continue; } if (! CH_COMPATIBLE (val, domain)) { error ("incompatible member of powerset tuple (at position #%d)", i); is_erroneous = 1; continue; } val = check_ps_range (val, TYPE_MIN_VALUE (domain), TYPE_MAX_VALUE (domain)); if (TREE_CODE (val) == ERROR_MARK) { is_erroneous = 1; continue; } TREE_PURPOSE (list) = convert (domain, val); if (!TREE_CONSTANT (val)) is_constant = 0; else if (!initializer_constant_valid_p (val, TREE_TYPE (val))) is_simple = 0; } result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1)); if (is_erroneous) return error_mark_node; if (is_constant) TREE_CONSTANT (result) = 1; if (is_constant && is_simple) TREE_STATIC (result) = 1; return result; } static tree digest_structure_tuple (type, inits) tree type; tree inits; { tree elements = CONSTRUCTOR_ELTS (inits); tree values = NULL_TREE; int is_constant = 1; int is_simple = 1; int is_erroneous = 0; tree field; int labelled_elements = 0; int unlabelled_elements = 0; for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field)) { if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE) { /* Regular fixed field. */ tree value = remove_tree_element (DECL_NAME (field), &elements); if (value) labelled_elements++; else if (elements && TREE_PURPOSE (elements) == NULL_TREE) { value = elements; elements = TREE_CHAIN (elements); unlabelled_elements++; } if (value) { tree val; char msg[120]; sprintf (msg, "initializer for field `%.80s'", IDENTIFIER_POINTER (DECL_NAME (field))); val = chill_convert_for_assignment (TREE_TYPE (field), TREE_VALUE (value), msg); if (TREE_CODE (val) == ERROR_MARK) is_erroneous = 1; else { TREE_VALUE (value) = val; TREE_CHAIN (value) = values; TREE_PURPOSE (value) = field; values = value; if (TREE_CODE (val) == ERROR_MARK) is_erroneous = 1; else if (!TREE_CONSTANT (val)) is_constant = 0; else if (!initializer_constant_valid_p (val, TREE_TYPE (val))) is_simple = 0; } } else { pedwarn ("no initializer value for fixed field `%s'", IDENTIFIER_POINTER (DECL_NAME (field))); } } else { tree variant; tree selected_variant = NULL_TREE; tree variant_values = NULL_TREE; /* In a tagged variant structure mode, try to figure out (from the fixed fields), which is the selected variant. */ if (TYPE_TAGFIELDS (TREE_TYPE (field))) { for (variant = TYPE_FIELDS (TREE_TYPE (field)); variant; variant = TREE_CHAIN (variant)) { tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant)); tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field)); if (DECL_NAME (variant) == ELSE_VARIANT_NAME) { selected_variant = variant; break; } for (; tag_labels && tag_fields; tag_labels = TREE_CHAIN (tag_labels), tag_fields = TREE_CHAIN (tag_fields)) { tree tag_value = values; int found = 0; tree tag_decl = TREE_VALUE (tag_fields); tree tag_value_set = TREE_VALUE (tag_labels); for ( ; tag_value; tag_value = TREE_CHAIN (tag_value)) { if (TREE_PURPOSE (tag_value) == tag_decl) { tag_value = TREE_VALUE (tag_value); break; } } if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST) { pedwarn ("non-constant value for tag field `%s'", IDENTIFIER_POINTER (DECL_NAME (tag_decl))); goto get_values; } /* Check if the value of the tag (as given in a previous field) matches the case label list. */ for (; tag_value_set; tag_value_set = TREE_CHAIN (tag_value_set)) { if (tree_int_cst_equal (TREE_VALUE (tag_value_set), tag_value)) { found = 1; break; } } if (!found) break; } if (!tag_fields) { selected_variant = variant; break; } } } get_values: for (variant = TYPE_FIELDS (TREE_TYPE (field)); variant; variant = TREE_CHAIN (variant)) { tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant)); tree vfield; for (vfield = vfield0; vfield; vfield = TREE_CHAIN (vfield)) { tree value = remove_tree_element (DECL_NAME (vfield), &elements); if (value) labelled_elements++; else if (variant == selected_variant && elements && TREE_PURPOSE (elements) == NULL_TREE) { value = elements; elements = TREE_CHAIN (elements); unlabelled_elements++; } if (value) { if (selected_variant && selected_variant != variant) { error ("field `%s' in wrong variant", IDENTIFIER_POINTER (DECL_NAME (vfield))); is_erroneous = 1; } else { if (!selected_variant && vfield != vfield0) pedwarn ("missing variant fields (at least `%s')", IDENTIFIER_POINTER (DECL_NAME (vfield0))); selected_variant = variant; if (CH_COMPATIBLE (TREE_VALUE (value), TREE_TYPE (vfield))) { tree val = convert (TREE_TYPE (vfield), TREE_VALUE (value)); TREE_PURPOSE (value) = vfield; TREE_VALUE (value) = val; TREE_CHAIN (value) = variant_values; variant_values = value; if (TREE_CODE (val) == ERROR_MARK) is_erroneous = 1; else if (!TREE_CONSTANT (val)) is_constant = 0; else if (!initializer_constant_valid_p (val, TREE_TYPE (val))) is_simple = 0; } else { is_erroneous = 1; error ("bad initializer for field `%s'", IDENTIFIER_POINTER (DECL_NAME (vfield))); } } } else if (variant == selected_variant) { pedwarn ("no initializer value for variant field `%s'", IDENTIFIER_POINTER (DECL_NAME (field))); } } } if (selected_variant == NULL_TREE) pedwarn ("no selected variant"); else { variant_values = build (CONSTRUCTOR, TREE_TYPE (selected_variant), NULL_TREE, nreverse (variant_values)); variant_values = build (CONSTRUCTOR, TREE_TYPE (field), NULL_TREE, build_tree_list (selected_variant, variant_values)); values = tree_cons (field, variant_values, values); } } } if (labelled_elements && unlabelled_elements) pedwarn ("mixture of labelled and unlabelled tuple elements"); /* Check for unused initializer elements. */ unlabelled_elements = 0; for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements)) { if (TREE_PURPOSE (elements) == NULL_TREE) unlabelled_elements++; else { if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0) error ("probably not a structure tuple"); else error ("excess initializer for field `%s'", IDENTIFIER_POINTER (TREE_PURPOSE (elements))); is_erroneous = 1; } } if (unlabelled_elements) { error ("excess unnamed initializers"); is_erroneous = 1; } CONSTRUCTOR_ELTS (inits) = nreverse (values); TREE_TYPE (inits) = type; if (is_erroneous) return error_mark_node; if (is_constant) TREE_CONSTANT (inits) = 1; if (is_constant && is_simple) TREE_STATIC (inits) = 1; return inits; } /* Return a Chill representation of the INTEGER_CST VAL. The result may be in a static buffer, */ const char * display_int_cst (val) tree val; { static char buffer[50]; HOST_WIDE_INT x; tree fields; if (TREE_CODE (val) != INTEGER_CST) return ""; x = TREE_INT_CST_LOW (val); switch (TREE_CODE (TREE_TYPE (val))) { case BOOLEAN_TYPE: if (x == 0) return "FALSE"; if (x == 1) return "TRUE"; goto int_case; case CHAR_TYPE: if (x == '^') strcpy (buffer, "'^^'"); else if (x == '\n') strcpy (buffer, "'^J'"); else if (x < ' ' || x > '~') sprintf (buffer, "'^(%u)'", (unsigned int) x); else sprintf (buffer, "'%c'", (char) x); return buffer; case ENUMERAL_TYPE: for (fields = TYPE_VALUES (TREE_TYPE (val)); fields != NULL_TREE; fields = TREE_CHAIN (fields)) { if (tree_int_cst_equal (TREE_VALUE (fields), val)) return IDENTIFIER_POINTER (TREE_PURPOSE (fields)); } goto int_case; case POINTER_TYPE: if (x == 0) return "NULL"; goto int_case; int_case: default: /* This code is derived from print-tree.c:print_code_brief. */ if (TREE_INT_CST_HIGH (val) == 0) sprintf (buffer, #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT "%1u", #else "%1lu", #endif x); else if (TREE_INT_CST_HIGH (val) == -1 && TREE_INT_CST_LOW (val) != 0) sprintf (buffer, #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT "-%1u", #else "-%1lu", #endif -x); else sprintf (buffer, #if HOST_BITS_PER_WIDE_INT == 64 #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT "H'%lx%016lx", #else "H'%x%016x", #endif #else #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT "H'%lx%08lx", #else "H'%x%08x", #endif #endif TREE_INT_CST_HIGH (val), TREE_INT_CST_LOW (val)); return buffer; } } static tree digest_array_tuple (type, init, allow_missing_elements) tree type; tree init; int allow_missing_elements; { tree element = CONSTRUCTOR_ELTS (init); int is_constant = 1; int is_simple = 1; tree element_type = TREE_TYPE (type); tree default_value = NULL_TREE; tree element_list = NULL_TREE; tree domain_min; tree domain_max; tree *ptr = &element_list; int errors = 0; int labelled_elements = 0; int unlabelled_elements = 0; tree first, last = NULL_TREE; if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) return error_mark_node; domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); domain_max = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); if (domain_min == NULL || TREE_CODE (domain_min) != INTEGER_CST) { error ("non-constant start index for tuple"); return error_mark_node; } if (TREE_CODE (domain_max) != INTEGER_CST) is_constant = 0; if (TREE_CODE (type) != ARRAY_TYPE) abort (); for ( ; element != NULL_TREE; element = TREE_CHAIN (element)) { tree purpose = TREE_PURPOSE (element); tree value = TREE_VALUE (element); if (purpose == NULL_TREE) { if (last == NULL_TREE) first = domain_min; else { HOST_WIDE_INT new_lo, new_hi; add_double (TREE_INT_CST_LOW (last), TREE_INT_CST_HIGH (last), 1, 0, &new_lo, &new_hi); first = build_int_2 (new_lo, new_hi); TREE_TYPE (first) = TYPE_DOMAIN (type); } last = first; unlabelled_elements++; } else { labelled_elements++; if (TREE_CODE (purpose) == INTEGER_CST) first = last = purpose; else if (TREE_CODE (purpose) == TYPE_DECL && discrete_type_p (TREE_TYPE (purpose))) { first = TYPE_MIN_VALUE (TREE_TYPE (purpose)); last = TYPE_MAX_VALUE (TREE_TYPE (purpose)); } else if (TREE_CODE (purpose) != RANGE_EXPR) { error ("invalid array tuple label"); errors++; continue; } else if (TREE_OPERAND (purpose, 0) == NULL_TREE) first = last = NULL_TREE; /* Default value. */ else { first = TREE_OPERAND (purpose, 0); last = TREE_OPERAND (purpose, 1); } if ((first != NULL && TREE_CODE (first) != INTEGER_CST) || (last != NULL && TREE_CODE (last) != INTEGER_CST)) { error ("non-constant array tuple index range"); errors++; } } if (! CH_COMPATIBLE (value, element_type)) { const char *err_val_name = first ? display_int_cst (first) : "(default)"; error ("incompatible array tuple element %s", err_val_name); value = error_mark_node; } else value = convert (element_type, value); if (TREE_CODE (value) == ERROR_MARK) errors++; else if (!TREE_CONSTANT (value)) is_constant = 0; else if (!initializer_constant_valid_p (value, TREE_TYPE (value))) is_simple = 0; if (first == NULL_TREE) { if (default_value != NULL) { error ("multiple (*) or (ELSE) array tuple labels"); errors++; } default_value = value; continue; } if (first != last && tree_int_cst_lt (last, first)) { error ("empty range in array tuple"); errors++; continue; } ptr = &element_list; #define MAYBE_RANGE_OP(PURPOSE, OPNO) \ (TREE_CODE (PURPOSE) == RANGE_EXPR ? TREE_OPERAND (PURPOSE, OPNO): PURPOSE) #define CONSTRUCTOR_ELT_LO(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 0) #define CONSTRUCTOR_ELT_HI(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 1) while (*ptr && tree_int_cst_lt (last, CONSTRUCTOR_ELT_LO (*ptr))) ptr = &TREE_CHAIN (*ptr); if (*ptr && ! tree_int_cst_lt (CONSTRUCTOR_ELT_HI (*ptr), first)) { const char *err_val_name = display_int_cst (first); error ("array tuple has duplicate index %s", err_val_name); errors++; continue; } if ((ptr == &element_list && tree_int_cst_lt (domain_max, last)) || (*ptr == NULL_TREE && tree_int_cst_lt (first, domain_min))) { if (purpose) error ("array tuple index out of range"); else if (errors == 0) error ("too many array tuple values"); errors++; continue; } if (! tree_int_cst_lt (first, last)) purpose = first; else if (purpose == NULL_TREE || TREE_CODE (purpose) != RANGE_EXPR) purpose = build_nt (RANGE_EXPR, first, last); *ptr = tree_cons (purpose, value, *ptr); } element_list = nreverse (element_list); /* For each missing element, set it to the default value, if there is one. Otherwise, emit an error. */ if (errors == 0 && (!allow_missing_elements || default_value != NULL_TREE)) { /* Iterate over each *gap* between specified elements/ranges. */ tree prev_elt; if (element_list && tree_int_cst_equal (CONSTRUCTOR_ELT_LO (element_list), domain_min)) { ptr = &TREE_CHAIN (element_list); prev_elt = element_list; } else { prev_elt = NULL_TREE; ptr = &element_list; } for (;;) { tree first, last; /* Calculate the first element of the gap. */ if (prev_elt == NULL_TREE) first = domain_min; else { first = CONSTRUCTOR_ELT_HI (prev_elt); if (tree_int_cst_equal (first, domain_max)) break; /* We're done. Avoid overflow below. */ first = copy_node (first); add_double (TREE_INT_CST_LOW (first), TREE_INT_CST_HIGH (first), 1, 0, &TREE_INT_CST_LOW (first), &TREE_INT_CST_HIGH (first)); } /* Calculate the last element of the gap. */ if (*ptr) { /* Actually end up with correct type. */ last = size_binop (MINUS_EXPR, CONSTRUCTOR_ELT_LO (*ptr), integer_one_node); } else last = domain_max; if (TREE_CODE (last) == INTEGER_CST && tree_int_cst_lt (last, first)) ; /* Empty "gap" - no missing elements. */ else if (default_value) { tree purpose; if (tree_int_cst_equal (first, last)) purpose = first; else purpose = build_nt (RANGE_EXPR, first, last); *ptr = tree_cons (purpose, default_value, *ptr); } else { const char *err_val_name = display_int_cst (first); if (TREE_CODE (last) != INTEGER_CST) error ("dynamic array tuple without (*) or (ELSE)"); else if (tree_int_cst_equal (first, last)) error ("missing array tuple element %s", err_val_name); else { char *first_name = (char *) xmalloc (strlen (err_val_name) + 1); strcpy (first_name, err_val_name); err_val_name = display_int_cst (last); error ("missing array tuple elements %s : %s", first_name, err_val_name); free (first_name); } errors++; } if (*ptr == NULL_TREE) break; prev_elt = *ptr; ptr = &TREE_CHAIN (*ptr); } } if (errors) return error_mark_node; element = build (CONSTRUCTOR, type, NULL_TREE, element_list); TREE_CONSTANT (element) = is_constant; if (is_constant && is_simple) TREE_STATIC (element) = 1; if (labelled_elements && unlabelled_elements) pedwarn ("mixture of labelled and unlabelled tuple elements"); return element; } /* This function is needed because no-op CHILL conversions are not fully understood by the initialization machinery. This function should only be called when a conversion truly is a no-op. */ static tree convert1 (type, expr) tree type, expr; { int was_constant = TREE_CONSTANT (expr); STRIP_NOPS (expr); was_constant |= TREE_CONSTANT (expr); expr = copy_node (expr); TREE_TYPE (expr) = type; if (TREE_CONSTANT (expr) != was_constant) abort (); TREE_CONSTANT (expr) = was_constant; return expr; } /* Create an expression whose value is that of EXPR, converted to type TYPE. The TREE_TYPE of the value is always TYPE. This function implements all reasonable conversions; callers should filter out those that are not permitted by the language being compiled. In CHILL, we assume that the type is Compatible with the Class of expr, and generally complain otherwise. However, convert is more general (e.g. allows enum<->int conversion), so there should probably be at least two routines. Maybe add something like convert_for_assignment. FIXME. */ tree convert (type, expr) tree type, expr; { register tree e = expr; register enum chill_tree_code code; int type_varying; if (e == NULL_TREE || TREE_CODE (e) == ERROR_MARK) return error_mark_node; if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) return error_mark_node; code = TREE_CODE (type); if (type == TREE_TYPE (e)) return e; if (TREE_TYPE (e) != NULL_TREE && TREE_CODE (TREE_TYPE (e)) == REFERENCE_TYPE) e = convert_from_reference (e); /* Support for converting *to* a reference type is limited; it is only here as a convenience for loc-identity declarations, and loc parameters. */ if (code == REFERENCE_TYPE) return convert_to_reference (type, e); /* if expression was untyped because of its context (an if_expr or case_expr in a tuple, perhaps) just apply the type */ if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == ERROR_MARK) { TREE_TYPE (e) = type; return e; } /* Turn a NULL keyword into [0, 0] for an instance */ if (CH_IS_INSTANCE_MODE (type) && expr == null_pointer_node) { tree field0 = TYPE_FIELDS (type); tree field1 = TREE_CHAIN (field0); e = build (CONSTRUCTOR, type, NULL_TREE, tree_cons (field0, integer_zero_node, tree_cons (field1, integer_zero_node, NULL_TREE))); TREE_CONSTANT (e) = 1; TREE_STATIC (e) = 1; return e; } /* Turn a pointer into a function pointer for a procmode */ if (TREE_CODE (type) == POINTER_TYPE && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE && expr == null_pointer_node) return convert1 (type, expr); /* turn function_decl expression into a pointer to that function */ if (TREE_CODE (expr) == FUNCTION_DECL && TREE_CODE (type) == POINTER_TYPE && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE) { e = build1 (ADDR_EXPR, type, expr); TREE_CONSTANT (e) = 1; return e; } if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE) e = varying_to_slice (e); type_varying = chill_varying_type_p (type); /* Convert a char to a singleton string. Needed for compatibility with 1984 version of Z.200. */ if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == CHAR_TYPE && (CH_CHARS_ONE_P (type) || type_varying)) { if (TREE_CODE (e) == INTEGER_CST) { char ch = TREE_INT_CST_LOW (e); e = build_chill_string (1, &ch); } else e = build (CONSTRUCTOR, string_one_type_node, NULL_TREE, tree_cons (NULL_TREE, e, NULL_TREE)); } /* Convert a Boolean to a singleton bitstring. Needed for compatibility with 1984 version of Z.200. */ if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == BOOLEAN_TYPE && (CH_BOOLS_ONE_P (type) || type_varying)) { if (TREE_CODE (e) == INTEGER_CST) e = integer_zerop (e) ? bit_zero_node : bit_one_node; else e = build (COND_EXPR, bitstring_one_type_node, e, bit_one_node, bit_zero_node); } if (type_varying) { tree nentries; tree field0 = TYPE_FIELDS (type); tree field1 = TREE_CHAIN (field0); tree orig_e = e; tree target_array_type = TREE_TYPE (field1); tree needed_padding; tree padding_max_size = 0; int orig_e_constant = TREE_CONSTANT (orig_e); if (TREE_TYPE (e) != NULL_TREE && TREE_CODE (TREE_TYPE (e)) == ARRAY_TYPE) { /* Note that array_type_nelts returns 1 less than the size. */ nentries = array_type_nelts (TREE_TYPE (e)); needed_padding = size_binop (MINUS_EXPR, array_type_nelts (target_array_type), nentries); if (TREE_CODE (needed_padding) != INTEGER_CST) { padding_max_size = size_in_bytes (TREE_TYPE (e)); if (TREE_CODE (padding_max_size) != INTEGER_CST) padding_max_size = TYPE_ARRAY_MAX_SIZE (TREE_TYPE (e)); } nentries = size_binop (PLUS_EXPR, nentries, integer_one_node); } else if (TREE_CODE (e) == CONSTRUCTOR) { HOST_WIDE_INT init_cnt = 0; tree chaser = CONSTRUCTOR_ELTS (e); for ( ; chaser; chaser = TREE_CHAIN (chaser)) init_cnt++; /* count initializer elements */ nentries = build_int_2 (init_cnt, 0); needed_padding = integer_zero_node; if (TREE_TYPE (e) == NULL_TREE) e = digest_array_tuple (TREE_TYPE (field1), e, 1); orig_e_constant = TREE_CONSTANT (e); } else { error ("initializer is not an array or string mode"); return error_mark_node; } #if 0 FIXME check that nentries will fit in type; #endif if (!integer_zerop (needed_padding)) { tree padding, padding_type, padding_range; if (TREE_CODE (needed_padding) == INTEGER_CST && (long)TREE_INT_CST_LOW (needed_padding) < 0) { error ("destination is too small"); return error_mark_node; } padding_range = build_chill_range_type (NULL_TREE, integer_one_node, needed_padding); padding_type = build_simple_array_type (TREE_TYPE (target_array_type), padding_range, NULL_TREE); TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size; if (CH_CHARS_TYPE_P (target_array_type)) MARK_AS_STRING_TYPE (padding_type); padding = build (UNDEFINED_EXPR, padding_type); if (TREE_CONSTANT (e)) e = build_chill_binary_op (CONCAT_EXPR, e, padding); else e = build (CONCAT_EXPR, target_array_type, e, padding); } e = convert (TREE_TYPE (field1), e); /* We build this constructor by hand (rather than going through digest_structure_tuple), to avoid some type-checking problem. E.g. type may have non-null novelty, but its field1 will have non-novelty. */ e = build (CONSTRUCTOR, type, NULL_TREE, tree_cons (field0, nentries, build_tree_list (field1, e))); /* following was wrong, cause orig_e never will be TREE_CONSTANT. e may become constant after digest_array_tuple. */ if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */ { TREE_CONSTANT (e) = 1; if (TREE_STATIC (nentries) && TREE_STATIC (orig_e)) TREE_STATIC (e) = 1; } } if (TREE_TYPE (e) == NULL_TREE) { if (TREE_CODE (e) == CONSTRUCTOR) { if (TREE_CODE (type) == SET_TYPE) return digest_powerset_tuple (type, e); if (TREE_CODE (type) == RECORD_TYPE) return digest_structure_tuple (type, e); if (TREE_CODE (type) == ARRAY_TYPE) return digest_array_tuple (type, e, 0); fatal ("internal error - bad CONSTRUCTOR passed to convert"); } else if (TREE_CODE (e) == COND_EXPR) e = build (COND_EXPR, type, TREE_OPERAND (e, 0), convert (type, TREE_OPERAND (e, 1)), convert (type, TREE_OPERAND (e, 2))); else if (TREE_CODE (e) == CASE_EXPR) TREE_TYPE (e) = type; else { error ("internal error: unknown type of expression"); return error_mark_node; } } if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)) || (CH_NOVELTY (type) != NULL_TREE && CH_NOVELTY (type) == CH_NOVELTY (TREE_TYPE (e)))) return convert1 (type, e); if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) { error ("void value not ignored as it ought to be"); return error_mark_node; } if (code == VOID_TYPE) return build1 (CONVERT_EXPR, type, e); if (code == SET_TYPE) return convert1 (type, e); if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) { if (flag_old_strings) { if (CH_CHARS_ONE_P (TREE_TYPE (e))) e = convert_to_char (char_type_node, e); else if (CH_BOOLS_ONE_P (TREE_TYPE (e))) e = convert_to_boolean (boolean_type_node, e); } return fold (convert_to_integer (type, e)); } if (code == POINTER_TYPE) return fold (convert_to_pointer (type, e)); if (code == REAL_TYPE) return fold (convert_to_real (type, e)); if (code == BOOLEAN_TYPE) return fold (convert_to_boolean (type, e)); if (code == CHAR_TYPE) return fold (convert_to_char (type, e)); if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e))) { /* The mode of the expression is different from that of the type. Earlier checks should have tested against different lengths. But even if the lengths are the same, it is possible that one type is a static type (and hence could be say SImode), while the other type is dynamic type (and hence is BLKmode). This causes problems when emitting instructions. */ tree ee = build1 (INDIRECT_REF, type, build1 (NOP_EXPR, build_pointer_type (type), build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (e)), e))); TREE_READONLY (ee) = TYPE_READONLY (type); return ee; } /* The default! */ return convert1 (type, e); } /* Return an expression whose value is EXPR, but whose class is CLASS. */ tree convert_to_class (class, expr) struct ch_class class; tree expr; { switch (class.kind) { case CH_NULL_CLASS: case CH_ALL_CLASS: return expr; case CH_DERIVED_CLASS: if (TREE_TYPE (expr) != class.mode) expr = convert (class.mode, expr); if (!CH_DERIVED_FLAG (expr)) { expr = copy_node (expr); CH_DERIVED_FLAG (expr) = 1; } return expr; case CH_VALUE_CLASS: case CH_REFERENCE_CLASS: if (TREE_TYPE (expr) != class.mode) expr = convert (class.mode, expr); if (CH_DERIVED_FLAG (expr)) { expr = copy_node (expr); CH_DERIVED_FLAG (expr) = 0; } return expr; } return expr; }