OSDN Git Service

* config/alpha/vms.h (INCLUDE_DEFAULTS): Add /gnu/lib/gcc-lib/include.
[pf3gnuchains/gcc-fork.git] / gcc / ch / convert.c
1 /* Language-level data type conversion for GNU CHILL.
2    Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000, 2001
3    Free Software Foundation, Inc.
4
5 This file is part of GNU CC.
6
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)
10 any later version.
11
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.
16
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.  */
21
22
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.  */
27
28 #include "config.h"
29 #include "system.h"
30 #include "tree.h"
31 #include "ch-tree.h"
32 #include "flags.h"
33 #include "convert.h"
34 #include "lex.h"
35 #include "toplev.h"
36 #include "output.h"
37
38 extern tree bit_one_node, bit_zero_node;
39 extern tree string_one_type_node;
40 extern tree bitstring_one_type_node;
41
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));
45 #if 0
46 static tree base_type_size_in_bytes     PARAMS ((tree));
47 #endif
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));
54 \f
55 static tree
56 convert_to_reference (reftype, expr)
57      tree reftype, expr;
58 {
59   while (TREE_CODE (expr) == NOP_EXPR)  /* RETYPE_EXPR */
60     expr = TREE_OPERAND (expr, 0);
61
62   if (! CH_LOCATION_P (expr))
63     error("internal error: trying to make loc-identity with non-location");
64   else
65     {
66       mark_addressable (expr);
67       return fold (build1 (ADDR_EXPR, reftype, expr));
68     }
69
70   return error_mark_node;
71 }
72
73 tree
74 convert_from_reference (expr)
75      tree expr;
76 {
77   tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr);
78   TREE_READONLY (e) = TREE_READONLY (expr);
79   return e;
80 }
81
82 /* Convert EXPR to a boolean type.  */
83
84 static tree
85 convert_to_boolean (type, expr)
86      tree type, expr;
87 {
88   register tree intype = TREE_TYPE (expr);
89   
90   if (integer_zerop (expr))
91     return boolean_false_node;
92   if (integer_onep (expr))
93     return boolean_true_node;
94
95   /* Convert a singleton bitstring to a Boolean.
96      Needed if flag_old_strings. */
97   if (CH_BOOLS_ONE_P (intype))
98     {
99       if (TREE_CODE (expr) == CONSTRUCTOR)
100         {
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;
108         }
109       return build_chill_bitref (expr,
110                                  build_tree_list (NULL_TREE,
111                                                   integer_zero_node));
112     }
113
114   if (INTEGRAL_TYPE_P (intype))
115     return build1 (CONVERT_EXPR, type, expr);
116
117   error ("cannot convert to a boolean mode");
118   return boolean_false_node;
119 }
120
121 /* Convert EXPR to a char type.  */
122
123 static tree
124 convert_to_char (type, expr)
125      tree type, expr;
126 {
127   register tree intype = TREE_TYPE (expr);
128   register enum chill_tree_code form = TREE_CODE (intype);
129   
130   if (form == CHAR_TYPE)
131     return build1 (NOP_EXPR, type, expr);
132
133   /* Convert a singleton string to a char.
134      Needed if flag_old_strings. */
135   if (CH_CHARS_ONE_P (intype))
136     {
137       if (TREE_CODE (expr) == STRING_CST)
138         {
139           expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0);
140           TREE_TYPE (expr) = char_type_node;
141           return expr;
142         }
143       else
144         return build (ARRAY_REF, char_type_node, expr, integer_zero_node);
145
146     }
147
148   /* For now, assume it will always fit */
149   if (form == INTEGER_TYPE)
150     return build1 (CONVERT_EXPR, type, expr);
151
152   error ("cannot convert to a char mode");
153
154   {
155     register tree tem = build_int_2 (0, 0);
156     TREE_TYPE (tem) = type;
157     return tem;
158   }
159 }
160 \f
161 #if 0
162 static tree
163 base_type_size_in_bytes (type)
164      tree type;
165 {
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));
171 }
172 #endif
173
174 /*
175  * build a singleton array type, of TYPE objects.
176  */
177 tree
178 build_array_type_for_scalar (type)
179      tree type;
180 {
181   /* KLUDGE */
182   if (type == char_type_node)
183     return build_string_type (type, integer_one_node);
184
185   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
186     return error_mark_node;
187
188   return build_chill_array_type
189     (type,
190      tree_cons (NULL_TREE,
191                 build_chill_range_type (NULL_TREE,
192                                         integer_zero_node, integer_zero_node),
193                 NULL_TREE),
194      0, NULL_TREE);
195
196 }
197 \f
198 #if 0
199 static tree
200 unreferenced_type_of (type)
201      tree type;
202 {
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);
207   return type;
208 }
209 #endif
210
211
212 /* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY.
213    Return the TREE_LIST node, or NULL_TREE on failure. */
214
215 static tree
216 remove_tree_element (key, listp)
217      tree *listp;
218      tree key;
219 {
220   tree node = *listp;
221   for ( ; node; listp = &TREE_CHAIN (node), node = *listp)
222     {
223       if (TREE_PURPOSE (node) == key)
224         {
225           *listp = TREE_CHAIN (node);
226           TREE_CHAIN (node) = NULL_TREE;
227           return node;
228         }
229     }
230   return NULL_TREE;
231 }
232
233 /* This is quite the same as check_range in actions.c, but with
234    different error message. */
235
236 static tree
237 check_ps_range (value, lo_limit, hi_limit)
238      tree value;
239      tree lo_limit;
240      tree hi_limit;
241 {
242   tree check = test_range (value, lo_limit, hi_limit);
243
244   if (!integer_zerop (check))
245     {
246       if (TREE_CODE (check) == INTEGER_CST)
247         {
248           error ("powerset tuple element out of range");
249           return error_mark_node;
250         }
251       else
252         value = check_expression (value, check,
253                                   ridpointers[(int) RID_RANGEFAIL]);
254     }
255   return value;
256 }
257
258 static tree
259 digest_powerset_tuple (type, inits)
260      tree type;
261      tree inits;
262 {
263   tree list;
264   tree result;
265   tree domain = TYPE_DOMAIN (type);
266   int i = 0;
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++)
271     {
272       tree val = TREE_VALUE (list);
273       if (TREE_CODE (val) == ERROR_MARK)
274         {
275           is_erroneous = 1;
276           continue;
277         }
278       if (!TREE_CONSTANT (val))
279         is_constant = 0;
280       else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
281         is_simple = 0;
282       if (! CH_COMPATIBLE (val, domain))
283         {
284           error ("incompatible member of powerset tuple (at position #%d)", i);
285           is_erroneous = 1;
286           continue;
287         }
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)
292         {
293           is_erroneous = 1;
294           continue;
295         }
296
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);
300
301       val = TREE_PURPOSE (list);
302       if (val == NULL_TREE)
303         continue;
304
305       if (TREE_CODE (val) == ERROR_MARK)
306         {
307           is_erroneous = 1;
308           continue;
309         }
310       if (! CH_COMPATIBLE (val, domain))
311         {
312           error ("incompatible member of powerset tuple (at position #%d)", i);
313           is_erroneous = 1;
314           continue;
315         }
316       val = check_ps_range (val, TYPE_MIN_VALUE (domain),
317                             TYPE_MAX_VALUE (domain));
318       if (TREE_CODE (val) == ERROR_MARK)
319         {
320           is_erroneous = 1;
321           continue;
322         }
323       TREE_PURPOSE (list) = convert (domain, val);
324       if (!TREE_CONSTANT (val))
325         is_constant = 0;
326       else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
327         is_simple = 0;
328     }
329   result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1));
330   if (is_erroneous)
331     return error_mark_node;
332   if (is_constant)
333     TREE_CONSTANT (result) = 1;
334   if (is_constant && is_simple)
335     TREE_STATIC (result) = 1;
336   return result;
337 }
338
339 static tree
340 digest_structure_tuple (type, inits)
341      tree type;
342      tree inits;
343 {
344   tree elements = CONSTRUCTOR_ELTS (inits);
345   tree values = NULL_TREE;
346   int is_constant = 1;
347   int is_simple = 1;
348   int is_erroneous = 0;
349   tree field;
350   int labelled_elements = 0;
351   int unlabelled_elements = 0;
352   for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
353     {
354       if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE)
355         { /* Regular fixed field. */
356           tree value = remove_tree_element (DECL_NAME (field), &elements);
357
358           if (value)
359             labelled_elements++;
360           else if (elements && TREE_PURPOSE (elements) == NULL_TREE)
361             {
362               value = elements;
363               elements = TREE_CHAIN (elements);
364               unlabelled_elements++;
365             }
366
367           if (value)
368             {
369               tree val;
370               char msg[120];
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)
376                   is_erroneous = 1;
377               else
378                 {
379                   TREE_VALUE (value) = val;
380                   TREE_CHAIN (value) = values;
381                   TREE_PURPOSE (value) = field;
382                   values = value;       
383                   if (TREE_CODE (val) == ERROR_MARK)
384                     is_erroneous = 1;
385                   else if (!TREE_CONSTANT (val))
386                     is_constant = 0;
387                   else if (!initializer_constant_valid_p (val,
388                                                           TREE_TYPE (val)))
389                     is_simple = 0;
390                 }
391             }
392           else
393             {
394               pedwarn ("no initializer value for fixed field `%s'",
395                        IDENTIFIER_POINTER (DECL_NAME (field)));
396             }
397         }
398       else
399         {
400           tree variant;
401           tree selected_variant = NULL_TREE;
402           tree variant_values = NULL_TREE;
403
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)))
407             {
408               for (variant = TYPE_FIELDS (TREE_TYPE (field));
409                    variant; variant = TREE_CHAIN (variant))
410                 {
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)
414                     {
415                       selected_variant = variant;
416                       break;
417                     }
418                   for (; tag_labels && tag_fields;
419                        tag_labels = TREE_CHAIN (tag_labels),
420                        tag_fields = TREE_CHAIN (tag_fields))
421                     {
422                       tree tag_value = values;
423                       int found = 0;
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))
427                         {
428                           if (TREE_PURPOSE (tag_value) == tag_decl)
429                             {
430                               tag_value = TREE_VALUE (tag_value);
431                               break;
432                             }
433                         }
434                       if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST)
435                         {
436                           pedwarn ("non-constant value for tag field `%s'",
437                                    IDENTIFIER_POINTER (DECL_NAME (tag_decl)));
438                           goto get_values;
439                         }
440
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))
445                         {
446                           if (tree_int_cst_equal (TREE_VALUE (tag_value_set),
447                                                   tag_value))
448                             {
449                               found = 1;
450                               break;
451                             }
452                         }
453                       if (!found)
454                         break;
455                     }
456                   if (!tag_fields)
457                     {
458                       selected_variant = variant;
459                       break;
460                     }
461                 }
462             }
463         get_values:
464           for (variant = TYPE_FIELDS (TREE_TYPE (field));
465                variant; variant = TREE_CHAIN (variant))
466             {
467               tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant)); 
468               tree vfield;
469               for (vfield = vfield0; vfield;  vfield = TREE_CHAIN (vfield))
470                 {
471                   tree value = remove_tree_element (DECL_NAME (vfield),
472                                                     &elements);
473
474                   if (value)
475                     labelled_elements++;
476                   else if (variant == selected_variant
477                            && elements && TREE_PURPOSE (elements) == NULL_TREE)
478                     {
479                       value = elements;
480                       elements = TREE_CHAIN (elements);
481                       unlabelled_elements++;
482                     }
483
484                   if (value)
485                     {
486                       if (selected_variant && selected_variant != variant)
487                         {
488                           error ("field `%s' in wrong variant",
489                                  IDENTIFIER_POINTER (DECL_NAME (vfield)));
490                           is_erroneous = 1;
491                         }
492                       else
493                         {
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),
499                                              TREE_TYPE (vfield)))
500                             {
501                               tree val = convert (TREE_TYPE (vfield),
502                                                   TREE_VALUE (value));
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)
508                                 is_erroneous = 1;
509                               else if (!TREE_CONSTANT (val))
510                                 is_constant = 0;
511                               else if (!initializer_constant_valid_p
512                                        (val, TREE_TYPE (val)))
513                                 is_simple = 0;
514                             }
515                           else
516                             {
517                               is_erroneous = 1;
518                               error ("bad initializer for field `%s'",
519                                      IDENTIFIER_POINTER (DECL_NAME (vfield)));
520                             }
521                         }
522                     }
523                   else if (variant == selected_variant)
524                     {
525                       pedwarn ("no initializer value for variant field `%s'",
526                                IDENTIFIER_POINTER (DECL_NAME (field)));
527                     }
528                 }
529             }
530           if (selected_variant == NULL_TREE)
531             pedwarn ("no selected variant");
532           else
533             {
534               variant_values = build (CONSTRUCTOR,
535                                       TREE_TYPE (selected_variant),
536                                       NULL_TREE, nreverse (variant_values));
537               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);
541             }
542         }
543     }
544
545   if (labelled_elements && unlabelled_elements)
546     pedwarn ("mixture of labelled and unlabelled tuple elements");
547
548   /* Check for unused initializer elements. */
549   unlabelled_elements = 0;
550   for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements))
551     {
552       if (TREE_PURPOSE (elements) == NULL_TREE)
553         unlabelled_elements++;
554       else
555         {
556           if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0)
557             error ("probably not a structure tuple");
558           else
559             error ("excess initializer for field `%s'",
560                    IDENTIFIER_POINTER (TREE_PURPOSE (elements)));
561           is_erroneous = 1;
562         }
563     }
564   if (unlabelled_elements)
565     {
566       error ("excess unnamed initializers");
567       is_erroneous = 1;
568     }
569
570   CONSTRUCTOR_ELTS (inits) = nreverse (values);
571   TREE_TYPE (inits) = type;
572   if (is_erroneous)
573     return error_mark_node;
574   if (is_constant)
575     TREE_CONSTANT (inits) = 1;
576   if (is_constant && is_simple)
577     TREE_STATIC (inits) = 1;
578   return inits;
579 }
580
581 /* Return a Chill representation of the INTEGER_CST VAL.
582    The result may be in a static buffer, */
583
584 const char *
585 display_int_cst (val)
586      tree val;
587 {
588   static char buffer[50];
589   HOST_WIDE_INT x;
590   tree fields;
591   if (TREE_CODE (val) != INTEGER_CST)
592     return "<not a constant>";
593
594   x = TREE_INT_CST_LOW (val);
595
596   switch (TREE_CODE (TREE_TYPE (val)))
597     {
598     case BOOLEAN_TYPE:
599       if (x == 0)
600         return "FALSE";
601       if (x == 1)
602         return "TRUE";
603       goto int_case;
604     case CHAR_TYPE:
605       if (x == '^')
606         strcpy (buffer, "'^^'");
607       else if (x == '\n')
608         strcpy (buffer, "'^J'");
609       else if (x < ' ' || x > '~')
610         sprintf (buffer, "'^(%u)'", (unsigned int) x);
611       else
612         sprintf (buffer, "'%c'", (char) x);
613       return buffer;
614     case ENUMERAL_TYPE:
615       for (fields = TYPE_VALUES (TREE_TYPE (val)); fields != NULL_TREE;
616            fields = TREE_CHAIN (fields))
617         {
618           if (tree_int_cst_equal (TREE_VALUE (fields), val))
619             return IDENTIFIER_POINTER (TREE_PURPOSE (fields));
620         }
621       goto int_case;
622     case POINTER_TYPE:
623       if (x == 0)
624         return "NULL";
625       goto int_case;
626     int_case:
627     default:
628       /* This code is derived from print-tree.c:print_code_brief. */
629       if (TREE_INT_CST_HIGH (val) == 0)
630         sprintf (buffer,
631 #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
632                  "%1u",
633 #else
634                  "%1lu",
635 #endif
636                  x);
637       else if (TREE_INT_CST_HIGH (val) == -1 && TREE_INT_CST_LOW (val) != 0)
638         sprintf (buffer,
639 #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
640                  "-%1u",
641 #else
642                  "-%1lu",
643 #endif
644                  -x);
645       else
646         sprintf (buffer,
647 #if HOST_BITS_PER_WIDE_INT == 64
648 #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
649                  "H'%lx%016lx",
650 #else
651                  "H'%x%016x",
652 #endif
653 #else
654 #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
655                  "H'%lx%08lx",
656 #else
657                  "H'%x%08x",
658 #endif
659 #endif
660                  TREE_INT_CST_HIGH (val), TREE_INT_CST_LOW (val));
661       return buffer;
662     }
663 }
664
665 static tree
666 digest_array_tuple (type, init, allow_missing_elements)
667      tree type;
668      tree init;
669      int allow_missing_elements;
670 {
671   tree element = CONSTRUCTOR_ELTS (init);
672   int is_constant = 1;
673   int is_simple = 1;
674   tree element_type = TREE_TYPE (type);
675   tree default_value = NULL_TREE;
676   tree element_list = NULL_TREE;
677   tree domain_min;
678   tree domain_max;
679   tree *ptr = &element_list;
680   int errors = 0;
681   int labelled_elements = 0;
682   int unlabelled_elements = 0;
683   tree first, last = NULL_TREE;
684
685   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
686     return error_mark_node;
687
688   domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
689   domain_max = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
690
691   if (domain_min == NULL || TREE_CODE (domain_min) != INTEGER_CST)
692     {
693       error ("non-constant start index for tuple");
694       return error_mark_node;
695     }
696   if (TREE_CODE (domain_max) != INTEGER_CST)
697     is_constant = 0;
698
699   if (TREE_CODE (type) != ARRAY_TYPE)
700     abort ();  
701
702   for ( ; element != NULL_TREE; element = TREE_CHAIN (element))
703     {
704       tree purpose = TREE_PURPOSE (element);
705       tree value   = TREE_VALUE (element);
706
707       if (purpose == NULL_TREE)
708         {
709           if (last == NULL_TREE)
710             first = domain_min;
711           else
712             {
713               HOST_WIDE_INT new_lo, new_hi;
714               add_double (TREE_INT_CST_LOW (last), TREE_INT_CST_HIGH (last),
715                           1, 0,
716                           &new_lo, &new_hi);
717               first = build_int_2 (new_lo, new_hi);
718               TREE_TYPE (first) = TYPE_DOMAIN (type);
719             }
720           last = first;
721           unlabelled_elements++;
722         }
723       else
724         {
725           labelled_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)))
730             {
731               first = TYPE_MIN_VALUE (TREE_TYPE (purpose));
732               last = TYPE_MAX_VALUE (TREE_TYPE (purpose));
733             }
734           else if (TREE_CODE (purpose) != RANGE_EXPR)
735             {
736               error ("invalid array tuple label");
737               errors++;
738               continue;
739             }
740           else if (TREE_OPERAND (purpose, 0) == NULL_TREE)
741             first = last = NULL_TREE;  /* Default value. */
742           else
743             {
744               first = TREE_OPERAND (purpose, 0);
745               last = TREE_OPERAND (purpose, 1);
746             }
747           if ((first != NULL && TREE_CODE (first) != INTEGER_CST)
748               || (last != NULL && TREE_CODE (last) != INTEGER_CST))
749             {
750               error ("non-constant array tuple index range");
751               errors++;
752             }
753         }
754
755       if (! CH_COMPATIBLE (value, element_type))
756         {
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;
761         }
762       else
763         value = convert (element_type, value);
764       if (TREE_CODE (value) == ERROR_MARK)
765         errors++;
766       else if (!TREE_CONSTANT (value))
767         is_constant = 0;
768       else if (!initializer_constant_valid_p (value, TREE_TYPE (value)))
769         is_simple = 0;
770
771       if (first == NULL_TREE)
772         {
773           if (default_value != NULL)
774             {
775               error ("multiple (*) or (ELSE) array tuple labels");
776               errors++;
777             }
778           default_value = value;
779           continue;
780         }
781
782       if (first != last && tree_int_cst_lt (last, first))
783         {
784           error ("empty range in array tuple");
785           errors++;
786           continue;
787         }
788
789       ptr = &element_list;
790
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))
799         {
800           const char *err_val_name = display_int_cst (first);
801           error ("array tuple has duplicate index %s", err_val_name);
802           errors++;
803           continue;
804         }
805       if ((ptr == &element_list && tree_int_cst_lt (domain_max, last))
806         || (*ptr == NULL_TREE && tree_int_cst_lt (first, domain_min)))
807         {
808           if (purpose)
809             error ("array tuple index out of range");
810           else if (errors == 0)
811             error ("too many array tuple values");
812           errors++;
813           continue;
814         }
815       if (! tree_int_cst_lt (first, last))
816         purpose = first;
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);
820     }
821
822   element_list = nreverse (element_list);
823
824   /* For each missing element, set it to the default value,
825      if there is one.  Otherwise, emit an error.  */
826
827   if (errors == 0
828       && (!allow_missing_elements || default_value != NULL_TREE))
829     {
830       /* Iterate over each *gap* between specified elements/ranges. */
831       tree prev_elt;
832       if (element_list &&
833           tree_int_cst_equal (CONSTRUCTOR_ELT_LO (element_list), domain_min))
834         {
835           ptr = &TREE_CHAIN (element_list);
836           prev_elt = element_list;
837         }
838       else
839         {
840           prev_elt = NULL_TREE;
841           ptr = &element_list;
842         }
843       for (;;)
844         {
845           tree first, last;
846           /* Calculate the first element of the gap. */
847           if (prev_elt == NULL_TREE)
848             first = domain_min;
849           else
850             {
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),
856                           1, 0,
857                           &TREE_INT_CST_LOW (first),
858                           &TREE_INT_CST_HIGH (first));
859             }
860           /* Calculate the last element of the gap. */
861           if (*ptr)
862             last = fold (build (MINUS_EXPR, integer_type_node,
863                                 CONSTRUCTOR_ELT_LO (*ptr),
864                                 integer_one_node));
865           else
866             last = domain_max;
867
868           if (TREE_CODE (last) == INTEGER_CST && tree_int_cst_lt (last, first))
869             ; /* Empty "gap" - no missing elements. */
870           else if (default_value)
871             {
872               tree purpose;
873               if (tree_int_cst_equal (first, last))
874                 purpose = first;
875               else
876                 purpose = build_nt (RANGE_EXPR, first, last);
877               *ptr = tree_cons (purpose, default_value, *ptr);
878             }
879           else
880             {
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);
886               else
887                 {
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);
894                   free (first_name);
895                 }
896               errors++;
897             }
898           if (*ptr == NULL_TREE)
899             break;
900           prev_elt = *ptr;
901           ptr = &TREE_CHAIN (*ptr);
902         }
903     }
904   if (errors)
905     return error_mark_node;
906
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");
913   return element;
914 }
915 \f
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.  */
919
920 static tree
921 convert1 (type, expr)
922      tree type, expr;
923 {
924   int was_constant = TREE_CONSTANT (expr);
925   STRIP_NOPS (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;
931   return expr;
932 }
933
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.
939
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. */
945
946 tree
947 convert (type, expr)
948      tree type, expr;
949 {
950   register tree e = expr;
951   register enum chill_tree_code code;
952   int type_varying;
953
954   if (e == NULL_TREE || TREE_CODE (e) == ERROR_MARK)
955     return error_mark_node;
956
957   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
958     return error_mark_node;
959
960   code = TREE_CODE (type);
961
962   if (type == TREE_TYPE (e))
963     return e;
964
965   if (TREE_TYPE (e) != NULL_TREE
966       && TREE_CODE (TREE_TYPE (e)) == REFERENCE_TYPE)
967     e = convert_from_reference (e);
968
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);
974
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)
978     {
979       TREE_TYPE (e) = type;
980       return e;
981     }
982
983   /* Turn a NULL keyword into [0, 0] for an instance */
984   if (CH_IS_INSTANCE_MODE (type) && expr == null_pointer_node)
985     {
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,
991                                        NULL_TREE)));
992       TREE_CONSTANT (e) = 1;
993       TREE_STATIC (e) = 1;
994       return e;
995     }
996
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);
1002
1003   /* turn function_decl expression into a pointer to 
1004      that function */
1005   if (TREE_CODE (expr) == FUNCTION_DECL
1006       && TREE_CODE (type) == POINTER_TYPE
1007       && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
1008     {
1009       e = build1 (ADDR_EXPR, type, expr);
1010       TREE_CONSTANT (e) = 1;
1011       return e;
1012     }
1013
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);
1017
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))
1022     {
1023       if (TREE_CODE (e) == INTEGER_CST)
1024         {
1025           char ch = TREE_INT_CST_LOW (e);
1026           e = build_chill_string (1, &ch);
1027         }
1028       else
1029         e = build (CONSTRUCTOR, string_one_type_node, NULL_TREE,
1030                    tree_cons (NULL_TREE, e, NULL_TREE));
1031     }
1032
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))
1037     {
1038       if (TREE_CODE (e) == INTEGER_CST)
1039         e = integer_zerop (e) ? bit_zero_node : bit_one_node;
1040       else
1041         e = build (COND_EXPR, bitstring_one_type_node,
1042                    e, bit_one_node, bit_zero_node);
1043     }
1044
1045   if (type_varying)
1046     {
1047       tree nentries;
1048       tree field0 = TYPE_FIELDS (type);
1049       tree field1 = TREE_CHAIN (field0);
1050       tree orig_e = e;
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)
1057         {
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),
1062                                         nentries));
1063           if (TREE_CODE (needed_padding) != INTEGER_CST)
1064             {
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));
1068             }
1069           nentries = fold (build (PLUS_EXPR, integer_type_node,
1070                                   nentries, integer_one_node));
1071         }
1072       else if (TREE_CODE (e) == CONSTRUCTOR)
1073         {
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);
1083         }
1084       else
1085         {
1086           error ("initializer is not an array or string mode");
1087           return error_mark_node;
1088         }
1089       /* FIXME check that nentries will fit in type; */
1090       if (!integer_zerop (needed_padding))
1091         {
1092           tree padding, padding_type, padding_range;
1093           if (TREE_CODE (needed_padding) == INTEGER_CST
1094               && (long)TREE_INT_CST_LOW (needed_padding) < 0)
1095             {
1096               error ("destination is too small");
1097               return error_mark_node;
1098             }
1099           padding_range = build_chill_range_type (NULL_TREE, integer_one_node,
1100                                                   needed_padding);
1101           padding_type
1102             = build_simple_array_type (TREE_TYPE (target_array_type),
1103                                        padding_range, NULL_TREE);
1104           TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size;
1105           if (CH_CHARS_TYPE_P (target_array_type))
1106             MARK_AS_STRING_TYPE (padding_type);
1107           padding = build (UNDEFINED_EXPR, padding_type);
1108           if (TREE_CONSTANT (e))
1109             e = build_chill_binary_op (CONCAT_EXPR, e, padding);
1110           else
1111             e = build (CONCAT_EXPR, target_array_type, e, padding);
1112         }
1113       e = convert (TREE_TYPE (field1), e);
1114       /* We build this constructor by hand (rather than going through
1115          digest_structure_tuple), to avoid some type-checking problem.
1116          E.g. type may have non-null novelty, but its field1 will
1117          have non-novelty. */
1118       e = build (CONSTRUCTOR, type, NULL_TREE,
1119                     tree_cons (field0, nentries,
1120                                build_tree_list (field1, e)));
1121       /* following was wrong, cause orig_e never will be TREE_CONSTANT. e
1122          may become constant after digest_array_tuple. */
1123       if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */
1124         {
1125           TREE_CONSTANT (e) = 1;
1126           if (TREE_STATIC (nentries) && TREE_STATIC (orig_e))
1127             TREE_STATIC (e) = 1;
1128         }
1129     }
1130   if (TREE_TYPE (e) == NULL_TREE)
1131     {
1132       if (TREE_CODE (e) == CONSTRUCTOR)
1133         {
1134           if (TREE_CODE (type) == SET_TYPE)
1135             return digest_powerset_tuple (type, e);
1136           else if (TREE_CODE (type) == RECORD_TYPE)
1137             return digest_structure_tuple (type, e);
1138           else if (TREE_CODE (type) == ARRAY_TYPE)
1139             return digest_array_tuple (type, e, 0);
1140           else
1141             abort ();
1142         }
1143       else if (TREE_CODE (e) == COND_EXPR)
1144         e = build (COND_EXPR, type,
1145                    TREE_OPERAND (e, 0),
1146                    convert (type, TREE_OPERAND (e, 1)),
1147                    convert (type, TREE_OPERAND (e, 2)));
1148       else if (TREE_CODE (e) == CASE_EXPR)
1149         TREE_TYPE (e) = type;
1150       else
1151         {
1152           error ("internal error:  unknown type of expression");
1153           return error_mark_node;
1154         }
1155     }
1156
1157   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))
1158       || (CH_NOVELTY (type) != NULL_TREE
1159           && CH_NOVELTY (type) == CH_NOVELTY (TREE_TYPE (e))))
1160     return convert1 (type, e);
1161
1162   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1163     {
1164       error ("void value not ignored as it ought to be");
1165       return error_mark_node;
1166     }
1167   if (code == VOID_TYPE)
1168     return build1 (CONVERT_EXPR, type, e);
1169
1170   if (code == SET_TYPE)
1171     return convert1 (type, e);
1172
1173   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
1174     {
1175       if (flag_old_strings)
1176         {
1177           if (CH_CHARS_ONE_P (TREE_TYPE (e)))
1178             e = convert_to_char (char_type_node, e);
1179           else if (CH_BOOLS_ONE_P (TREE_TYPE (e)))
1180             e = convert_to_boolean (boolean_type_node, e);
1181         }
1182       return fold (convert_to_integer (type, e));
1183     }
1184   if (code == POINTER_TYPE)
1185     return fold (convert_to_pointer (type, e));
1186   if (code == REAL_TYPE)
1187     return fold (convert_to_real (type, e));
1188   if (code == BOOLEAN_TYPE)
1189     return fold (convert_to_boolean (type, e));
1190   if (code == CHAR_TYPE)
1191     return fold (convert_to_char (type, e));
1192
1193   if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e)))
1194     {
1195       /* The mode of the expression is different from that of the type.
1196          Earlier checks should have tested against different lengths.
1197          But even if the lengths are the same, it is possible that one
1198          type is a static type (and hence could be say SImode), while the
1199          other type is dynamic type (and hence is BLKmode).
1200          This causes problems when emitting instructions.  */
1201       tree ee = build1 (INDIRECT_REF, type,
1202                         build1 (NOP_EXPR, build_pointer_type (type),
1203                                 build1 (ADDR_EXPR,
1204                                         build_pointer_type (TREE_TYPE (e)),
1205                                         e)));
1206       TREE_READONLY (ee) = TYPE_READONLY (type);
1207       return ee;
1208     }
1209
1210   /* The default! */
1211   return convert1 (type, e);
1212 }
1213
1214 /* Return an expression whose value is EXPR, but whose class is CLASS. */
1215
1216 tree
1217 convert_to_class (class, expr)
1218      struct ch_class class;
1219      tree expr;
1220 {
1221   switch (class.kind)
1222     {
1223     case CH_NULL_CLASS:
1224     case CH_ALL_CLASS:
1225       return expr;
1226     case CH_DERIVED_CLASS:
1227       if (TREE_TYPE (expr) != class.mode)
1228         expr = convert (class.mode, expr);
1229       if (!CH_DERIVED_FLAG (expr))
1230         {
1231           expr = copy_node (expr);
1232           CH_DERIVED_FLAG (expr) = 1;
1233         }
1234       return expr;
1235     case CH_VALUE_CLASS:
1236     case CH_REFERENCE_CLASS:
1237       if (TREE_TYPE (expr) != class.mode)
1238         expr = convert (class.mode, expr);
1239       if (CH_DERIVED_FLAG (expr))
1240         {
1241           expr = copy_node (expr);
1242           CH_DERIVED_FLAG (expr) = 0;
1243         }
1244       return expr;
1245     }
1246   return expr;
1247 }