1 /* Language-level data type conversion for GNU CHILL.
2 Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000
3 Free Software Foundation, Inc.
5 This file is part of GNU CC.
7 GNU CC is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU CC is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU CC; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
23 /* This file contains the functions for converting CHILL expressions
24 to different data types. The only entry point is `convert'.
25 Every language front end must have a `convert' function
26 but what kind of conversions it does will depend on the language. */
38 extern tree bit_one_node, bit_zero_node;
39 extern tree string_one_type_node;
40 extern tree bitstring_one_type_node;
42 static tree convert_to_reference PARAMS ((tree, tree));
43 static tree convert_to_boolean PARAMS ((tree, tree));
44 static tree convert_to_char PARAMS ((tree, tree));
46 static tree base_type_size_in_bytes PARAMS ((tree));
48 static tree remove_tree_element PARAMS ((tree, tree *));
49 static tree check_ps_range PARAMS ((tree, tree, tree));
50 static tree digest_powerset_tuple PARAMS ((tree, tree));
51 static tree digest_structure_tuple PARAMS ((tree, tree));
52 static tree digest_array_tuple PARAMS ((tree, tree, int));
53 static tree convert1 PARAMS ((tree, tree));
56 convert_to_reference (reftype, expr)
59 while (TREE_CODE (expr) == NOP_EXPR) /* RETYPE_EXPR */
60 expr = TREE_OPERAND (expr, 0);
62 if (! CH_LOCATION_P (expr))
63 error("internal error: trying to make loc-identity with non-location");
66 mark_addressable (expr);
67 return fold (build1 (ADDR_EXPR, reftype, expr));
70 return error_mark_node;
74 convert_from_reference (expr)
77 tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr);
78 TREE_READONLY (e) = TREE_READONLY (expr);
82 /* Convert EXPR to a boolean type. */
85 convert_to_boolean (type, expr)
88 register tree intype = TREE_TYPE (expr);
90 if (integer_zerop (expr))
91 return boolean_false_node;
92 if (integer_onep (expr))
93 return boolean_true_node;
95 /* Convert a singleton bitstring to a Boolean.
96 Needed if flag_old_strings. */
97 if (CH_BOOLS_ONE_P (intype))
99 if (TREE_CODE (expr) == CONSTRUCTOR)
101 tree valuelist = TREE_OPERAND (expr, 1);
102 if (valuelist == NULL_TREE)
103 return boolean_false_node;
104 if (TREE_CHAIN (valuelist) == NULL_TREE
105 && TREE_PURPOSE (valuelist) == NULL_TREE
106 && integer_zerop (TREE_VALUE (valuelist)))
107 return boolean_true_node;
109 return build_chill_bitref (expr,
110 build_tree_list (NULL_TREE,
114 if (INTEGRAL_TYPE_P (intype))
115 return build1 (CONVERT_EXPR, type, expr);
117 error ("cannot convert to a boolean mode");
118 return boolean_false_node;
121 /* Convert EXPR to a char type. */
124 convert_to_char (type, expr)
127 register tree intype = TREE_TYPE (expr);
128 register enum chill_tree_code form = TREE_CODE (intype);
130 if (form == CHAR_TYPE)
131 return build1 (NOP_EXPR, type, expr);
133 /* Convert a singleton string to a char.
134 Needed if flag_old_strings. */
135 if (CH_CHARS_ONE_P (intype))
137 if (TREE_CODE (expr) == STRING_CST)
139 expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0);
140 TREE_TYPE (expr) = char_type_node;
144 return build (ARRAY_REF, char_type_node, expr, integer_zero_node);
148 /* For now, assume it will always fit */
149 if (form == INTEGER_TYPE)
150 return build1 (CONVERT_EXPR, type, expr);
152 error ("cannot convert to a char mode");
155 register tree tem = build_int_2 (0, 0);
156 TREE_TYPE (tem) = type;
163 base_type_size_in_bytes (type)
166 if (type == NULL_TREE
167 || TREE_CODE (type) == ERROR_MARK
168 || TREE_CODE (type) != ARRAY_TYPE)
169 return error_mark_node;
170 return size_in_bytes (TREE_TYPE (type));
175 * build a singleton array type, of TYPE objects.
178 build_array_type_for_scalar (type)
182 if (type == char_type_node)
183 return build_string_type (type, integer_one_node);
185 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
186 return error_mark_node;
188 return build_chill_array_type
190 tree_cons (NULL_TREE,
191 build_chill_range_type (NULL_TREE,
192 integer_zero_node, integer_zero_node),
200 unreferenced_type_of (type)
203 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
204 return error_mark_node;
205 while (TREE_CODE (type) == REFERENCE_TYPE)
206 type = TREE_TYPE (type);
212 /* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY.
213 Return the TREE_LIST node, or NULL_TREE on failure. */
216 remove_tree_element (key, listp)
221 for ( ; node; listp = &TREE_CHAIN (node), node = *listp)
223 if (TREE_PURPOSE (node) == key)
225 *listp = TREE_CHAIN (node);
226 TREE_CHAIN (node) = NULL_TREE;
233 /* This is quite the same as check_range in actions.c, but with
234 different error message. */
237 check_ps_range (value, lo_limit, hi_limit)
242 tree check = test_range (value, lo_limit, hi_limit);
244 if (!integer_zerop (check))
246 if (TREE_CODE (check) == INTEGER_CST)
248 error ("powerset tuple element out of range");
249 return error_mark_node;
252 value = check_expression (value, check,
253 ridpointers[(int) RID_RANGEFAIL]);
259 digest_powerset_tuple (type, inits)
265 tree domain = TYPE_DOMAIN (type);
267 int is_erroneous = 0, is_constant = 1, is_simple = 1;
268 if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK)
269 return error_mark_node;
270 for (list = TREE_OPERAND (inits, 1); list; list = TREE_CHAIN (list), i++)
272 tree val = TREE_VALUE (list);
273 if (TREE_CODE (val) == ERROR_MARK)
278 if (!TREE_CONSTANT (val))
280 else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
282 if (! CH_COMPATIBLE (val, domain))
284 error ("incompatible member of powerset tuple (at position #%d)", i);
288 /* check range of value */
289 val = check_ps_range (val, TYPE_MIN_VALUE (domain),
290 TYPE_MAX_VALUE (domain));
291 if (TREE_CODE (val) == ERROR_MARK)
297 /* Updating the list in place is in principle questionable,
298 but I can't think how it could hurt. */
299 TREE_VALUE (list) = convert (domain, val);
301 val = TREE_PURPOSE (list);
302 if (val == NULL_TREE)
305 if (TREE_CODE (val) == ERROR_MARK)
310 if (! CH_COMPATIBLE (val, domain))
312 error ("incompatible member of powerset tuple (at position #%d)", i);
316 val = check_ps_range (val, TYPE_MIN_VALUE (domain),
317 TYPE_MAX_VALUE (domain));
318 if (TREE_CODE (val) == ERROR_MARK)
323 TREE_PURPOSE (list) = convert (domain, val);
324 if (!TREE_CONSTANT (val))
326 else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
329 result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1));
331 return error_mark_node;
333 TREE_CONSTANT (result) = 1;
334 if (is_constant && is_simple)
335 TREE_STATIC (result) = 1;
340 digest_structure_tuple (type, inits)
344 tree elements = CONSTRUCTOR_ELTS (inits);
345 tree values = NULL_TREE;
348 int is_erroneous = 0;
350 int labelled_elements = 0;
351 int unlabelled_elements = 0;
352 for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
354 if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE)
355 { /* Regular fixed field. */
356 tree value = remove_tree_element (DECL_NAME (field), &elements);
360 else if (elements && TREE_PURPOSE (elements) == NULL_TREE)
363 elements = TREE_CHAIN (elements);
364 unlabelled_elements++;
371 sprintf (msg, "initializer for field `%.80s'",
372 IDENTIFIER_POINTER (DECL_NAME (field)));
373 val = chill_convert_for_assignment (TREE_TYPE (field),
374 TREE_VALUE (value), msg);
375 if (TREE_CODE (val) == ERROR_MARK)
379 TREE_VALUE (value) = val;
380 TREE_CHAIN (value) = values;
381 TREE_PURPOSE (value) = field;
383 if (TREE_CODE (val) == ERROR_MARK)
385 else if (!TREE_CONSTANT (val))
387 else if (!initializer_constant_valid_p (val,
394 pedwarn ("no initializer value for fixed field `%s'",
395 IDENTIFIER_POINTER (DECL_NAME (field)));
401 tree selected_variant = NULL_TREE;
402 tree variant_values = NULL_TREE;
404 /* In a tagged variant structure mode, try to figure out
405 (from the fixed fields), which is the selected variant. */
406 if (TYPE_TAGFIELDS (TREE_TYPE (field)))
408 for (variant = TYPE_FIELDS (TREE_TYPE (field));
409 variant; variant = TREE_CHAIN (variant))
411 tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant));
412 tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field));
413 if (DECL_NAME (variant) == ELSE_VARIANT_NAME)
415 selected_variant = variant;
418 for (; tag_labels && tag_fields;
419 tag_labels = TREE_CHAIN (tag_labels),
420 tag_fields = TREE_CHAIN (tag_fields))
422 tree tag_value = values;
424 tree tag_decl = TREE_VALUE (tag_fields);
425 tree tag_value_set = TREE_VALUE (tag_labels);
426 for ( ; tag_value; tag_value = TREE_CHAIN (tag_value))
428 if (TREE_PURPOSE (tag_value) == tag_decl)
430 tag_value = TREE_VALUE (tag_value);
434 if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST)
436 pedwarn ("non-constant value for tag field `%s'",
437 IDENTIFIER_POINTER (DECL_NAME (tag_decl)));
441 /* Check if the value of the tag (as given in a
442 previous field) matches the case label list. */
443 for (; tag_value_set;
444 tag_value_set = TREE_CHAIN (tag_value_set))
446 if (tree_int_cst_equal (TREE_VALUE (tag_value_set),
458 selected_variant = variant;
464 for (variant = TYPE_FIELDS (TREE_TYPE (field));
465 variant; variant = TREE_CHAIN (variant))
467 tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant));
469 for (vfield = vfield0; vfield; vfield = TREE_CHAIN (vfield))
471 tree value = remove_tree_element (DECL_NAME (vfield),
476 else if (variant == selected_variant
477 && elements && TREE_PURPOSE (elements) == NULL_TREE)
480 elements = TREE_CHAIN (elements);
481 unlabelled_elements++;
486 if (selected_variant && selected_variant != variant)
488 error ("field `%s' in wrong variant",
489 IDENTIFIER_POINTER (DECL_NAME (vfield)));
494 if (!selected_variant && vfield != vfield0)
495 pedwarn ("missing variant fields (at least `%s')",
496 IDENTIFIER_POINTER (DECL_NAME (vfield0)));
497 selected_variant = variant;
498 if (CH_COMPATIBLE (TREE_VALUE (value),
501 tree val = convert (TREE_TYPE (vfield),
503 TREE_PURPOSE (value) = vfield;
504 TREE_VALUE (value) = val;
505 TREE_CHAIN (value) = variant_values;
506 variant_values = value;
507 if (TREE_CODE (val) == ERROR_MARK)
509 else if (!TREE_CONSTANT (val))
511 else if (!initializer_constant_valid_p
512 (val, TREE_TYPE (val)))
518 error ("bad initializer for field `%s'",
519 IDENTIFIER_POINTER (DECL_NAME (vfield)));
523 else if (variant == selected_variant)
525 pedwarn ("no initializer value for variant field `%s'",
526 IDENTIFIER_POINTER (DECL_NAME (field)));
530 if (selected_variant == NULL_TREE)
531 pedwarn ("no selected variant");
534 variant_values = build (CONSTRUCTOR,
535 TREE_TYPE (selected_variant),
536 NULL_TREE, nreverse (variant_values));
538 = build (CONSTRUCTOR, TREE_TYPE (field), NULL_TREE,
539 build_tree_list (selected_variant, variant_values));
540 values = tree_cons (field, variant_values, values);
545 if (labelled_elements && unlabelled_elements)
546 pedwarn ("mixture of labelled and unlabelled tuple elements");
548 /* Check for unused initializer elements. */
549 unlabelled_elements = 0;
550 for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements))
552 if (TREE_PURPOSE (elements) == NULL_TREE)
553 unlabelled_elements++;
556 if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0)
557 error ("probably not a structure tuple");
559 error ("excess initializer for field `%s'",
560 IDENTIFIER_POINTER (TREE_PURPOSE (elements)));
564 if (unlabelled_elements)
566 error ("excess unnamed initializers");
570 CONSTRUCTOR_ELTS (inits) = nreverse (values);
571 TREE_TYPE (inits) = type;
573 return error_mark_node;
575 TREE_CONSTANT (inits) = 1;
576 if (is_constant && is_simple)
577 TREE_STATIC (inits) = 1;
581 /* Return a Chill representation of the INTEGER_CST VAL.
582 The result may be in a static buffer, */
585 display_int_cst (val)
588 static char buffer[50];
591 if (TREE_CODE (val) != INTEGER_CST)
592 return "<not a constant>";
594 x = TREE_INT_CST_LOW (val);
596 switch (TREE_CODE (TREE_TYPE (val)))
606 strcpy (buffer, "'^^'");
608 strcpy (buffer, "'^J'");
609 else if (x < ' ' || x > '~')
610 sprintf (buffer, "'^(%u)'", (unsigned int) x);
612 sprintf (buffer, "'%c'", (char) x);
615 for (fields = TYPE_VALUES (TREE_TYPE (val)); fields != NULL_TREE;
616 fields = TREE_CHAIN (fields))
618 if (tree_int_cst_equal (TREE_VALUE (fields), val))
619 return IDENTIFIER_POINTER (TREE_PURPOSE (fields));
628 /* This code is derived from print-tree.c:print_code_brief. */
629 if (TREE_INT_CST_HIGH (val) == 0)
631 #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
637 else if (TREE_INT_CST_HIGH (val) == -1 && TREE_INT_CST_LOW (val) != 0)
639 #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
647 #if HOST_BITS_PER_WIDE_INT == 64
648 #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
654 #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
660 TREE_INT_CST_HIGH (val), TREE_INT_CST_LOW (val));
666 digest_array_tuple (type, init, allow_missing_elements)
669 int allow_missing_elements;
671 tree element = CONSTRUCTOR_ELTS (init);
674 tree element_type = TREE_TYPE (type);
675 tree default_value = NULL_TREE;
676 tree element_list = NULL_TREE;
679 tree *ptr = &element_list;
681 int labelled_elements = 0;
682 int unlabelled_elements = 0;
683 tree first, last = NULL_TREE;
685 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
686 return error_mark_node;
688 domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
689 domain_max = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
691 if (domain_min == NULL || TREE_CODE (domain_min) != INTEGER_CST)
693 error ("non-constant start index for tuple");
694 return error_mark_node;
696 if (TREE_CODE (domain_max) != INTEGER_CST)
699 if (TREE_CODE (type) != ARRAY_TYPE)
702 for ( ; element != NULL_TREE; element = TREE_CHAIN (element))
704 tree purpose = TREE_PURPOSE (element);
705 tree value = TREE_VALUE (element);
707 if (purpose == NULL_TREE)
709 if (last == NULL_TREE)
713 HOST_WIDE_INT new_lo, new_hi;
714 add_double (TREE_INT_CST_LOW (last), TREE_INT_CST_HIGH (last),
717 first = build_int_2 (new_lo, new_hi);
718 TREE_TYPE (first) = TYPE_DOMAIN (type);
721 unlabelled_elements++;
726 if (TREE_CODE (purpose) == INTEGER_CST)
727 first = last = purpose;
728 else if (TREE_CODE (purpose) == TYPE_DECL
729 && discrete_type_p (TREE_TYPE (purpose)))
731 first = TYPE_MIN_VALUE (TREE_TYPE (purpose));
732 last = TYPE_MAX_VALUE (TREE_TYPE (purpose));
734 else if (TREE_CODE (purpose) != RANGE_EXPR)
736 error ("invalid array tuple label");
740 else if (TREE_OPERAND (purpose, 0) == NULL_TREE)
741 first = last = NULL_TREE; /* Default value. */
744 first = TREE_OPERAND (purpose, 0);
745 last = TREE_OPERAND (purpose, 1);
747 if ((first != NULL && TREE_CODE (first) != INTEGER_CST)
748 || (last != NULL && TREE_CODE (last) != INTEGER_CST))
750 error ("non-constant array tuple index range");
755 if (! CH_COMPATIBLE (value, element_type))
757 const char *err_val_name =
758 first ? display_int_cst (first) : "(default)";
759 error ("incompatible array tuple element %s", err_val_name);
760 value = error_mark_node;
763 value = convert (element_type, value);
764 if (TREE_CODE (value) == ERROR_MARK)
766 else if (!TREE_CONSTANT (value))
768 else if (!initializer_constant_valid_p (value, TREE_TYPE (value)))
771 if (first == NULL_TREE)
773 if (default_value != NULL)
775 error ("multiple (*) or (ELSE) array tuple labels");
778 default_value = value;
782 if (first != last && tree_int_cst_lt (last, first))
784 error ("empty range in array tuple");
791 #define MAYBE_RANGE_OP(PURPOSE, OPNO) \
792 (TREE_CODE (PURPOSE) == RANGE_EXPR ? TREE_OPERAND (PURPOSE, OPNO): PURPOSE)
793 #define CONSTRUCTOR_ELT_LO(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 0)
794 #define CONSTRUCTOR_ELT_HI(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 1)
795 while (*ptr && tree_int_cst_lt (last,
796 CONSTRUCTOR_ELT_LO (*ptr)))
797 ptr = &TREE_CHAIN (*ptr);
798 if (*ptr && ! tree_int_cst_lt (CONSTRUCTOR_ELT_HI (*ptr), first))
800 const char *err_val_name = display_int_cst (first);
801 error ("array tuple has duplicate index %s", err_val_name);
805 if ((ptr == &element_list && tree_int_cst_lt (domain_max, last))
806 || (*ptr == NULL_TREE && tree_int_cst_lt (first, domain_min)))
809 error ("array tuple index out of range");
810 else if (errors == 0)
811 error ("too many array tuple values");
815 if (! tree_int_cst_lt (first, last))
817 else if (purpose == NULL_TREE || TREE_CODE (purpose) != RANGE_EXPR)
818 purpose = build_nt (RANGE_EXPR, first, last);
819 *ptr = tree_cons (purpose, value, *ptr);
822 element_list = nreverse (element_list);
824 /* For each missing element, set it to the default value,
825 if there is one. Otherwise, emit an error. */
828 && (!allow_missing_elements || default_value != NULL_TREE))
830 /* Iterate over each *gap* between specified elements/ranges. */
833 tree_int_cst_equal (CONSTRUCTOR_ELT_LO (element_list), domain_min))
835 ptr = &TREE_CHAIN (element_list);
836 prev_elt = element_list;
840 prev_elt = NULL_TREE;
846 /* Calculate the first element of the gap. */
847 if (prev_elt == NULL_TREE)
851 first = CONSTRUCTOR_ELT_HI (prev_elt);
852 if (tree_int_cst_equal (first, domain_max))
853 break; /* We're done. Avoid overflow below. */
854 first = copy_node (first);
855 add_double (TREE_INT_CST_LOW (first), TREE_INT_CST_HIGH (first),
857 &TREE_INT_CST_LOW (first),
858 &TREE_INT_CST_HIGH (first));
860 /* Calculate the last element of the gap. */
862 last = fold (build (MINUS_EXPR, integer_type_node,
863 CONSTRUCTOR_ELT_LO (*ptr),
868 if (TREE_CODE (last) == INTEGER_CST && tree_int_cst_lt (last, first))
869 ; /* Empty "gap" - no missing elements. */
870 else if (default_value)
873 if (tree_int_cst_equal (first, last))
876 purpose = build_nt (RANGE_EXPR, first, last);
877 *ptr = tree_cons (purpose, default_value, *ptr);
881 const char *err_val_name = display_int_cst (first);
882 if (TREE_CODE (last) != INTEGER_CST)
883 error ("dynamic array tuple without (*) or (ELSE)");
884 else if (tree_int_cst_equal (first, last))
885 error ("missing array tuple element %s", err_val_name);
888 char *first_name = (char *)
889 xmalloc (strlen (err_val_name) + 1);
890 strcpy (first_name, err_val_name);
891 err_val_name = display_int_cst (last);
892 error ("missing array tuple elements %s : %s",
893 first_name, err_val_name);
898 if (*ptr == NULL_TREE)
901 ptr = &TREE_CHAIN (*ptr);
905 return error_mark_node;
907 element = build (CONSTRUCTOR, type, NULL_TREE, element_list);
908 TREE_CONSTANT (element) = is_constant;
909 if (is_constant && is_simple)
910 TREE_STATIC (element) = 1;
911 if (labelled_elements && unlabelled_elements)
912 pedwarn ("mixture of labelled and unlabelled tuple elements");
916 /* This function is needed because no-op CHILL conversions are not fully
917 understood by the initialization machinery. This function should only
918 be called when a conversion truly is a no-op. */
921 convert1 (type, expr)
924 int was_constant = TREE_CONSTANT (expr);
926 was_constant |= TREE_CONSTANT (expr);
927 expr = copy_node (expr);
928 TREE_TYPE (expr) = type;
929 if (TREE_CONSTANT (expr) != was_constant) abort ();
930 TREE_CONSTANT (expr) = was_constant;
934 /* Create an expression whose value is that of EXPR,
935 converted to type TYPE. The TREE_TYPE of the value
936 is always TYPE. This function implements all reasonable
937 conversions; callers should filter out those that are
938 not permitted by the language being compiled.
940 In CHILL, we assume that the type is Compatible with the
941 Class of expr, and generally complain otherwise.
942 However, convert is more general (e.g. allows enum<->int
943 conversion), so there should probably be at least two routines.
944 Maybe add something like convert_for_assignment. FIXME. */
950 register tree e = expr;
951 register enum chill_tree_code code;
954 if (e == NULL_TREE || TREE_CODE (e) == ERROR_MARK)
955 return error_mark_node;
957 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
958 return error_mark_node;
960 code = TREE_CODE (type);
962 if (type == TREE_TYPE (e))
965 if (TREE_TYPE (e) != NULL_TREE
966 && TREE_CODE (TREE_TYPE (e)) == REFERENCE_TYPE)
967 e = convert_from_reference (e);
969 /* Support for converting *to* a reference type is limited;
970 it is only here as a convenience for loc-identity declarations,
971 and loc parameters. */
972 if (code == REFERENCE_TYPE)
973 return convert_to_reference (type, e);
975 /* if expression was untyped because of its context (an if_expr or case_expr
976 in a tuple, perhaps) just apply the type */
977 if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == ERROR_MARK)
979 TREE_TYPE (e) = type;
983 /* Turn a NULL keyword into [0, 0] for an instance */
984 if (CH_IS_INSTANCE_MODE (type) && expr == null_pointer_node)
986 tree field0 = TYPE_FIELDS (type);
987 tree field1 = TREE_CHAIN (field0);
988 e = build (CONSTRUCTOR, type, NULL_TREE,
989 tree_cons (field0, integer_zero_node,
990 tree_cons (field1, integer_zero_node,
992 TREE_CONSTANT (e) = 1;
997 /* Turn a pointer into a function pointer for a procmode */
998 if (TREE_CODE (type) == POINTER_TYPE
999 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE
1000 && expr == null_pointer_node)
1001 return convert1 (type, expr);
1003 /* turn function_decl expression into a pointer to
1005 if (TREE_CODE (expr) == FUNCTION_DECL
1006 && TREE_CODE (type) == POINTER_TYPE
1007 && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
1009 e = build1 (ADDR_EXPR, type, expr);
1010 TREE_CONSTANT (e) = 1;
1014 if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)
1015 e = varying_to_slice (e);
1016 type_varying = chill_varying_type_p (type);
1018 /* Convert a char to a singleton string.
1019 Needed for compatibility with 1984 version of Z.200. */
1020 if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == CHAR_TYPE
1021 && (CH_CHARS_ONE_P (type) || type_varying))
1023 if (TREE_CODE (e) == INTEGER_CST)
1025 char ch = TREE_INT_CST_LOW (e);
1026 e = build_chill_string (1, &ch);
1029 e = build (CONSTRUCTOR, string_one_type_node, NULL_TREE,
1030 tree_cons (NULL_TREE, e, NULL_TREE));
1033 /* Convert a Boolean to a singleton bitstring.
1034 Needed for compatibility with 1984 version of Z.200. */
1035 if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == BOOLEAN_TYPE
1036 && (CH_BOOLS_ONE_P (type) || type_varying))
1038 if (TREE_CODE (e) == INTEGER_CST)
1039 e = integer_zerop (e) ? bit_zero_node : bit_one_node;
1041 e = build (COND_EXPR, bitstring_one_type_node,
1042 e, bit_one_node, bit_zero_node);
1048 tree field0 = TYPE_FIELDS (type);
1049 tree field1 = TREE_CHAIN (field0);
1051 tree target_array_type = TREE_TYPE (field1);
1052 tree needed_padding;
1053 tree padding_max_size = 0;
1054 int orig_e_constant = TREE_CONSTANT (orig_e);
1055 if (TREE_TYPE (e) != NULL_TREE
1056 && TREE_CODE (TREE_TYPE (e)) == ARRAY_TYPE)
1058 /* Note that array_type_nelts returns 1 less than the size. */
1059 nentries = array_type_nelts (TREE_TYPE (e));
1060 needed_padding = fold (build (MINUS_EXPR, integer_type_node,
1061 array_type_nelts (target_array_type),
1063 if (TREE_CODE (needed_padding) != INTEGER_CST)
1065 padding_max_size = size_in_bytes (TREE_TYPE (e));
1066 if (TREE_CODE (padding_max_size) != INTEGER_CST)
1067 padding_max_size = TYPE_ARRAY_MAX_SIZE (TREE_TYPE (e));
1069 nentries = fold (build (PLUS_EXPR, integer_type_node,
1070 nentries, integer_one_node));
1072 else if (TREE_CODE (e) == CONSTRUCTOR)
1074 HOST_WIDE_INT init_cnt = 0;
1075 tree chaser = CONSTRUCTOR_ELTS (e);
1076 for ( ; chaser; chaser = TREE_CHAIN (chaser))
1077 init_cnt++; /* count initializer elements */
1078 nentries = build_int_2 (init_cnt, 0);
1079 needed_padding = integer_zero_node;
1080 if (TREE_TYPE (e) == NULL_TREE)
1081 e = digest_array_tuple (TREE_TYPE (field1), e, 1);
1082 orig_e_constant = TREE_CONSTANT (e);
1086 error ("initializer is not an array or string mode");
1087 return error_mark_node;
1090 FIXME check that nentries will fit in type;
1092 if (!integer_zerop (needed_padding))
1094 tree padding, padding_type, padding_range;
1095 if (TREE_CODE (needed_padding) == INTEGER_CST
1096 && (long)TREE_INT_CST_LOW (needed_padding) < 0)
1098 error ("destination is too small");
1099 return error_mark_node;
1101 padding_range = build_chill_range_type (NULL_TREE, integer_one_node,
1104 = build_simple_array_type (TREE_TYPE (target_array_type),
1105 padding_range, NULL_TREE);
1106 TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size;
1107 if (CH_CHARS_TYPE_P (target_array_type))
1108 MARK_AS_STRING_TYPE (padding_type);
1109 padding = build (UNDEFINED_EXPR, padding_type);
1110 if (TREE_CONSTANT (e))
1111 e = build_chill_binary_op (CONCAT_EXPR, e, padding);
1113 e = build (CONCAT_EXPR, target_array_type, e, padding);
1115 e = convert (TREE_TYPE (field1), e);
1116 /* We build this constructor by hand (rather than going through
1117 digest_structure_tuple), to avoid some type-checking problem.
1118 E.g. type may have non-null novelty, but its field1 will
1119 have non-novelty. */
1120 e = build (CONSTRUCTOR, type, NULL_TREE,
1121 tree_cons (field0, nentries,
1122 build_tree_list (field1, e)));
1123 /* following was wrong, cause orig_e never will be TREE_CONSTANT. e
1124 may become constant after digest_array_tuple. */
1125 if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */
1127 TREE_CONSTANT (e) = 1;
1128 if (TREE_STATIC (nentries) && TREE_STATIC (orig_e))
1129 TREE_STATIC (e) = 1;
1132 if (TREE_TYPE (e) == NULL_TREE)
1134 if (TREE_CODE (e) == CONSTRUCTOR)
1136 if (TREE_CODE (type) == SET_TYPE)
1137 return digest_powerset_tuple (type, e);
1138 if (TREE_CODE (type) == RECORD_TYPE)
1139 return digest_structure_tuple (type, e);
1140 if (TREE_CODE (type) == ARRAY_TYPE)
1141 return digest_array_tuple (type, e, 0);
1142 fatal ("internal error - bad CONSTRUCTOR passed to convert");
1144 else if (TREE_CODE (e) == COND_EXPR)
1145 e = build (COND_EXPR, type,
1146 TREE_OPERAND (e, 0),
1147 convert (type, TREE_OPERAND (e, 1)),
1148 convert (type, TREE_OPERAND (e, 2)));
1149 else if (TREE_CODE (e) == CASE_EXPR)
1150 TREE_TYPE (e) = type;
1153 error ("internal error: unknown type of expression");
1154 return error_mark_node;
1158 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))
1159 || (CH_NOVELTY (type) != NULL_TREE
1160 && CH_NOVELTY (type) == CH_NOVELTY (TREE_TYPE (e))))
1161 return convert1 (type, e);
1163 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1165 error ("void value not ignored as it ought to be");
1166 return error_mark_node;
1168 if (code == VOID_TYPE)
1169 return build1 (CONVERT_EXPR, type, e);
1171 if (code == SET_TYPE)
1172 return convert1 (type, e);
1174 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
1176 if (flag_old_strings)
1178 if (CH_CHARS_ONE_P (TREE_TYPE (e)))
1179 e = convert_to_char (char_type_node, e);
1180 else if (CH_BOOLS_ONE_P (TREE_TYPE (e)))
1181 e = convert_to_boolean (boolean_type_node, e);
1183 return fold (convert_to_integer (type, e));
1185 if (code == POINTER_TYPE)
1186 return fold (convert_to_pointer (type, e));
1187 if (code == REAL_TYPE)
1188 return fold (convert_to_real (type, e));
1189 if (code == BOOLEAN_TYPE)
1190 return fold (convert_to_boolean (type, e));
1191 if (code == CHAR_TYPE)
1192 return fold (convert_to_char (type, e));
1194 if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e)))
1196 /* The mode of the expression is different from that of the type.
1197 Earlier checks should have tested against different lengths.
1198 But even if the lengths are the same, it is possible that one
1199 type is a static type (and hence could be say SImode), while the
1200 other type is dynamic type (and hence is BLKmode).
1201 This causes problems when emitting instructions. */
1202 tree ee = build1 (INDIRECT_REF, type,
1203 build1 (NOP_EXPR, build_pointer_type (type),
1205 build_pointer_type (TREE_TYPE (e)),
1207 TREE_READONLY (ee) = TYPE_READONLY (type);
1212 return convert1 (type, e);
1215 /* Return an expression whose value is EXPR, but whose class is CLASS. */
1218 convert_to_class (class, expr)
1219 struct ch_class class;
1227 case CH_DERIVED_CLASS:
1228 if (TREE_TYPE (expr) != class.mode)
1229 expr = convert (class.mode, expr);
1230 if (!CH_DERIVED_FLAG (expr))
1232 expr = copy_node (expr);
1233 CH_DERIVED_FLAG (expr) = 1;
1236 case CH_VALUE_CLASS:
1237 case CH_REFERENCE_CLASS:
1238 if (TREE_TYPE (expr) != class.mode)
1239 expr = convert (class.mode, expr);
1240 if (CH_DERIVED_FLAG (expr))
1242 expr = copy_node (expr);
1243 CH_DERIVED_FLAG (expr) = 0;