gcc/ch/convert.c

   1 /* Language-level data type conversion for GNU CHILL.
   2    Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000
   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 #if 0
1090       FIXME check that nentries will fit in type;
1091 #endif
1092       if (!integer_zerop (needed_padding))
1093         {
1094           tree padding, padding_type, padding_range;
1095           if (TREE_CODE (needed_padding) == INTEGER_CST
1096               && (long)TREE_INT_CST_LOW (needed_padding) < 0)
1097             {
1098               error ("destination is too small");
1099               return error_mark_node;
1100             }
1101           padding_range = build_chill_range_type (NULL_TREE, integer_one_node,
1102                                                   needed_padding);
1103           padding_type
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);
1112           else
1113             e = build (CONCAT_EXPR, target_array_type, e, padding);
1114         }
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)) */
1126         {
1127           TREE_CONSTANT (e) = 1;
1128           if (TREE_STATIC (nentries) && TREE_STATIC (orig_e))
1129             TREE_STATIC (e) = 1;
1130         }
1131     }
1132   if (TREE_TYPE (e) == NULL_TREE)
1133     {
1134       if (TREE_CODE (e) == CONSTRUCTOR)
1135         {
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");
1143         }
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;
1151       else
1152         {
1153           error ("internal error:  unknown type of expression");
1154           return error_mark_node;
1155         }
1156     }
1157
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);
1162
1163   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1164     {
1165       error ("void value not ignored as it ought to be");
1166       return error_mark_node;
1167     }
1168   if (code == VOID_TYPE)
1169     return build1 (CONVERT_EXPR, type, e);
1170
1171   if (code == SET_TYPE)
1172     return convert1 (type, e);
1173
1174   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
1175     {
1176       if (flag_old_strings)
1177         {
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);
1182         }
1183       return fold (convert_to_integer (type, e));
1184     }
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));
1193
1194   if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e)))
1195     {
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),
1204                                 build1 (ADDR_EXPR,
1205                                         build_pointer_type (TREE_TYPE (e)),
1206                                         e)));
1207       TREE_READONLY (ee) = TYPE_READONLY (type);
1208       return ee;
1209     }
1210
1211   /* The default! */
1212   return convert1 (type, e);
1213 }
1214
1215 /* Return an expression whose value is EXPR, but whose class is CLASS. */
1216
1217 tree
1218 convert_to_class (class, expr)
1219      struct ch_class class;
1220      tree expr;
1221 {
1222   switch (class.kind)
1223     {
1224     case CH_NULL_CLASS:
1225     case CH_ALL_CLASS:
1226       return expr;
1227     case CH_DERIVED_CLASS:
1228       if (TREE_TYPE (expr) != class.mode)
1229         expr = convert (class.mode, expr);
1230       if (!CH_DERIVED_FLAG (expr))
1231         {
1232           expr = copy_node (expr);
1233           CH_DERIVED_FLAG (expr) = 1;
1234         }
1235       return expr;
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))
1241         {
1242           expr = copy_node (expr);
1243           CH_DERIVED_FLAG (expr) = 0;
1244         }
1245       return expr;
1246     }
1247   return expr;
1248 }