gcc/ch/convert.c

   1 /* Language-level data type conversion for GNU CHILL.
   2    Copyright (C) 1992, 93, 1994, 1998 Free Software Foundation, Inc.
   3
   4 This file is part of GNU CC.
   5
   6 GNU CC is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU CC is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU CC; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21
  22 /* This file contains the functions for converting CHILL expressions
  23    to different data types.  The only entry point is `convert'.
  24    Every language front end must have a `convert' function
  25    but what kind of conversions it does will depend on the language.  */
  26
  27 #include "config.h"
  28 #include "system.h"
  29 #include "tree.h"
  30 #include "ch-tree.h"
  31 #include "flags.h"
  32 #include "convert.h"
  33 #include "lex.h"
  34 #include "toplev.h"
  35
  36 extern tree bit_one_node, bit_zero_node;
  37 extern tree string_one_type_node;
  38 extern tree bitstring_one_type_node;
  39
  40 static tree convert_to_reference        PROTO ((tree, tree));
  41 static tree convert_to_boolean          PROTO ((tree, tree));
  42 static tree convert_to_char             PROTO ((tree, tree));
  43 #if 0
  44 static tree base_type_size_in_bytes     PROTO ((tree));
  45 #endif
  46 static tree remove_tree_element         PROTO ((tree, tree *));
  47 static tree check_ps_range              PROTO ((tree, tree, tree));
  48 static tree digest_powerset_tuple       PROTO ((tree, tree));
  49 static tree digest_structure_tuple      PROTO ((tree, tree));
  50 static tree digest_array_tuple          PROTO ((tree, tree, int));
  51 static tree convert1                    PROTO ((tree, tree));
  52 \f
  53 static tree
  54 convert_to_reference (reftype, expr)
  55      tree reftype, expr;
  56 {
  57   while (TREE_CODE (expr) == NOP_EXPR)  /* RETYPE_EXPR */
  58     expr = TREE_OPERAND (expr, 0);
  59
  60   if (! CH_LOCATION_P (expr))
  61     error("internal error: trying to make loc-identity with non-location");
  62   else
  63     {
  64       mark_addressable (expr);
  65       return fold (build1 (ADDR_EXPR, reftype, expr));
  66     }
  67
  68   return error_mark_node;
  69 }
  70
  71 tree
  72 convert_from_reference (expr)
  73      tree expr;
  74 {
  75   tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr);
  76   TREE_READONLY (e) = TREE_READONLY (expr);
  77   return e;
  78 }
  79
  80 /* Convert EXPR to a boolean type.  */
  81
  82 static tree
  83 convert_to_boolean (type, expr)
  84      tree type, expr;
  85 {
  86   register tree intype = TREE_TYPE (expr);
  87
  88   if (integer_zerop (expr))
  89     return boolean_false_node;
  90   if (integer_onep (expr))
  91     return boolean_true_node;
  92
  93   /* Convert a singleton bitstring to a Boolean.
  94      Needed if flag_old_strings. */
  95   if (CH_BOOLS_ONE_P (intype))
  96     {
  97       if (TREE_CODE (expr) == CONSTRUCTOR)
  98         {
  99           tree valuelist = TREE_OPERAND (expr, 1);
 100           if (valuelist == NULL_TREE)
 101             return boolean_false_node;
 102           if (TREE_CHAIN (valuelist) == NULL_TREE
 103               && TREE_PURPOSE (valuelist) == NULL_TREE
 104               && integer_zerop (TREE_VALUE (valuelist)))
 105             return boolean_true_node;
 106         }
 107       return build_chill_bitref (expr,
 108                                  build_tree_list (NULL_TREE,
 109                                                   integer_zero_node));
 110     }
 111
 112   if (INTEGRAL_TYPE_P (intype))
 113     return build1 (CONVERT_EXPR, type, expr);
 114
 115   error ("cannot convert to a boolean mode");
 116   return boolean_false_node;
 117 }
 118
 119 /* Convert EXPR to a char type.  */
 120
 121 static tree
 122 convert_to_char (type, expr)
 123      tree type, expr;
 124 {
 125   register tree intype = TREE_TYPE (expr);
 126   register enum chill_tree_code form = TREE_CODE (intype);
 127
 128   if (form == CHAR_TYPE)
 129     return build1 (NOP_EXPR, type, expr);
 130
 131   /* Convert a singleton string to a char.
 132      Needed if flag_old_strings. */
 133   if (CH_CHARS_ONE_P (intype))
 134     {
 135       if (TREE_CODE (expr) == STRING_CST)
 136         {
 137           expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0);
 138           TREE_TYPE (expr) = char_type_node;
 139           return expr;
 140         }
 141       else
 142         return build (ARRAY_REF, char_type_node, expr, integer_zero_node);
 143
 144     }
 145
 146   /* For now, assume it will always fit */
 147   if (form == INTEGER_TYPE)
 148     return build1 (CONVERT_EXPR, type, expr);
 149
 150   error ("cannot convert to a char mode");
 151
 152   {
 153     register tree tem = build_int_2 (0, 0);
 154     TREE_TYPE (tem) = type;
 155     return tem;
 156   }
 157 }
 158 \f
 159 #if 0
 160 static tree
 161 base_type_size_in_bytes (type)
 162      tree type;
 163 {
 164   if (type == NULL_TREE
 165       || TREE_CODE (type) == ERROR_MARK
 166       || TREE_CODE (type) != ARRAY_TYPE)
 167     return error_mark_node;
 168   return size_in_bytes (TREE_TYPE (type));
 169 }
 170 #endif
 171
 172 /*
 173  * build a singleton array type, of TYPE objects.
 174  */
 175 tree
 176 build_array_type_for_scalar (type)
 177      tree type;
 178 {
 179   /* KLUDGE */
 180   if (type == char_type_node)
 181     return build_string_type (type, integer_one_node);
 182
 183   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
 184     return error_mark_node;
 185
 186   return build_chill_array_type
 187     (type,
 188      tree_cons (NULL_TREE,
 189                 build_chill_range_type (NULL_TREE,
 190                                         integer_zero_node, integer_zero_node),
 191                 NULL_TREE),
 192      0, NULL_TREE);
 193
 194 }
 195 \f
 196 #if 0
 197 static tree
 198 unreferenced_type_of (type)
 199      tree type;
 200 {
 201   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
 202     return error_mark_node;
 203   while (TREE_CODE (type) == REFERENCE_TYPE)
 204     type = TREE_TYPE (type);
 205   return type;
 206 }
 207 #endif
 208
 209
 210 /* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY.
 211    Return the TREE_LIST node, or NULL_TREE on failure. */
 212
 213 static tree
 214 remove_tree_element (key, listp)
 215      tree *listp;
 216      tree key;
 217 {
 218   tree node = *listp;
 219   for ( ; node; listp = &TREE_CHAIN (node), node = *listp)
 220     {
 221       if (TREE_PURPOSE (node) == key)
 222         {
 223           *listp = TREE_CHAIN (node);
 224           TREE_CHAIN (node) = NULL_TREE;
 225           return node;
 226         }
 227     }
 228   return NULL_TREE;
 229 }
 230
 231 /* This is quite the same as check_range in actions.c, but with
 232    different error message. */
 233
 234 static tree
 235 check_ps_range (value, lo_limit, hi_limit)
 236      tree value;
 237      tree lo_limit;
 238      tree hi_limit;
 239 {
 240   tree check = test_range (value, lo_limit, hi_limit);
 241
 242   if (!integer_zerop (check))
 243     {
 244       if (TREE_CODE (check) == INTEGER_CST)
 245         {
 246           error ("powerset tuple element out of range");
 247           return error_mark_node;
 248         }
 249       else
 250         value = check_expression (value, check,
 251                                   ridpointers[(int) RID_RANGEFAIL]);
 252     }
 253   return value;
 254 }
 255
 256 static tree
 257 digest_powerset_tuple (type, inits)
 258      tree type;
 259      tree inits;
 260 {
 261   tree list;
 262   tree result;
 263   tree domain = TYPE_DOMAIN (type);
 264   int i = 0;
 265   int is_erroneous = 0, is_constant = 1, is_simple = 1;
 266   if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK)
 267     return error_mark_node;
 268   for (list = TREE_OPERAND (inits, 1);  list; list = TREE_CHAIN (list), i++)
 269     {
 270       tree val = TREE_VALUE (list);
 271       if (TREE_CODE (val) == ERROR_MARK)
 272         {
 273           is_erroneous = 1;
 274           continue;
 275         }
 276       if (!TREE_CONSTANT (val))
 277         is_constant = 0;
 278       else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
 279         is_simple = 0;
 280       if (! CH_COMPATIBLE (val, domain))
 281         {
 282           error ("incompatible member of powerset tuple (at position #%d)", i);
 283           is_erroneous = 1;
 284           continue;
 285         }
 286       /* check range of value */
 287       val = check_ps_range (val, TYPE_MIN_VALUE (domain),
 288                             TYPE_MAX_VALUE (domain));
 289       if (TREE_CODE (val) == ERROR_MARK)
 290         {
 291           is_erroneous = 1;
 292           continue;
 293         }
 294
 295       /* Updating the list in place is in principle questionable,
 296          but I can't think how it could hurt. */
 297       TREE_VALUE (list) = convert (domain, val);
 298
 299       val = TREE_PURPOSE (list);
 300       if (val == NULL_TREE)
 301         continue;
 302
 303       if (TREE_CODE (val) == ERROR_MARK)
 304         {
 305           is_erroneous = 1;
 306           continue;
 307         }
 308       if (! CH_COMPATIBLE (val, domain))
 309         {
 310           error ("incompatible member of powerset tuple (at position #%d)", i);
 311           is_erroneous = 1;
 312           continue;
 313         }
 314       val = check_ps_range (val, TYPE_MIN_VALUE (domain),
 315                             TYPE_MAX_VALUE (domain));
 316       if (TREE_CODE (val) == ERROR_MARK)
 317         {
 318           is_erroneous = 1;
 319           continue;
 320         }
 321       TREE_PURPOSE (list) = convert (domain, val);
 322       if (!TREE_CONSTANT (val))
 323         is_constant = 0;
 324       else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
 325         is_simple = 0;
 326     }
 327   result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1));
 328   if (is_erroneous)
 329     return error_mark_node;
 330   if (is_constant)
 331     TREE_CONSTANT (result) = 1;
 332   if (is_constant && is_simple)
 333     TREE_STATIC (result) = 1;
 334   return result;
 335 }
 336
 337 static tree
 338 digest_structure_tuple (type, inits)
 339      tree type;
 340      tree inits;
 341 {
 342   tree elements = CONSTRUCTOR_ELTS (inits);
 343   tree values = NULL_TREE;
 344   int is_constant = 1;
 345   int is_simple = 1;
 346   int is_erroneous = 0;
 347   tree field;
 348   int labelled_elements = 0;
 349   int unlabelled_elements = 0;
 350   for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
 351     {
 352       if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE)
 353         { /* Regular fixed field. */
 354           tree value = remove_tree_element (DECL_NAME (field), &elements);
 355
 356           if (value)
 357             labelled_elements++;
 358           else if (elements && TREE_PURPOSE (elements) == NULL_TREE)
 359             {
 360               value = elements;
 361               elements = TREE_CHAIN (elements);
 362               unlabelled_elements++;
 363             }
 364
 365           if (value)
 366             {
 367               tree val;
 368               char msg[120];
 369               sprintf (msg, "initializer for field `%.80s'",
 370                        IDENTIFIER_POINTER (DECL_NAME (field)));
 371               val = chill_convert_for_assignment (TREE_TYPE (field),
 372                                                   TREE_VALUE (value), msg);
 373               if (TREE_CODE (val) == ERROR_MARK)
 374                   is_erroneous = 1;
 375               else
 376                 {
 377                   TREE_VALUE (value) = val;
 378                   TREE_CHAIN (value) = values;
 379                   TREE_PURPOSE (value) = field;
 380                   values = value;
 381                   if (TREE_CODE (val) == ERROR_MARK)
 382                     is_erroneous = 1;
 383                   else if (!TREE_CONSTANT (val))
 384                     is_constant = 0;
 385                   else if (!initializer_constant_valid_p (val,
 386                                                           TREE_TYPE (val)))
 387                     is_simple = 0;
 388                 }
 389             }
 390           else
 391             {
 392               pedwarn ("no initializer value for fixed field `%s'",
 393                        IDENTIFIER_POINTER (DECL_NAME (field)));
 394             }
 395         }
 396       else
 397         {
 398           tree variant;
 399           tree selected_variant = NULL_TREE;
 400           tree variant_values = NULL_TREE;
 401
 402           /* In a tagged variant structure mode, try to figure out
 403              (from the fixed fields), which is the selected variant. */
 404           if (TYPE_TAGFIELDS (TREE_TYPE (field)))
 405             {
 406               for (variant = TYPE_FIELDS (TREE_TYPE (field));
 407                    variant; variant = TREE_CHAIN (variant))
 408                 {
 409                   tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant));
 410                   tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field));
 411                   if (DECL_NAME (variant) == ELSE_VARIANT_NAME)
 412                     {
 413                       selected_variant = variant;
 414                       break;
 415                     }
 416                   for (; tag_labels && tag_fields;
 417                        tag_labels = TREE_CHAIN (tag_labels),
 418                        tag_fields = TREE_CHAIN (tag_fields))
 419                     {
 420                       tree tag_value = values;
 421                       int found = 0;
 422                       tree tag_decl = TREE_VALUE (tag_fields);
 423                       tree tag_value_set = TREE_VALUE (tag_labels);
 424                       for ( ; tag_value; tag_value = TREE_CHAIN (tag_value))
 425                         {
 426                           if (TREE_PURPOSE (tag_value) == tag_decl)
 427                             {
 428                               tag_value = TREE_VALUE (tag_value);
 429                               break;
 430                             }
 431                         }
 432                       if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST)
 433                         {
 434                           pedwarn ("non-constant value for tag field `%s'",
 435                                    IDENTIFIER_POINTER (DECL_NAME (tag_decl)));
 436                           goto get_values;
 437                         }
 438
 439                       /* Check if the value of the tag (as given in a
 440                          previous field) matches the case label list. */
 441                       for (; tag_value_set;
 442                            tag_value_set = TREE_CHAIN (tag_value_set))
 443                         {
 444                           if (tree_int_cst_equal (TREE_VALUE (tag_value_set),
 445                                                   tag_value))
 446                             {
 447                               found = 1;
 448                               break;
 449                             }
 450                         }
 451                       if (!found)
 452                         break;
 453                     }
 454                   if (!tag_fields)
 455                     {
 456                       selected_variant = variant;
 457                       break;
 458                     }
 459                 }
 460             }
 461         get_values:
 462           for (variant = TYPE_FIELDS (TREE_TYPE (field));
 463                variant; variant = TREE_CHAIN (variant))
 464             {
 465               tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant));
 466               tree vfield;
 467               for (vfield = vfield0; vfield;  vfield = TREE_CHAIN (vfield))
 468                 {
 469                   tree value = remove_tree_element (DECL_NAME (vfield),
 470                                                     &elements);
 471
 472                   if (value)
 473                     labelled_elements++;
 474                   else if (variant == selected_variant
 475                            && elements && TREE_PURPOSE (elements) == NULL_TREE)
 476                     {
 477                       value = elements;
 478                       elements = TREE_CHAIN (elements);
 479                       unlabelled_elements++;
 480                     }
 481
 482                   if (value)
 483                     {
 484                       if (selected_variant && selected_variant != variant)
 485                         {
 486                           error ("field `%s' in wrong variant",
 487                                  IDENTIFIER_POINTER (DECL_NAME (vfield)));
 488                           is_erroneous = 1;
 489                         }
 490                       else
 491                         {
 492                           if (!selected_variant && vfield != vfield0)
 493                             pedwarn ("missing variant fields (at least `%s')",
 494                                      IDENTIFIER_POINTER (DECL_NAME (vfield0)));
 495                           selected_variant = variant;
 496                           if (CH_COMPATIBLE (TREE_VALUE (value),
 497                                              TREE_TYPE (vfield)))
 498                             {
 499                               tree val = convert (TREE_TYPE (vfield),
 500                                                   TREE_VALUE (value));
 501                               TREE_PURPOSE (value) = vfield;
 502                               TREE_VALUE (value) = val;
 503                               TREE_CHAIN (value) = variant_values;
 504                               variant_values = value;
 505                               if (TREE_CODE (val) == ERROR_MARK)
 506                                 is_erroneous = 1;
 507                               else if (!TREE_CONSTANT (val))
 508                                 is_constant = 0;
 509                               else if (!initializer_constant_valid_p
 510                                        (val, TREE_TYPE (val)))
 511                                 is_simple = 0;
 512                             }
 513                           else
 514                             {
 515                               is_erroneous = 1;
 516                               error ("bad initializer for field `%s'",
 517                                      IDENTIFIER_POINTER (DECL_NAME (vfield)));
 518                             }
 519                         }
 520                     }
 521                   else if (variant == selected_variant)
 522                     {
 523                       pedwarn ("no initializer value for variant field `%s'",
 524                                IDENTIFIER_POINTER (DECL_NAME (field)));
 525                     }
 526                 }
 527             }
 528           if (selected_variant == NULL_TREE)
 529             pedwarn ("no selected variant");
 530           else
 531             {
 532               variant_values = build (CONSTRUCTOR,
 533                                       TREE_TYPE (selected_variant),
 534                                       NULL_TREE, nreverse (variant_values));
 535               variant_values
 536                 = build (CONSTRUCTOR, TREE_TYPE (field), NULL_TREE,
 537                          build_tree_list (selected_variant, variant_values));
 538               values = tree_cons (field, variant_values, values);
 539             }
 540         }
 541     }
 542
 543   if (labelled_elements && unlabelled_elements)
 544     pedwarn ("mixture of labelled and unlabelled tuple elements");
 545
 546   /* Check for unused initializer elements. */
 547   unlabelled_elements = 0;
 548   for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements))
 549     {
 550       if (TREE_PURPOSE (elements) == NULL_TREE)
 551         unlabelled_elements++;
 552       else
 553         {
 554           if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0)
 555             error ("probably not a structure tuple");
 556           else
 557             error ("excess initializer for field `%s'",
 558                    IDENTIFIER_POINTER (TREE_PURPOSE (elements)));
 559           is_erroneous = 1;
 560         }
 561     }
 562   if (unlabelled_elements)
 563     {
 564       error ("excess unnamed initializers");
 565       is_erroneous = 1;
 566     }
 567
 568   CONSTRUCTOR_ELTS (inits) = nreverse (values);
 569   TREE_TYPE (inits) = type;
 570   if (is_erroneous)
 571     return error_mark_node;
 572   if (is_constant)
 573     TREE_CONSTANT (inits) = 1;
 574   if (is_constant && is_simple)
 575     TREE_STATIC (inits) = 1;
 576   return inits;
 577 }
 578
 579 /* Return a Chill representation of the INTEGER_CST VAL.
 580    The result may be in a static buffer, */
 581
 582 const char *
 583 display_int_cst (val)
 584      tree val;
 585 {
 586   static char buffer[50];
 587   HOST_WIDE_INT x;
 588   tree fields;
 589   if (TREE_CODE (val) != INTEGER_CST)
 590     return "<not a constant>";
 591
 592   x = TREE_INT_CST_LOW (val);
 593
 594   switch (TREE_CODE (TREE_TYPE (val)))
 595     {
 596     case BOOLEAN_TYPE:
 597       if (x == 0)
 598         return "FALSE";
 599       if (x == 1)
 600         return "TRUE";
 601       goto int_case;
 602     case CHAR_TYPE:
 603       if (x == '^')
 604         strcpy (buffer, "'^^'");
 605       else if (x == '\n')
 606         strcpy (buffer, "'^J'");
 607       else if (x < ' ' || x > '~')
 608         sprintf (buffer, "'^(%u)'", (unsigned int) x);
 609       else
 610         sprintf (buffer, "'%c'", (char) x);
 611       return buffer;
 612     case ENUMERAL_TYPE:
 613       for (fields = TYPE_VALUES (TREE_TYPE (val)); fields != NULL_TREE;
 614            fields = TREE_CHAIN (fields))
 615         {
 616           if (tree_int_cst_equal (TREE_VALUE (fields), val))
 617             return IDENTIFIER_POINTER (TREE_PURPOSE (fields));
 618         }
 619       goto int_case;
 620     case POINTER_TYPE:
 621       if (x == 0)
 622         return "NULL";
 623       goto int_case;
 624     int_case:
 625     default:
 626       /* This code is derived from print-tree.c:print_code_brief. */
 627       if (TREE_INT_CST_HIGH (val) == 0)
 628         sprintf (buffer,
 629 #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
 630                  "%1u",
 631 #else
 632                  "%1lu",
 633 #endif
 634                  x);
 635       else if (TREE_INT_CST_HIGH (val) == -1 && TREE_INT_CST_LOW (val) != 0)
 636         sprintf (buffer,
 637 #if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
 638                  "-%1u",
 639 #else
 640                  "-%1lu",
 641 #endif
 642                  -x);
 643       else
 644         sprintf (buffer,
 645 #if HOST_BITS_PER_WIDE_INT == 64
 646 #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
 647                  "H'%lx%016lx",
 648 #else
 649                  "H'%x%016x",
 650 #endif
 651 #else
 652 #if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
 653                  "H'%lx%08lx",
 654 #else
 655                  "H'%x%08x",
 656 #endif
 657 #endif
 658                  TREE_INT_CST_HIGH (val), TREE_INT_CST_LOW (val));
 659       return buffer;
 660     }
 661 }
 662
 663 static tree
 664 digest_array_tuple (type, init, allow_missing_elements)
 665      tree type;
 666      tree init;
 667      int allow_missing_elements;
 668 {
 669   tree element = CONSTRUCTOR_ELTS (init);
 670   int is_constant = 1;
 671   int is_simple = 1;
 672   tree element_type = TREE_TYPE (type);
 673   tree default_value = NULL_TREE;
 674   tree element_list = NULL_TREE;
 675   tree domain_min;
 676   tree domain_max;
 677   tree *ptr = &element_list;
 678   int errors = 0;
 679   int labelled_elements = 0;
 680   int unlabelled_elements = 0;
 681   tree first, last = NULL_TREE;
 682
 683   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
 684     return error_mark_node;
 685
 686   domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
 687   domain_max = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
 688
 689   if (domain_min == NULL || TREE_CODE (domain_min) != INTEGER_CST)
 690     {
 691       error ("non-constant start index for tuple");
 692       return error_mark_node;
 693     }
 694   if (TREE_CODE (domain_max) != INTEGER_CST)
 695     is_constant = 0;
 696
 697   if (TREE_CODE (type) != ARRAY_TYPE)
 698     abort ();
 699
 700   for ( ; element != NULL_TREE; element = TREE_CHAIN (element))
 701     {
 702       tree purpose = TREE_PURPOSE (element);
 703       tree value   = TREE_VALUE (element);
 704
 705       if (purpose == NULL_TREE)
 706         {
 707           if (last == NULL_TREE)
 708             first = domain_min;
 709           else
 710             {
 711               HOST_WIDE_INT new_lo, new_hi;
 712               add_double (TREE_INT_CST_LOW (last), TREE_INT_CST_HIGH (last),
 713                           1, 0,
 714                           &new_lo, &new_hi);
 715               first = build_int_2 (new_lo, new_hi);
 716               TREE_TYPE (first) = TYPE_DOMAIN (type);
 717             }
 718           last = first;
 719           unlabelled_elements++;
 720         }
 721       else
 722         {
 723           labelled_elements++;
 724           if (TREE_CODE (purpose) == INTEGER_CST)
 725             first = last = purpose;
 726           else if (TREE_CODE (purpose) == TYPE_DECL
 727                    && discrete_type_p (TREE_TYPE (purpose)))
 728             {
 729               first = TYPE_MIN_VALUE (TREE_TYPE (purpose));
 730               last = TYPE_MAX_VALUE (TREE_TYPE (purpose));
 731             }
 732           else if (TREE_CODE (purpose) != RANGE_EXPR)
 733             {
 734               error ("invalid array tuple label");
 735               errors++;
 736               continue;
 737             }
 738           else if (TREE_OPERAND (purpose, 0) == NULL_TREE)
 739             first = last = NULL_TREE;  /* Default value. */
 740           else
 741             {
 742               first = TREE_OPERAND (purpose, 0);
 743               last = TREE_OPERAND (purpose, 1);
 744             }
 745           if ((first != NULL && TREE_CODE (first) != INTEGER_CST)
 746               || (last != NULL && TREE_CODE (last) != INTEGER_CST))
 747             {
 748               error ("non-constant array tuple index range");
 749               errors++;
 750             }
 751         }
 752
 753       if (! CH_COMPATIBLE (value, element_type))
 754         {
 755           const char *err_val_name =
 756             first ? display_int_cst (first) : "(default)";
 757           error ("incompatible array tuple element %s", err_val_name);
 758           value = error_mark_node;
 759         }
 760       else
 761         value = convert (element_type, value);
 762       if (TREE_CODE (value) == ERROR_MARK)
 763         errors++;
 764       else if (!TREE_CONSTANT (value))
 765         is_constant = 0;
 766       else if (!initializer_constant_valid_p (value, TREE_TYPE (value)))
 767         is_simple = 0;
 768
 769       if (first == NULL_TREE)
 770         {
 771           if (default_value != NULL)
 772             {
 773               error ("multiple (*) or (ELSE) array tuple labels");
 774               errors++;
 775             }
 776           default_value = value;
 777           continue;
 778         }
 779
 780       if (first != last && tree_int_cst_lt (last, first))
 781         {
 782           error ("empty range in array tuple");
 783           errors++;
 784           continue;
 785         }
 786
 787       ptr = &element_list;
 788
 789 #define MAYBE_RANGE_OP(PURPOSE, OPNO) \
 790   (TREE_CODE (PURPOSE) == RANGE_EXPR ? TREE_OPERAND (PURPOSE, OPNO): PURPOSE)
 791 #define CONSTRUCTOR_ELT_LO(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 0)
 792 #define CONSTRUCTOR_ELT_HI(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 1)
 793       while (*ptr && tree_int_cst_lt (last,
 794                                       CONSTRUCTOR_ELT_LO (*ptr)))
 795         ptr = &TREE_CHAIN (*ptr);
 796       if (*ptr && ! tree_int_cst_lt (CONSTRUCTOR_ELT_HI (*ptr), first))
 797         {
 798           const char *err_val_name = display_int_cst (first);
 799           error ("array tuple has duplicate index %s", err_val_name);
 800           errors++;
 801           continue;
 802         }
 803       if ((ptr == &element_list && tree_int_cst_lt (domain_max, last))
 804         || (*ptr == NULL_TREE && tree_int_cst_lt (first, domain_min)))
 805         {
 806           if (purpose)
 807             error ("array tuple index out of range");
 808           else if (errors == 0)
 809             error ("too many array tuple values");
 810           errors++;
 811           continue;
 812         }
 813       if (! tree_int_cst_lt (first, last))
 814         purpose = first;
 815       else if (purpose == NULL_TREE || TREE_CODE (purpose) != RANGE_EXPR)
 816         purpose = build_nt (RANGE_EXPR, first, last);
 817       *ptr = tree_cons (purpose, value, *ptr);
 818     }
 819
 820   element_list = nreverse (element_list);
 821
 822   /* For each missing element, set it to the default value,
 823      if there is one.  Otherwise, emit an error.  */
 824
 825   if (errors == 0
 826       && (!allow_missing_elements || default_value != NULL_TREE))
 827     {
 828       /* Iterate over each *gap* between specified elements/ranges. */
 829       tree prev_elt;
 830       if (element_list &&
 831           tree_int_cst_equal (CONSTRUCTOR_ELT_LO (element_list), domain_min))
 832         {
 833           ptr = &TREE_CHAIN (element_list);
 834           prev_elt = element_list;
 835         }
 836       else
 837         {
 838           prev_elt = NULL_TREE;
 839           ptr = &element_list;
 840         }
 841       for (;;)
 842         {
 843           tree first, last;
 844           /* Calculate the first element of the gap. */
 845           if (prev_elt == NULL_TREE)
 846             first = domain_min;
 847           else
 848             {
 849               first = CONSTRUCTOR_ELT_HI (prev_elt);
 850               if (tree_int_cst_equal (first, domain_max))
 851                 break; /* We're done.  Avoid overflow below. */
 852               first = copy_node (first);
 853               add_double (TREE_INT_CST_LOW (first), TREE_INT_CST_HIGH (first),
 854                           1, 0,
 855                           &TREE_INT_CST_LOW (first),
 856                           &TREE_INT_CST_HIGH (first));
 857             }
 858           /* Calculate the last element of the gap. */
 859           if (*ptr)
 860             {
 861               /* Actually end up with correct type. */
 862               last = size_binop (MINUS_EXPR,
 863                                  CONSTRUCTOR_ELT_LO (*ptr),
 864                                  integer_one_node);
 865             }
 866           else
 867             last = domain_max;
 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 = size_binop (MINUS_EXPR,
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 = size_binop (PLUS_EXPR, nentries, integer_one_node);
1070         }
1071       else if (TREE_CODE (e) == CONSTRUCTOR)
1072         {
1073           HOST_WIDE_INT init_cnt = 0;
1074           tree chaser = CONSTRUCTOR_ELTS (e);
1075           for ( ; chaser; chaser = TREE_CHAIN (chaser))
1076             init_cnt++;               /* count initializer elements */
1077           nentries = build_int_2 (init_cnt, 0);
1078           needed_padding = integer_zero_node;
1079           if (TREE_TYPE (e) == NULL_TREE)
1080             e = digest_array_tuple (TREE_TYPE (field1), e, 1);
1081           orig_e_constant = TREE_CONSTANT (e);
1082         }
1083       else
1084         {
1085           error ("initializer is not an array or string mode");
1086           return error_mark_node;
1087         }
1088 #if 0
1089       FIXME check that nentries will fit in type;
1090 #endif
1091       if (!integer_zerop (needed_padding))
1092         {
1093           tree padding, padding_type, padding_range;
1094           if (TREE_CODE (needed_padding) == INTEGER_CST
1095               && (long)TREE_INT_CST_LOW (needed_padding) < 0)
1096             {
1097               error ("destination is too small");
1098               return error_mark_node;
1099             }
1100           padding_range = build_chill_range_type (NULL_TREE, integer_one_node,
1101                                                   needed_padding);
1102           padding_type
1103             = build_simple_array_type (TREE_TYPE (target_array_type),
1104                                        padding_range, NULL_TREE);
1105           TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size;
1106           if (CH_CHARS_TYPE_P (target_array_type))
1107             MARK_AS_STRING_TYPE (padding_type);
1108           padding = build (UNDEFINED_EXPR, padding_type);
1109           if (TREE_CONSTANT (e))
1110             e = build_chill_binary_op (CONCAT_EXPR, e, padding);
1111           else
1112             e = build (CONCAT_EXPR, target_array_type, e, padding);
1113         }
1114       e = convert (TREE_TYPE (field1), e);
1115       /* We build this constructor by hand (rather than going through
1116          digest_structure_tuple), to avoid some type-checking problem.
1117          E.g. type may have non-null novelty, but its field1 will
1118          have non-novelty. */
1119       e = build (CONSTRUCTOR, type, NULL_TREE,
1120                     tree_cons (field0, nentries,
1121                                build_tree_list (field1, e)));
1122       /* following was wrong, cause orig_e never will be TREE_CONSTANT. e
1123          may become constant after digest_array_tuple. */
1124       if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */
1125         {
1126           TREE_CONSTANT (e) = 1;
1127           if (TREE_STATIC (nentries) && TREE_STATIC (orig_e))
1128             TREE_STATIC (e) = 1;
1129         }
1130     }
1131   if (TREE_TYPE (e) == NULL_TREE)
1132     {
1133       if (TREE_CODE (e) == CONSTRUCTOR)
1134         {
1135           if (TREE_CODE (type) == SET_TYPE)
1136             return digest_powerset_tuple (type, e);
1137           if (TREE_CODE (type) == RECORD_TYPE)
1138             return digest_structure_tuple (type, e);
1139           if (TREE_CODE (type) == ARRAY_TYPE)
1140             return digest_array_tuple (type, e, 0);
1141           fatal ("internal error - bad CONSTRUCTOR passed to convert");
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 }