gcc/ch/typeck.c

   1 /* Build expressions with type checking for CHILL compiler.
   2    Copyright (C) 1992, 93, 1994, 1998, 1999 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 is part of the CHILL front end.
  23    It contains routines to build C expressions given their operands,
  24    including computing the modes of the result, C-specific error checks,
  25    and some optimization.
  26
  27    There are also routines to build RETURN_STMT nodes and CASE_STMT nodes,
  28    and to process initializations in declarations (since they work
  29    like a strange sort of assignment).  */
  30
  31 #include "config.h"
  32 #include "system.h"
  33 #include "tree.h"
  34 #include "ch-tree.h"
  35 #include "flags.h"
  36 #include "rtl.h"
  37 #include "expr.h"
  38 #include "lex.h"
  39 #include "toplev.h"
  40
  41 extern tree intQI_type_node;
  42 extern tree intHI_type_node;
  43 extern tree intSI_type_node;
  44 extern tree intDI_type_node;
  45 #if HOST_BITS_PER_WIDE_INT >= 64
  46 extern tree intTI_type_node;
  47 #endif
  48
  49 extern tree unsigned_intQI_type_node;
  50 extern tree unsigned_intHI_type_node;
  51 extern tree unsigned_intSI_type_node;
  52 extern tree unsigned_intDI_type_node;
  53 #if HOST_BITS_PER_WIDE_INT >= 64
  54 extern tree unsigned_intTI_type_node;
  55 #endif
  56
  57 /* forward declarations */
  58 static int chill_l_equivalent PROTO((tree, tree, struct mode_chain*));
  59 static tree extract_constant_from_buffer PROTO((tree, unsigned char *, int));
  60 static int expand_constant_to_buffer PROTO((tree, unsigned char *, int));
  61 \f
  62 /*
  63  * This function checks an array access.
  64  * It calls error (ERROR_MESSAGE) if the condition (index <= domain max value
  65  *                                     index >= domain min value)
  66  *                   is not met at compile time,
  67  *         If a runtime test is required and permitted,
  68  *         check_expression is used to do so.
  69  * the global RANGE_CHECKING flags controls the
  70  * generation of runtime checking code.
  71  */
  72 tree
  73 valid_array_index_p (array, idx, error_message, is_varying_lhs)
  74      tree array, idx;
  75      char *error_message;
  76      int is_varying_lhs;
  77 {
  78   tree cond, low_limit, high_cond, atype, domain;
  79   tree orig_index = idx;
  80   enum chill_tree_code condition;
  81
  82   if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
  83       || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK)
  84     return error_mark_node;
  85
  86   if (TREE_CODE (idx) == TYPE_DECL
  87       || TREE_CODE_CLASS (TREE_CODE (idx)) == 't')
  88     {
  89       error ("array or string index is a mode (instead of a value)");
  90       return error_mark_node;
  91     }
  92
  93   atype = TREE_TYPE (array);
  94
  95   if (chill_varying_type_p (atype))
  96     {
  97       domain = TYPE_DOMAIN (CH_VARYING_ARRAY_TYPE (atype));
  98       high_cond = build_component_ref (array, var_length_id);
  99       if (chill_varying_string_type_p (atype))
 100         {
 101           if (is_varying_lhs)
 102             condition = GT_EXPR;
 103           else
 104             condition = GE_EXPR;
 105         }
 106       else
 107         condition = GT_EXPR;
 108     }
 109   else
 110     {
 111       domain = TYPE_DOMAIN (atype);
 112       high_cond = TYPE_MAX_VALUE (domain);
 113       condition = GT_EXPR;
 114     }
 115
 116   if (CH_STRING_TYPE_P (atype))
 117     {
 118       if (! CH_SIMILAR (TREE_TYPE (orig_index), integer_type_node))
 119         {
 120           error ("index is not an integer expression");
 121           return error_mark_node;
 122         }
 123     }
 124   else
 125     {
 126       if (! CH_COMPATIBLE (orig_index, domain))
 127         {
 128           error ("index not compatible with index mode");
 129           return error_mark_node;
 130         }
 131     }
 132
 133   /* Convert BOOLS(1) to BOOL and CHARS(1) to CHAR. */
 134   if (flag_old_strings)
 135     {
 136       idx = convert_to_discrete (idx);
 137       if (idx == NULL) /* should never happen */
 138         error ("index is not discrete");
 139     }
 140
 141   /* we know we'll refer to this value twice */
 142   if (range_checking)
 143     idx = save_expr (idx);
 144
 145   low_limit = TYPE_MIN_VALUE (domain);
 146   high_cond = build_compare_discrete_expr (condition, idx, high_cond);
 147
 148   /* an invalid index expression meets this condition */
 149   cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
 150            build_compare_discrete_expr (LT_EXPR, idx, low_limit),
 151              high_cond));
 152
 153   /* strip a redundant NOP_EXPR */
 154   if (TREE_CODE (cond) == NOP_EXPR
 155       && TREE_TYPE (cond) == boolean_type_node
 156       && TREE_CODE (TREE_OPERAND (cond, 0)) == INTEGER_CST)
 157     cond = TREE_OPERAND (cond, 0);
 158
 159   idx = convert (CH_STRING_TYPE_P (atype) ? integer_type_node : domain,
 160                  idx);
 161
 162   if (TREE_CODE (cond) == INTEGER_CST)
 163     {
 164       if (tree_int_cst_equal (cond, boolean_false_node))
 165         return idx;       /* condition met at compile time */
 166       error (error_message); /* condition failed at compile time */
 167       return error_mark_node;
 168     }
 169   else if (range_checking)
 170     {
 171       /* FIXME: often, several of these conditions will
 172          be generated for the same source file and line number.
 173          A great optimization would be to share the
 174          cause_exception function call among them rather
 175          than generating a cause_exception call for each. */
 176       return check_expression (idx, cond,
 177                                ridpointers[(int) RID_RANGEFAIL]);
 178     }
 179   else
 180     return idx;           /* don't know at compile time */
 181 }
 182 \f
 183 /*
 184  * Extract a slice from an array, which could look like a
 185  * SET_TYPE if it's a bitstring.  The array could also be VARYING
 186  * if the element type is CHAR.  The min_value and length values
 187  * must have already been checked with valid_array_index_p.  No
 188  * checking is done here.
 189  */
 190 tree
 191 build_chill_slice (array, min_value, length)
 192      tree array, min_value, length;
 193 {
 194   tree result;
 195   tree array_type = TREE_TYPE (array);
 196
 197   if (!CH_REFERABLE (array) && TREE_CODE (array) != SAVE_EXPR
 198       && (TREE_CODE (array) != COMPONENT_REF
 199            || TREE_CODE (TREE_OPERAND (array, 0)) != SAVE_EXPR))
 200     {
 201       if (!TREE_CONSTANT (array))
 202         warning ("possible internal error - slice argument is neither referable nor constant");
 203       else
 204         {
 205           /* Force to storage.
 206              NOTE:  This could mean multiple identical copies of
 207              the same constant.  FIXME. */
 208           tree mydecl = decl_temp1 (get_unique_identifier("SLICEE"),
 209                                     array_type, 1, array, 0, 0);
 210           TREE_READONLY (mydecl) = 1;
 211           /* mark_addressable (mydecl); FIXME: necessary? */
 212           array = mydecl;
 213         }
 214     }
 215
 216   /*
 217      The code-generation which uses a slice tree needs not only to
 218      know the dynamic upper and lower limits of that slice, but the
 219      original static allocation, to use to build temps where one or both
 220      of the dynamic limits must be calculated at runtime..  We pass the
 221      dynamic size by building a new array_type whose limits are the
 222      min_value and min_value + length values passed to us.
 223
 224      The static allocation info is passed by using the parent array's
 225      limits to compute a temp_size, which is passed in the lang_specific
 226      field of the slice_type.
 227    */
 228
 229   if (TREE_CODE (array_type) == ARRAY_TYPE)
 230     {
 231       tree domain_type = TYPE_DOMAIN (array_type);
 232       tree domain_min = TYPE_MIN_VALUE (domain_type);
 233       tree domain_max = fold (build (PLUS_EXPR, domain_type,
 234                                      domain_min,
 235                                      size_binop (MINUS_EXPR,
 236                                                  length, integer_one_node)));
 237       tree index_type = build_chill_range_type (TYPE_DOMAIN (array_type),
 238                                                 domain_min,
 239                                                 domain_max);
 240
 241       tree element_type = TREE_TYPE (array_type);
 242       tree slice_type = build_simple_array_type (element_type, index_type, NULL_TREE);
 243       tree slice_pointer_type;
 244       tree max_size;
 245
 246       if (CH_CHARS_TYPE_P (array_type))
 247         MARK_AS_STRING_TYPE (slice_type);
 248       else
 249         TYPE_PACKED (slice_type) = TYPE_PACKED (array_type);
 250
 251       SET_CH_NOVELTY (slice_type, CH_NOVELTY (array_type));
 252
 253       if (TREE_CONSTANT (array) && TREE_CODE (min_value) == INTEGER_CST
 254           && TREE_CODE (length) == INTEGER_CST)
 255         {
 256           int type_size = int_size_in_bytes (array_type);
 257           unsigned char *buffer = (unsigned char*) alloca (type_size);
 258           int delta = int_size_in_bytes (element_type)
 259             * (TREE_INT_CST_LOW (min_value) - TREE_INT_CST_LOW (domain_min));
 260           bzero (buffer, type_size);
 261           if (expand_constant_to_buffer (array, buffer, type_size))
 262             {
 263               result = extract_constant_from_buffer (slice_type,
 264                                                      buffer + delta,
 265                                                      type_size - delta);
 266               if (result)
 267                 return result;
 268             }
 269         }
 270
 271       /* Kludge used by case CONCAT_EXPR in chill_expand_expr.
 272          Set TYPE_ARRAY_MAX_SIZE to a constant upper bound on the
 273          bytes needed. */
 274       max_size = size_in_bytes (slice_type);
 275       if (TREE_CODE (max_size) != INTEGER_CST)
 276         {
 277           max_size = TYPE_ARRAY_MAX_SIZE (array_type);
 278           if (max_size == NULL_TREE)
 279             max_size = size_in_bytes (array_type);
 280         }
 281       TYPE_ARRAY_MAX_SIZE (slice_type) = max_size;
 282
 283       mark_addressable (array);
 284       /* Contruct a SLICE_EXPR to represent a slice of a packed array of bits. */
 285       if (TYPE_PACKED (array_type))
 286         {
 287           if (pass == 2 && TREE_CODE (length) != INTEGER_CST)
 288             {
 289               sorry ("bit array slice with non-constant length");
 290               return error_mark_node;
 291             }
 292           if (domain_min && ! integer_zerop (domain_min))
 293             min_value = size_binop (MINUS_EXPR, min_value,
 294                                     convert (sizetype, domain_min));
 295           result = build (SLICE_EXPR, slice_type, array, min_value, length);
 296           TREE_READONLY (result)
 297             = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type));
 298           return result;
 299         }
 300
 301       slice_pointer_type = build_chill_pointer_type (slice_type);
 302       if (TREE_CODE (min_value) == INTEGER_CST
 303           && domain_min && TREE_CODE (domain_min) == INTEGER_CST
 304           && compare_int_csts (EQ_EXPR, min_value, domain_min))
 305         result = fold (build1 (ADDR_EXPR, slice_pointer_type, array));
 306       else
 307         {
 308           min_value = convert (sizetype, min_value);
 309           if (domain_min && ! integer_zerop (domain_min))
 310             min_value = size_binop (MINUS_EXPR, min_value,
 311                                     convert (sizetype, domain_min));
 312           min_value = size_binop (MULT_EXPR, min_value,
 313                                   size_in_bytes (element_type));
 314           result = fold (build (PLUS_EXPR, slice_pointer_type,
 315                                 build1 (ADDR_EXPR, slice_pointer_type,
 316                                         array),
 317                                 convert (slice_pointer_type, min_value)));
 318         }
 319       /* Return the final array value. */
 320       result = fold (build1 (INDIRECT_REF, slice_type, result));
 321       TREE_READONLY (result)
 322         = TREE_READONLY (array) | TYPE_READONLY (element_type);
 323       return result;
 324     }
 325   else if (TREE_CODE (array_type) == SET_TYPE)  /* actually a bitstring */
 326     {
 327       if (pass == 2 && TREE_CODE (length) != INTEGER_CST)
 328         {
 329           sorry ("bitstring slice with non-constant length");
 330           return error_mark_node;
 331         }
 332       result = build (SLICE_EXPR, build_bitstring_type (length),
 333                       array, min_value, length);
 334       TREE_READONLY (result)
 335         = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type));
 336       return result;
 337     }
 338   else if (chill_varying_type_p (array_type))
 339       return build_chill_slice (varying_to_slice (array), min_value, length);
 340   else
 341     {
 342       error ("slice operation on non-array, non-bitstring value not supported");
 343       return error_mark_node;
 344     }
 345 }
 346 \f
 347 static tree
 348 build_empty_string (type)
 349      tree type;
 350 {
 351   int orig_pass = pass;
 352   tree range, result;
 353
 354   range = build_chill_range_type (type, integer_zero_node,
 355                                   integer_minus_one_node);
 356   result = build_chill_array_type (type,
 357              tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE);
 358   pass = 2;
 359   range = build_chill_range_type (type, integer_zero_node,
 360                                   integer_minus_one_node);
 361   result = build_chill_array_type (type,
 362              tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE);
 363   pass = orig_pass;
 364
 365   return decl_temp1 (get_unique_identifier ("EMPTY_STRING"),
 366                      result, 0, NULL_TREE, 0, 0);
 367 }
 368 \f
 369 /* We build the runtime range-checking as a separate list
 370  * rather than making a compound_expr with min_value
 371  * (for example), to control when that comparison gets
 372  * generated.  We cannot allow it in a TYPE_MAX_VALUE or
 373  * TYPE_MIN_VALUE expression, for instance, because that code
 374  * will get generated when the slice is laid out, which would
 375  * put it outside the scope of an exception handler for the
 376  * statement we're generating.  I.e. we would be generating
 377  * cause_exception calls which might execute before the
 378  * necessary ch_link_handler call.
 379  */
 380 tree
 381 build_chill_slice_with_range (array, min_value, max_value)
 382      tree array, min_value, max_value;
 383 {
 384   if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
 385       || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK
 386       || max_value == NULL_TREE || TREE_CODE(max_value) == ERROR_MARK)
 387     return error_mark_node;
 388
 389   if (TREE_TYPE (array) == NULL_TREE
 390       || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE
 391           && TREE_CODE (TREE_TYPE (array)) != SET_TYPE
 392           && !chill_varying_type_p (TREE_TYPE (array))))
 393     {
 394       error ("can only take slice of array or string");
 395       return error_mark_node;
 396     }
 397
 398   array = save_if_needed (array);
 399
 400   /* FIXME: test here for max_value >= min_value, except
 401      for max_value == -1, min_value == 0 (empty string) */
 402   min_value = valid_array_index_p (array, min_value,
 403                                    "slice lower limit out-of-range", 0);
 404   if (TREE_CODE (min_value) == ERROR_MARK)
 405     return min_value;
 406
 407   /* FIXME: suppress this test if max_value is the LENGTH of a
 408      varying array, which has presumably already been checked. */
 409   max_value = valid_array_index_p (array, max_value,
 410                                    "slice upper limit out-of-range", 0);
 411   if (TREE_CODE (max_value) == ERROR_MARK)
 412     return error_mark_node;
 413
 414   if (TREE_CODE (min_value) == INTEGER_CST
 415       && TREE_CODE (max_value) == INTEGER_CST
 416       && tree_int_cst_lt (max_value, min_value))
 417     return build_empty_string (TREE_TYPE (TREE_TYPE (array)));
 418
 419   return build_chill_slice (array, min_value,
 420              save_expr (size_binop (PLUS_EXPR,
 421                size_binop (MINUS_EXPR, max_value, min_value),
 422                                     integer_one_node)));
 423 }
 424
 425
 426 tree
 427 build_chill_slice_with_length (array, min_value, length)
 428      tree array, min_value, length;
 429 {
 430   tree max_index;
 431   tree cond, high_cond, atype;
 432
 433   if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
 434       || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK
 435       || length == NULL_TREE || TREE_CODE(length) == ERROR_MARK)
 436     return error_mark_node;
 437
 438   if (TREE_TYPE (array) == NULL_TREE
 439       || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE
 440           && TREE_CODE (TREE_TYPE (array)) != SET_TYPE
 441           && !chill_varying_type_p (TREE_TYPE (array))))
 442     {
 443       error ("can only take slice of array or string");
 444       return error_mark_node;
 445     }
 446
 447   if (TREE_CONSTANT (length)
 448       && tree_int_cst_lt (length, integer_zero_node))
 449     return build_empty_string (TREE_TYPE (TREE_TYPE (array)));
 450
 451   array = save_if_needed (array);
 452   min_value = save_expr (min_value);
 453   length = save_expr (length);
 454
 455   if (! CH_SIMILAR (TREE_TYPE (length), integer_type_node))
 456     {
 457       error ("slice length is not an integer");
 458       length = integer_one_node;
 459     }
 460
 461   max_index = size_binop (MINUS_EXPR,
 462                 size_binop (PLUS_EXPR, length, min_value),
 463                           integer_one_node);
 464   max_index = convert_to_class (chill_expr_class (min_value), max_index);
 465
 466   min_value = valid_array_index_p (array, min_value,
 467                                    "slice start index out-of-range", 0);
 468   if (TREE_CODE (min_value) == ERROR_MARK)
 469     return error_mark_node;
 470
 471   atype = TREE_TYPE (array);
 472
 473   if (chill_varying_type_p (atype))
 474     high_cond = build_component_ref (array, var_length_id);
 475   else
 476     high_cond = TYPE_MAX_VALUE (TYPE_DOMAIN (atype));
 477
 478   /* an invalid index expression meets this condition */
 479   cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
 480                       build_compare_discrete_expr (LT_EXPR,
 481                                                    length, integer_zero_node),
 482                       build_compare_discrete_expr (GT_EXPR,
 483                                                    max_index, high_cond)));
 484
 485   if (TREE_CODE (cond) == INTEGER_CST)
 486     {
 487       if (! tree_int_cst_equal (cond, boolean_false_node))
 488         {
 489           error ("slice length out-of-range");
 490           return error_mark_node;
 491         }
 492
 493     }
 494   else if (range_checking)
 495     {
 496       min_value = check_expression (min_value, cond,
 497                                     ridpointers[(int) RID_RANGEFAIL]);
 498     }
 499
 500   return build_chill_slice (array, min_value, length);
 501 }
 502 \f
 503 tree
 504 build_chill_array_ref (array, indexlist)
 505      tree array, indexlist;
 506 {
 507   tree idx;
 508
 509   if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK)
 510     return error_mark_node;
 511   if (indexlist == NULL_TREE || TREE_CODE (indexlist) == ERROR_MARK)
 512     return error_mark_node;
 513
 514   idx = TREE_VALUE (indexlist);   /* handle first index */
 515
 516   idx = valid_array_index_p (array, idx,
 517                              "array index out-of-range", 0);
 518   if (TREE_CODE (idx) == ERROR_MARK)
 519     return error_mark_node;
 520
 521   array = build_chill_array_ref_1 (array, idx);
 522
 523   if (array && TREE_CODE (array) != ERROR_MARK
 524       && TREE_CHAIN (indexlist))
 525     {
 526       /* Z.200 (1988) section 4.2.8 says that:
 527          <array> '(' <expression {',' <expression> }* ')'
 528          is derived syntax (i.e. syntactic sugar) for:
 529          <array> '(' <expression ')' { '(' <expression> ')' }*
 530          The intent is clear if <array> has mode: ARRAY (...) ARRAY (...) XXX.
 531          But what if <array> has mode: ARRAY (...) CHARS (N)
 532          or: ARRAY (...) BOOLS (N).
 533          Z.200 doesn't explicitly prohibit it, but the intent is unclear.
 534          We'll allow it, since it seems reasonable and useful.
 535          However, we won't allow it if <array> is:
 536          ARRAY (...) PROC (...).
 537          (The latter would make sense if we allowed general
 538          Currying, which Chill doesn't.)  */
 539       if (TREE_CODE (TREE_TYPE (array)) == ARRAY_TYPE
 540           || chill_varying_type_p (TREE_TYPE (array))
 541           || CH_BOOLS_TYPE_P (TREE_TYPE (array)))
 542         array = build_generalized_call (array, TREE_CHAIN (indexlist));
 543       else
 544         error ("too many index expressions");
 545     }
 546   return array;
 547 }
 548
 549 /*
 550  * Don't error check the index in here.  It's supposed to be
 551  * checked by the caller.
 552  */
 553 tree
 554 build_chill_array_ref_1 (array, idx)
 555      tree array, idx;
 556 {
 557   tree type;
 558   tree domain;
 559   tree rval;
 560
 561   if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK
 562       || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK)
 563     return error_mark_node;
 564
 565   if (chill_varying_type_p (TREE_TYPE (array)))
 566     array = varying_to_slice (array);
 567
 568   domain = TYPE_DOMAIN (TREE_TYPE (array));
 569
 570 #if 0
 571   if (! integer_zerop (TYPE_MIN_VALUE (domain)))
 572     {
 573       /* The C part of the compiler doesn't understand how to do
 574          arithmetic with dissimilar enum types.  So we check compatability
 575          here, and perform the math in INTEGER_TYPE.  */
 576       if (TREE_CODE (TREE_TYPE (idx)) == ENUMERAL_TYPE
 577           && chill_comptypes (TREE_TYPE (idx), domain, 0))
 578         idx = convert (TREE_TYPE (TYPE_MIN_VALUE (domain)), idx);
 579       idx = build_binary_op (MINUS_EXPR, idx, TYPE_MIN_VALUE (domain), 0);
 580     }
 581 #endif
 582
 583   if (CH_STRING_TYPE_P (TREE_TYPE (array)))
 584     {
 585       /* Could be bitstring or char string.  */
 586       if (TREE_TYPE (TREE_TYPE (array)) == boolean_type_node)
 587         {
 588           rval = build (SET_IN_EXPR, boolean_type_node, idx, array);
 589           TREE_READONLY (rval) = TREE_READONLY (array);
 590           return rval;
 591         }
 592     }
 593
 594   if (!discrete_type_p (TREE_TYPE (idx)))
 595     {
 596       error ("array index is not discrete");
 597       return error_mark_node;
 598     }
 599
 600   /* An array that is indexed by a non-constant
 601      cannot be stored in a register; we must be able to do
 602      address arithmetic on its address.
 603      Likewise an array of elements of variable size.  */
 604   if (TREE_CODE (idx) != INTEGER_CST
 605       || (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))) != 0
 606           && TREE_CODE (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array)))) != INTEGER_CST))
 607     {
 608       if (mark_addressable (array) == 0)
 609         return error_mark_node;
 610     }
 611
 612   type = TREE_TYPE (TREE_TYPE (array));
 613
 614   /* Do constant folding */
 615   if (TREE_CODE (idx) == INTEGER_CST && TREE_CONSTANT (array))
 616     {
 617       struct ch_class class;
 618       class.kind = CH_VALUE_CLASS;
 619       class.mode = type;
 620
 621       if (TREE_CODE (array) == CONSTRUCTOR)
 622         {
 623           tree list = CONSTRUCTOR_ELTS (array);
 624           for ( ; list != NULL_TREE; list = TREE_CHAIN (list))
 625             {
 626               if (tree_int_cst_equal (TREE_PURPOSE (list), idx))
 627                 return convert_to_class (class, TREE_VALUE (list));
 628             }
 629         }
 630       else if (TREE_CODE (array) == STRING_CST
 631                && CH_CHARS_TYPE_P (TREE_TYPE (array)))
 632         {
 633           HOST_WIDE_INT i = TREE_INT_CST_LOW (idx);
 634           if (i >= 0 && i < TREE_STRING_LENGTH (array))
 635             {
 636               char ch = TREE_STRING_POINTER (array) [i];
 637               return convert_to_class (class,
 638                                        build_int_2 ((unsigned char)ch, 0));
 639             }
 640         }
 641     }
 642
 643   if (TYPE_PACKED (TREE_TYPE (array)))
 644     rval = build (PACKED_ARRAY_REF, type, array, idx);
 645   else
 646     rval = build (ARRAY_REF, type, array, idx);
 647
 648   /* Array ref is const/volatile if the array elements are
 649      or if the array is.  */
 650   TREE_READONLY (rval) = TREE_READONLY (array) | TYPE_READONLY (type);
 651   TREE_SIDE_EFFECTS (rval)
 652     |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array)))
 653         | TREE_SIDE_EFFECTS (array));
 654   TREE_THIS_VOLATILE (rval)
 655     |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array)))
 656         /* This was added by rms on 16 Nov 91.
 657            It fixes  vol struct foo *a;  a->elts[1]
 658            in an inline function.
 659            Hope it doesn't break something else.  */
 660         | TREE_THIS_VOLATILE (array));
 661   return fold (rval);
 662 }
 663 \f
 664 tree
 665 build_chill_bitref (bitstring, indexlist)
 666      tree bitstring, indexlist;
 667 {
 668   if (TREE_CODE (bitstring) == ERROR_MARK)
 669     return bitstring;
 670   if (TREE_CODE (indexlist) == ERROR_MARK)
 671     return indexlist;
 672
 673   if (TREE_CHAIN (indexlist) != NULL_TREE)
 674     {
 675       error ("invalid compound index for bitstring mode");
 676       return error_mark_node;
 677     }
 678
 679   if (TREE_CODE (indexlist) == TREE_LIST)
 680     {
 681       tree result = build (SET_IN_EXPR, boolean_type_node,
 682                            TREE_VALUE (indexlist), bitstring);
 683       TREE_READONLY (result) = TREE_READONLY (bitstring);
 684       return result;
 685     }
 686   else abort ();
 687 }
 688
 689 \f
 690 int
 691 discrete_type_p (type)
 692      tree type;
 693 {
 694   return INTEGRAL_TYPE_P (type);
 695 }
 696
 697 /* Checks that EXP has discrete type, or can be converted to discrete.
 698    Otherwise, returns NULL_TREE.
 699    Normally returns the (possibly-converted) EXP. */
 700
 701 tree
 702 convert_to_discrete (exp)
 703      tree exp;
 704 {
 705   if (! discrete_type_p (TREE_TYPE (exp)))
 706     {
 707       if (flag_old_strings)
 708         {
 709           if (CH_CHARS_ONE_P (TREE_TYPE (exp)))
 710             return convert (char_type_node, exp);
 711           if (CH_BOOLS_ONE_P (TREE_TYPE (exp)))
 712             return convert (boolean_type_node, exp);
 713         }
 714       return NULL_TREE;
 715     }
 716   return exp;
 717 }
 718 \f
 719 /* Write into BUFFER the target-machine representation of VALUE.
 720    Returns 1 on success, or 0 on failure. (Either the VALUE was
 721    not constant, or we don't know how to do the conversion.) */
 722
 723 static int
 724 expand_constant_to_buffer (value, buffer, buf_size)
 725      tree value;
 726      unsigned char *buffer;
 727      int buf_size;
 728 {
 729   tree type = TREE_TYPE (value);
 730   int size = int_size_in_bytes (type);
 731   int i;
 732   if (size < 0 || size > buf_size)
 733     return 0;
 734   switch (TREE_CODE (value))
 735     {
 736     case INTEGER_CST:
 737       {
 738         HOST_WIDE_INT lo = TREE_INT_CST_LOW (value);
 739         HOST_WIDE_INT hi = TREE_INT_CST_HIGH (value);
 740         for (i = 0; i < size; i++)
 741           {
 742             /* Doesn't work if host and target BITS_PER_UNIT differ. */
 743             unsigned char byte = lo & ((1 << BITS_PER_UNIT) - 1);
 744             if (BYTES_BIG_ENDIAN)
 745               buffer[size - i - 1] = byte;
 746             else
 747               buffer[i] = byte;
 748             rshift_double (lo, hi, BITS_PER_UNIT, BITS_PER_UNIT * size,
 749                            &lo, &hi, 0);
 750           }
 751       }
 752       break;
 753     case STRING_CST:
 754       {
 755         size = TREE_STRING_LENGTH (value);
 756         if (size > buf_size)
 757           return 0;
 758         bcopy (TREE_STRING_POINTER (value), buffer, size);
 759         break;
 760       }
 761     case CONSTRUCTOR:
 762       if (TREE_CODE (type) == ARRAY_TYPE)
 763         {
 764           tree element_type = TREE_TYPE (type);
 765           int element_size = int_size_in_bytes (element_type);
 766           tree list = CONSTRUCTOR_ELTS (value);
 767           HOST_WIDE_INT next_index;
 768           HOST_WIDE_INT min_index = 0;
 769           if (element_size < 0)
 770             return 0;
 771
 772           if (TYPE_DOMAIN (type) != 0)
 773             {
 774               tree min_val = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
 775               if (min_val)
 776                 {
 777                   if (TREE_CODE (min_val) != INTEGER_CST)
 778                     return 0;
 779                   else
 780                     min_index = TREE_INT_CST_LOW (min_val);
 781                 }
 782             }
 783
 784           next_index = min_index;
 785
 786           for (; list != NULL_TREE; list = TREE_CHAIN (list))
 787             {
 788               HOST_WIDE_INT offset;
 789               HOST_WIDE_INT last_index;
 790               tree purpose = TREE_PURPOSE (list);
 791               if (purpose)
 792                 {
 793                   if (TREE_CODE (purpose) == INTEGER_CST)
 794                     last_index = next_index = TREE_INT_CST_LOW (purpose);
 795                   else if (TREE_CODE (purpose) == RANGE_EXPR)
 796                     {
 797                       next_index = TREE_INT_CST_LOW (TREE_OPERAND(purpose, 0));
 798                       last_index = TREE_INT_CST_LOW (TREE_OPERAND(purpose, 1));
 799                     }
 800                   else
 801                     return 0;
 802                 }
 803               else
 804                 last_index = next_index;
 805               for ( ; next_index <= last_index; next_index++)
 806                 {
 807                   offset = (next_index - min_index) * element_size;
 808                   if (!expand_constant_to_buffer (TREE_VALUE (list),
 809                                                   buffer + offset,
 810                                                   buf_size - offset))
 811                     return 0;
 812                 }
 813             }
 814           break;
 815         }
 816       else if (TREE_CODE (type) == RECORD_TYPE)
 817         {
 818           tree list = CONSTRUCTOR_ELTS (value);
 819           for (; list != NULL_TREE; list = TREE_CHAIN (list))
 820             {
 821               tree field = TREE_PURPOSE (list);
 822               HOST_WIDE_INT offset;
 823               if (field == NULL_TREE || TREE_CODE (field) != FIELD_DECL)
 824                 return 0;
 825               if (DECL_BIT_FIELD (field))
 826                 return 0;
 827               offset = TREE_INT_CST_LOW (DECL_FIELD_BITPOS (field))
 828                 / BITS_PER_UNIT;
 829               if (!expand_constant_to_buffer (TREE_VALUE (list),
 830                                               buffer + offset,
 831                                               buf_size - offset))
 832                 return 0;
 833             }
 834           break;
 835         }
 836       else if (TREE_CODE (type) == SET_TYPE)
 837         {
 838           if (get_set_constructor_bytes (value, buffer, buf_size)
 839               != NULL_TREE)
 840             return 0;
 841         }
 842       break;
 843     default:
 844       return 0;
 845     }
 846   return 1;
 847 }
 848
 849 /* Given that BUFFER contains a target-machine representation of
 850    a value of type TYPE, return that value as a tree.
 851    Returns NULL_TREE on failure. (E.g. the TYPE might be variable size,
 852    or perhaps we don't know how to do the conversion.) */
 853
 854 static tree
 855 extract_constant_from_buffer (type, buffer, buf_size)
 856      tree type;
 857      unsigned char *buffer;
 858      int buf_size;
 859 {
 860   tree value;
 861   int size = int_size_in_bytes (type);
 862   int i;
 863   if (size < 0 || size > buf_size)
 864     return 0;
 865   switch (TREE_CODE (type))
 866     {
 867     case INTEGER_TYPE:
 868     case CHAR_TYPE:
 869     case BOOLEAN_TYPE:
 870     case ENUMERAL_TYPE:
 871     case POINTER_TYPE:
 872       {
 873         HOST_WIDE_INT lo = 0, hi = 0;
 874         /* Accumulate (into (lo,hi) the bytes (from buffer). */
 875         for (i = size; --i >= 0; )
 876           {
 877             unsigned char byte;
 878             /* Get next byte (in big-endian order). */
 879             if (BYTES_BIG_ENDIAN)
 880               byte = buffer[size - i - 1];
 881             else
 882               byte = buffer[i];
 883             lshift_double (lo, hi, BITS_PER_UNIT, TYPE_PRECISION (type),
 884                            &lo, &hi, 0);
 885             add_double (lo, hi, byte, 0, &lo, &hi);
 886           }
 887         value = build_int_2 (lo, hi);
 888         TREE_TYPE (value) = type;
 889         return value;
 890       }
 891     case ARRAY_TYPE:
 892       {
 893         tree element_type = TREE_TYPE (type);
 894         int element_size = int_size_in_bytes (element_type);
 895         tree list = NULL_TREE;
 896         HOST_WIDE_INT min_index = 0, max_index, cur_index;
 897         if (element_size == 1 && CH_CHARS_TYPE_P (type))
 898           {
 899             value = build_string (size, buffer);
 900             CH_DERIVED_FLAG (value) = 1;
 901             TREE_TYPE (value) = type;
 902             return value;
 903           }
 904         if (TYPE_DOMAIN (type) == 0)
 905           return 0;
 906         value = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
 907         if (value)
 908           {
 909             if (TREE_CODE (value) != INTEGER_CST)
 910               return 0;
 911             else
 912               min_index = TREE_INT_CST_LOW (value);
 913           }
 914         value = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
 915         if (value == NULL_TREE || TREE_CODE (value) != INTEGER_CST)
 916           return 0;
 917         else
 918           max_index = TREE_INT_CST_LOW (value);
 919         for (cur_index = max_index; cur_index >= min_index; cur_index--)
 920           {
 921             HOST_WIDE_INT offset = (cur_index - min_index) * element_size;
 922             value = extract_constant_from_buffer (element_type,
 923                                                   buffer + offset,
 924                                                   buf_size - offset);
 925             if (value == NULL_TREE)
 926               return NULL_TREE;
 927             list = tree_cons (build_int_2 (cur_index, 0), value, list);
 928           }
 929         value = build (CONSTRUCTOR, type, NULL_TREE, list);
 930         TREE_CONSTANT (value) = 1;
 931         TREE_STATIC (value) = 1;
 932         return value;
 933       }
 934     case RECORD_TYPE:
 935       {
 936         tree list = NULL_TREE;
 937         tree field = TYPE_FIELDS (type);
 938         for (; field != NULL_TREE; field = TREE_CHAIN (field))
 939           {
 940             HOST_WIDE_INT offset
 941               = TREE_INT_CST_LOW (DECL_FIELD_BITPOS (field)) / BITS_PER_UNIT;
 942             if (DECL_BIT_FIELD (field))
 943               return 0;
 944             value = extract_constant_from_buffer (TREE_TYPE (field),
 945                                                   buffer + offset,
 946                                                   buf_size - offset);
 947             if (value == NULL_TREE)
 948               return NULL_TREE;
 949             list = tree_cons (field, value, list);
 950           }
 951         value = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list));
 952         TREE_CONSTANT (value) = 1;
 953         TREE_STATIC (value) = 1;
 954         return value;
 955       }
 956
 957     case UNION_TYPE:
 958       {
 959         tree longest_variant = NULL_TREE;
 960         int longest_size = 0;
 961         tree field = TYPE_FIELDS (type);
 962
 963         /* This is a kludge.  We assume that converting the data to te
 964            longest variant will provide valid data for the "correct"
 965            variant.  This is usually the case, but is not guaranteed.
 966            For example, the longest variant may include holes.
 967            Also incorrect interpreting the given value as the longest
 968            variant may confuse the compiler if that should happen
 969            to yield invalid values.  ??? */
 970
 971         for (; field != NULL_TREE; field = TREE_CHAIN (field))
 972           {
 973             int size = TREE_INT_CST_LOW (size_in_bytes (TREE_TYPE (field)));
 974
 975             if (size > longest_size)
 976               {
 977                 longest_size = size;
 978                 longest_variant = field;
 979               }
 980           }
 981         if (longest_variant == NULL_TREE)
 982           return NULL_TREE;
 983         return extract_constant_from_buffer (TREE_TYPE (longest_variant), buffer, buf_size);
 984       }
 985
 986     case SET_TYPE:
 987       {
 988         tree list = NULL_TREE;
 989         int i;
 990         HOST_WIDE_INT min_index, max_index;
 991         if (TYPE_DOMAIN (type) == 0)
 992           return 0;
 993         value = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
 994         if (value == NULL_TREE)
 995           min_index = 0;
 996         else if (TREE_CODE (value) != INTEGER_CST)
 997           return 0;
 998         else
 999           min_index = TREE_INT_CST_LOW (value);
1000         value = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1001         if (value == NULL_TREE)
1002           max_index = 0;
1003         else if (TREE_CODE (value) != INTEGER_CST)
1004           return 0;
1005         else
1006           max_index = TREE_INT_CST_LOW (value);
1007         for (i = max_index + 1 - min_index; --i >= 0; )
1008           {
1009             unsigned char byte = (unsigned char)buffer[i / BITS_PER_UNIT];
1010             unsigned bit_pos = (unsigned)i % (unsigned)BITS_PER_UNIT;
1011             if (BYTES_BIG_ENDIAN
1012                 ? (byte & (1 << (BITS_PER_UNIT - 1 - bit_pos)))
1013                 : (byte & (1 << bit_pos)))
1014               list = tree_cons (NULL_TREE,
1015                                 build_int_2 (i + min_index, 0), list);
1016           }
1017         value = build (CONSTRUCTOR, type, NULL_TREE, list);
1018         TREE_CONSTANT (value) = 1;
1019         TREE_STATIC (value) = 1;
1020         return value;
1021       }
1022
1023     default:
1024       return NULL_TREE;
1025     }
1026 }
1027
1028 tree
1029 build_chill_cast (type, expr)
1030      tree type, expr;
1031 {
1032   tree expr_type;
1033   int  expr_type_size;
1034   int  type_size;
1035   int  type_is_discrete;
1036   int  expr_type_is_discrete;
1037
1038   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
1039     return error_mark_node;
1040   if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
1041     return error_mark_node;
1042
1043   /* if expression was untyped because of its context (an
1044      if_expr or case_expr in a tuple, perhaps) just apply
1045      the type */
1046   expr_type = TREE_TYPE (expr);
1047   if (expr_type == NULL_TREE
1048       || TREE_CODE (expr_type) == ERROR_MARK)
1049     return convert (type, expr);
1050
1051   if (expr_type == type)
1052     return expr;
1053
1054   expr_type_size = int_size_in_bytes (expr_type);
1055   type_size      = int_size_in_bytes (type);
1056
1057   if (expr_type_size == -1)
1058     {
1059       error ("conversions from variable_size value");
1060       return error_mark_node;
1061     }
1062   if (type_size == -1)
1063     {
1064       error ("conversions to variable_size mode");
1065       return error_mark_node;
1066     }
1067
1068   /* FIXME: process REAL ==> INT && INT ==> REAL && REAL ==> REAL. I hope this is correct. */
1069   if ((TREE_CODE (expr_type) == INTEGER_TYPE && TREE_CODE (type) == REAL_TYPE) ||
1070       (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == INTEGER_TYPE) ||
1071       (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == REAL_TYPE))
1072     return convert (type, expr);
1073
1074   /* FIXME: Don't know if this is correct */
1075   /* Don't allow conversions to or from REAL with others then integer */
1076   if (TREE_CODE (type) == REAL_TYPE)
1077     {
1078       error ("cannot convert to float");
1079       return error_mark_node;
1080     }
1081   else if (TREE_CODE (expr_type) == REAL_TYPE)
1082     {
1083       error ("cannot convert float to this mode");
1084       return error_mark_node;
1085     }
1086
1087   if (expr_type_size == type_size && CH_REFERABLE (expr))
1088     goto do_location_conversion;
1089
1090   type_is_discrete
1091     = discrete_type_p (type) || TREE_CODE (type) == POINTER_TYPE;
1092   expr_type_is_discrete
1093     = discrete_type_p (expr_type) || TREE_CODE (expr_type) == POINTER_TYPE;
1094   if (expr_type_is_discrete && type_is_discrete)
1095     {
1096       /* do an overflow check
1097          FIXME: is this always neccessary ??? */
1098       /* FIXME: don't do range chacking when target type is PTR.
1099          PTR doesn't have MIN and MAXVALUE. result is sigsegv. */
1100       if (range_checking && type != ptr_type_node)
1101         {
1102           tree tmp = expr;
1103
1104           STRIP_NOPS (tmp);
1105           if (TREE_CONSTANT (tmp) && TREE_CODE (tmp) != ADDR_EXPR)
1106             {
1107               if (compare_int_csts (LT_EXPR, tmp, TYPE_MIN_VALUE (type)) ||
1108                   compare_int_csts (GT_EXPR, tmp, TYPE_MAX_VALUE (type)))
1109                 {
1110                   error ("OVERFLOW in expression conversion");
1111                   return error_mark_node;
1112                 }
1113             }
1114           else
1115             {
1116               int cond1 = tree_int_cst_lt (TYPE_SIZE (type),
1117                                            TYPE_SIZE (expr_type));
1118               int cond2 = TREE_UNSIGNED (type) && (! TREE_UNSIGNED (expr_type));
1119               int cond3 = (! TREE_UNSIGNED (type))
1120                 && TREE_UNSIGNED (expr_type)
1121                 && tree_int_cst_equal (TYPE_SIZE (type),
1122                                        TYPE_SIZE (expr_type));
1123               int cond4 = TREE_TYPE (type) && type_is_discrete;
1124
1125               if (cond1 || cond2 || cond3 || cond4)
1126                 {
1127                   tree type_min = TYPE_MIN_VALUE (type);
1128                   tree type_max = TYPE_MAX_VALUE (type);
1129
1130                   expr = save_if_needed (expr);
1131                   if (expr && type_min && type_max)
1132                     {
1133                       tree check = test_range (expr, type_min, type_max);
1134                       if (!integer_zerop (check))
1135                         {
1136                           if (current_function_decl == NULL_TREE)
1137                             {
1138                               if (TREE_CODE (check) == INTEGER_CST)
1139                                 error ("overflow (not inside function)");
1140                               else
1141                                 warning ("possible overflow (not inside function)");
1142                             }
1143                           else
1144                             {
1145                               if (TREE_CODE (check) == INTEGER_CST)
1146                                 warning ("expression will always cause OVERFLOW");
1147                               expr = check_expression (expr, check,
1148                                                        ridpointers[(int) RID_OVERFLOW]);
1149                             }
1150                         }
1151                     }
1152                 }
1153             }
1154         }
1155       return convert (type, expr);
1156     }
1157
1158   if (TREE_CODE (expr) == INTEGER_CST && expr_type_size != type_size)
1159     {
1160       /* There should probably be a pedwarn here ... */
1161       tree itype = type_for_size (type_size * BITS_PER_UNIT, 1);
1162       if (itype)
1163         {
1164           expr = convert (itype, expr);
1165           expr_type = TREE_TYPE (expr);
1166           expr_type_size= type_size;
1167         }
1168     }
1169
1170   /* If expr is a constant of the right size, use it to to
1171      initialize a static variable. */
1172   if (expr_type_size == type_size && TREE_CONSTANT (expr) && !pedantic)
1173     {
1174       unsigned char *buffer = (unsigned char*) alloca (type_size);
1175       tree value;
1176       bzero (buffer, type_size);
1177       if (!expand_constant_to_buffer (expr, buffer, type_size))
1178         {
1179           error ("not implemented: constant conversion from that kind of expression");
1180           return error_mark_node;
1181         }
1182       value = extract_constant_from_buffer (type, buffer, type_size);
1183       if (value == NULL_TREE)
1184         {
1185           error ("not implemented: constant conversion to that kind of mode");
1186           return error_mark_node;
1187         }
1188       return value;
1189     }
1190
1191   if (!CH_REFERABLE (expr) && expr_type_size == type_size)
1192     {
1193       tree temp = decl_temp1 (get_unique_identifier ("CAST"),
1194                               TREE_TYPE (expr), 0, 0, 0, 0);
1195       tree convert1 = build_chill_modify_expr (temp, expr);
1196       pedwarn ("non-standard, non-portable value conversion");
1197       return build (COMPOUND_EXPR, type, convert1,
1198                     build_chill_cast (type, temp));
1199     }
1200
1201   if (CH_REFERABLE (expr) && expr_type_size != type_size)
1202     error ("location conversion between differently-sized modes");
1203   else
1204     error ("unsupported value conversion");
1205   return error_mark_node;
1206
1207  do_location_conversion:
1208   /* To avoid confusing other parts of gcc,
1209      represent this as the C expression: *(TYPE*)EXPR. */
1210   mark_addressable (expr);
1211   expr = build1 (INDIRECT_REF, type,
1212                  build1 (NOP_EXPR, build_pointer_type (type),
1213                          build1 (ADDR_EXPR, build_pointer_type (expr_type),
1214                                  expr)));
1215   TREE_READONLY (expr) = TYPE_READONLY (type);
1216   return expr;
1217 }
1218 \f
1219 /*
1220  * given a set_type, build an integer array from it that C will grok.
1221  */
1222 tree
1223 build_array_from_set (type)
1224      tree type;
1225 {
1226   tree bytespint, bit_array_size, int_array_count;
1227
1228   if (type == NULL_TREE || type == error_mark_node || TREE_CODE (type) != SET_TYPE)
1229     return error_mark_node;
1230
1231   bytespint = build_int_2 (HOST_BITS_PER_INT / HOST_BITS_PER_CHAR, 0);
1232   bit_array_size = size_in_bytes (type);
1233   int_array_count = fold (size_binop (TRUNC_DIV_EXPR, bit_array_size,
1234                                                  bytespint));
1235   if (integer_zerop (int_array_count))
1236     int_array_count = size_one_node;
1237   type = build_array_type (integer_type_node,
1238                            build_index_type (int_array_count));
1239   return type;
1240 }
1241
1242
1243 tree
1244 build_chill_bin_type (size)
1245      tree size;
1246 {
1247 #if 0
1248   int isize;
1249
1250   if (TREE_CODE (size) != INTEGER_CST
1251       || (isize = TREE_INT_CST_LOW (size), isize <= 0))
1252     {
1253       error ("operand to bin must be a non-negative integer literal");
1254       return error_mark_node;
1255     }
1256   if (isize <= TYPE_PRECISION (unsigned_char_type_node))
1257     return unsigned_char_type_node;
1258   if (isize <= TYPE_PRECISION (short_unsigned_type_node))
1259     return short_unsigned_type_node;
1260   if (isize <= TYPE_PRECISION (unsigned_type_node))
1261     return unsigned_type_node;
1262   if (isize <= TYPE_PRECISION (long_unsigned_type_node))
1263     return long_unsigned_type_node;
1264   if (isize <= TYPE_PRECISION (long_long_unsigned_type_node))
1265     return long_long_unsigned_type_node;
1266   error ("size %d of BIN too big - no such integer mode", isize);
1267   return error_mark_node;
1268 #endif
1269   tree bintype;
1270
1271   if (pass == 1)
1272     {
1273       bintype = make_node (INTEGER_TYPE);
1274       TREE_TYPE (bintype) = ridpointers[(int) RID_BIN];
1275       TYPE_MIN_VALUE (bintype) = size;
1276       TYPE_MAX_VALUE (bintype) = size;
1277     }
1278   else
1279     {
1280       error ("BIN in pass 2");
1281       return error_mark_node;
1282     }
1283   return bintype;
1284 }
1285 \f
1286 tree
1287 chill_expand_tuple (type, constructor)
1288      tree type, constructor;
1289 {
1290   char *name;
1291   tree nonreft = type;
1292
1293   if (TYPE_NAME (type) != NULL_TREE)
1294     {
1295       if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE)
1296         name = IDENTIFIER_POINTER (TYPE_NAME (type));
1297       else
1298         name = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type)));
1299     }
1300   else
1301     name = "";
1302
1303   /* get to actual underlying type for digest_init */
1304   while (nonreft && TREE_CODE (nonreft) == REFERENCE_TYPE)
1305     nonreft = TREE_TYPE (nonreft);
1306
1307   if (TREE_CODE (nonreft) == ARRAY_TYPE
1308       || TREE_CODE (nonreft) == RECORD_TYPE
1309       || TREE_CODE (nonreft) == SET_TYPE)
1310     return convert (nonreft, constructor);
1311   else
1312     {
1313       error ("mode of tuple is neither ARRAY, STRUCT, nor POWERSET");
1314       return error_mark_node;
1315     }
1316 }
1317 \f
1318 /* This function classifies an expr into the Null class,
1319    the All class, the M-Value, the M-derived, or the M-reference class.
1320    It probably has some inaccuracies. */
1321
1322 struct ch_class
1323 chill_expr_class (expr)
1324      tree expr;
1325 {
1326   struct ch_class class;
1327   /* The Null class contains the NULL pointer constant (only). */
1328   if (expr == null_pointer_node)
1329     {
1330       class.kind = CH_NULL_CLASS;
1331       class.mode = NULL_TREE;
1332       return class;
1333     }
1334
1335   /* The All class contains the <undefined value> "*". */
1336   if (TREE_CODE (expr) == UNDEFINED_EXPR)
1337     {
1338       class.kind = CH_ALL_CLASS;
1339       class.mode = NULL_TREE;
1340       return class;
1341     }
1342
1343   if (CH_DERIVED_FLAG (expr))
1344     {
1345       class.kind = CH_DERIVED_CLASS;
1346       class.mode = TREE_TYPE (expr);
1347       return class;
1348     }
1349
1350   /* The M-Reference contains <references location> (address-of) expressions.
1351      Note that something that's been converted to a reference doesn't count. */
1352   if (TREE_CODE (expr) == ADDR_EXPR
1353       && TREE_CODE (TREE_TYPE (expr)) != REFERENCE_TYPE)
1354     {
1355       class.kind = CH_REFERENCE_CLASS;
1356       class.mode = TREE_TYPE (TREE_TYPE (expr));
1357       return class;
1358     }
1359
1360   /* The M-Value class contains expressions with a known, specific mode M. */
1361   class.kind = CH_VALUE_CLASS;
1362   class.mode = TREE_TYPE (expr);
1363   return class;
1364 }
1365
1366 /* Returns >= 1 iff REF is a location. Return 2 if it is referable. */
1367
1368 int chill_location (ref)
1369      tree ref;
1370 {
1371   register enum tree_code code = TREE_CODE (ref);
1372
1373   switch (code)
1374     {
1375     case REALPART_EXPR:
1376     case IMAGPART_EXPR:
1377     case ARRAY_REF:
1378     case PACKED_ARRAY_REF:
1379     case COMPONENT_REF:
1380     case NOP_EXPR: /* RETYPE_EXPR */
1381       return chill_location (TREE_OPERAND (ref, 0));
1382     case COMPOUND_EXPR:
1383       return chill_location (TREE_OPERAND (ref, 1));
1384
1385     case BIT_FIELD_REF:
1386     case SLICE_EXPR:
1387       /* A bit-string slice is nor referable. */
1388       return chill_location (TREE_OPERAND (ref, 0)) == 0 ? 0 : 1;
1389
1390     case CONSTRUCTOR:
1391     case STRING_CST:
1392       return 0;
1393
1394     case INDIRECT_REF:
1395     case VAR_DECL:
1396     case PARM_DECL:
1397     case RESULT_DECL:
1398     case ERROR_MARK:
1399       if (TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE
1400           && TREE_CODE (TREE_TYPE (ref)) != METHOD_TYPE)
1401         return 2;
1402       break;
1403
1404     default:
1405       break;
1406     }
1407   return 0;
1408 }
1409
1410 int
1411 chill_referable (val)
1412      tree val;
1413 {
1414   return chill_location (val) > 1;
1415 }
1416
1417 /* Make a copy of MODE, but with the given NOVELTY. */
1418
1419 tree
1420 copy_novelty (novelty, mode)
1421      tree novelty, mode;
1422 {
1423   if (CH_NOVELTY (mode) != novelty)
1424     {
1425       mode = copy_node (mode);
1426       TYPE_MAIN_VARIANT (mode) = mode;
1427       TYPE_NEXT_VARIANT (mode) = 0;
1428       TYPE_POINTER_TO (mode) = 0;
1429       TYPE_REFERENCE_TO (mode) = 0;
1430       SET_CH_NOVELTY (mode, novelty);
1431     }
1432   return mode;
1433 }
1434
1435
1436 struct mode_chain
1437 {
1438   struct mode_chain *prev;
1439   tree mode1, mode2;
1440 };
1441
1442 /* Tests if MODE1 and MODE2 are SIMILAR.
1443    This is more or less as defined in the Blue Book, though
1444    see FIXME for parts that are unfinished.
1445    CHAIN is used to catch infinite recursion:  It is a list of pairs
1446    of mode arguments to calls to chill_similar "outer" to this call. */
1447
1448 int
1449 chill_similar (mode1, mode2, chain)
1450      tree mode1, mode2;
1451      struct mode_chain *chain;
1452 {
1453   int varying1, varying2;
1454   tree t1, t2;
1455   struct mode_chain *link, node;
1456   if (mode1 == NULL_TREE || mode2 == NULL_TREE)
1457     return 0;
1458
1459   while (TREE_CODE (mode1) == REFERENCE_TYPE)
1460     mode1 = TREE_TYPE (mode1);
1461   while (TREE_CODE (mode2) == REFERENCE_TYPE)
1462     mode2 = TREE_TYPE (mode2);
1463
1464   /* Range modes are similar to their parent types. */
1465   while (TREE_CODE (mode1) == INTEGER_TYPE && TREE_TYPE (mode1) != NULL_TREE)
1466     mode1 = TREE_TYPE (mode1);
1467   while (TREE_CODE (mode2) == INTEGER_TYPE && TREE_TYPE (mode2) != NULL_TREE)
1468     mode2 = TREE_TYPE (mode2);
1469
1470
1471   /* see Z.200 sections 12.1.2.2 and 13.2 - all integer precisions
1472      are similar to INT and to each other */
1473   if (mode1 == mode2 ||
1474       (TREE_CODE (mode1) == INTEGER_TYPE && TREE_CODE (mode2) == INTEGER_TYPE))
1475     return 1;
1476
1477   /* This guards against certain kinds of recursion.
1478      For example:
1479      SYNMODE a = STRUCT ( next REF a );
1480      SYNMODE b = STRUCT ( next REF b );
1481      These moes are similar, but will get an infite recursion trying
1482      to prove that.  So, if we are recursing, assume the moes are similar.
1483      If they are not, we'll find some other discrepancy.  */
1484   for (link = chain; link != NULL; link = link->prev)
1485     {
1486       if (link->mode1 == mode1 && link->mode2 == mode2)
1487         return 1;
1488     }
1489
1490   node.mode1 = mode1;
1491   node.mode2 = mode2;
1492   node.prev = chain;
1493
1494   varying1 = chill_varying_type_p (mode1);
1495   varying2 = chill_varying_type_p (mode2);
1496   /* FIXME:  This isn't quite strict enough. */
1497   if ((varying1 && varying2)
1498       || (varying1 && TREE_CODE (mode2) == ARRAY_TYPE)
1499       || (varying2 && TREE_CODE (mode1) == ARRAY_TYPE))
1500     return 1;
1501
1502   if (TREE_CODE(mode1) != TREE_CODE(mode2))
1503     {
1504       if (flag_old_strings)
1505         {
1506           /* The recursion is to handle varying strings. */
1507           if ((TREE_CODE (mode1) == CHAR_TYPE
1508                && CH_SIMILAR (mode2, string_one_type_node))
1509               || (TREE_CODE (mode2) == CHAR_TYPE
1510                && CH_SIMILAR (mode1, string_one_type_node)))
1511             return 1;
1512           if ((TREE_CODE (mode1) == BOOLEAN_TYPE
1513                && CH_SIMILAR (mode2, bitstring_one_type_node))
1514               || (TREE_CODE (mode2) == BOOLEAN_TYPE
1515                && CH_SIMILAR (mode1, bitstring_one_type_node)))
1516             return 1;
1517         }
1518       if (TREE_CODE (mode1) == FUNCTION_TYPE
1519           && TREE_CODE (mode2) == POINTER_TYPE
1520           && TREE_CODE (TREE_TYPE (mode2)) == FUNCTION_TYPE)
1521         mode2 = TREE_TYPE (mode2);
1522       else if (TREE_CODE (mode2) == FUNCTION_TYPE
1523           && TREE_CODE (mode1) == POINTER_TYPE
1524           && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE)
1525         mode1 = TREE_TYPE (mode1);
1526       else
1527         return 0;
1528     }
1529
1530   if (CH_IS_BUFFER_MODE (mode1) && CH_IS_BUFFER_MODE (mode2))
1531     {
1532       tree len1 = max_queue_size (mode1);
1533       tree len2 = max_queue_size (mode2);
1534       return tree_int_cst_equal (len1, len2);
1535     }
1536   else if (CH_IS_EVENT_MODE (mode1) && CH_IS_EVENT_MODE (mode2))
1537     {
1538       tree len1 = max_queue_size (mode1);
1539       tree len2 = max_queue_size (mode2);
1540       return tree_int_cst_equal (len1, len2);
1541     }
1542   else if (CH_IS_ACCESS_MODE (mode1) && CH_IS_ACCESS_MODE (mode2))
1543     {
1544       tree index1 = access_indexmode (mode1);
1545       tree index2 = access_indexmode (mode2);
1546       tree record1 = access_recordmode (mode1);
1547       tree record2 = access_recordmode (mode2);
1548       if (! chill_read_compatible (index1, index2))
1549         return 0;
1550       return chill_read_compatible (record1, record2);
1551     }
1552   switch ((enum chill_tree_code)TREE_CODE (mode1))
1553     {
1554     case INTEGER_TYPE:
1555     case BOOLEAN_TYPE:
1556     case CHAR_TYPE:
1557       return 1;
1558     case ENUMERAL_TYPE:
1559       if (TYPE_VALUES (mode1) == TYPE_VALUES (mode2))
1560         return 1;
1561       else
1562         {
1563           /* FIXME: This is more strict than z.200, which seems to
1564              allow the elements to be reordered, as long as they
1565              have the same values. */
1566
1567           tree field1 = TYPE_VALUES (mode1);
1568           tree field2 = TYPE_VALUES (mode2);
1569
1570           while (field1 != NULL_TREE && field2 != NULL_TREE)
1571             {
1572               tree value1, value2;
1573               /* Check that the names are equal.  */
1574               if (TREE_PURPOSE (field1) != TREE_PURPOSE (field2))
1575                 break;
1576
1577               value1 = TREE_VALUE (field1);
1578               value2 = TREE_VALUE (field2);
1579               /* This isn't quite sufficient in general, but will do ... */
1580               /* Note that proclaim_decl can cause the SET modes to be
1581                  compared BEFORE they are satisfied, but otherwise
1582                  chill_similar is mostly called after satisfaction. */
1583               if (TREE_CODE (value1) == CONST_DECL)
1584                 value1 = DECL_INITIAL (value1);
1585               if (TREE_CODE (value2) == CONST_DECL)
1586                 value2 = DECL_INITIAL (value2);
1587               /* Check that the values are equal or both NULL.  */
1588               if (!(value1 == NULL_TREE && value2 == NULL_TREE)
1589                   && (value1 == NULL_TREE || value2 == NULL_TREE
1590                       || ! tree_int_cst_equal (value1, value2)))
1591                 break;
1592               field1 = TREE_CHAIN (field1);
1593               field2 = TREE_CHAIN (field2);
1594             }
1595           return field1 == NULL_TREE && field2 == NULL_TREE;
1596         }
1597     case SET_TYPE:
1598       /* check for bit strings */
1599       if (CH_BOOLS_TYPE_P (mode1))
1600         return CH_BOOLS_TYPE_P (mode2);
1601       if (CH_BOOLS_TYPE_P (mode2))
1602         return CH_BOOLS_TYPE_P (mode1);
1603       /* both are powerset modes */
1604       return CH_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2));
1605
1606     case POINTER_TYPE:
1607       /* Are the referenced modes equivalent? */
1608       return !integer_zerop (chill_equivalent (TREE_TYPE (mode1),
1609                                                TREE_TYPE (mode2),
1610                                                &node));
1611
1612     case ARRAY_TYPE:
1613       /* char for char strings */
1614       if (CH_CHARS_TYPE_P (mode1))
1615         return CH_CHARS_TYPE_P (mode2);
1616       if (CH_CHARS_TYPE_P (mode2))
1617         return CH_CHARS_TYPE_P (mode1);
1618       /* array modes */
1619       if (CH_V_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2))
1620           /* Are the elements modes equivalent? */
1621           && !integer_zerop (chill_equivalent (TREE_TYPE (mode1),
1622                                                TREE_TYPE (mode2),
1623                                                &node)))
1624         {
1625           /* FIXME:  Check that element layouts are equivalent */
1626
1627           tree count1 = fold (build (MINUS_EXPR, sizetype,
1628                                      TYPE_MAX_VALUE (TYPE_DOMAIN (mode1)),
1629                                      TYPE_MIN_VALUE (TYPE_DOMAIN (mode1))));
1630           tree count2 = fold (build (MINUS_EXPR, sizetype,
1631                                      TYPE_MAX_VALUE (TYPE_DOMAIN (mode2)),
1632                                      TYPE_MIN_VALUE (TYPE_DOMAIN (mode2))));
1633           tree cond = build_compare_discrete_expr (EQ_EXPR, count1, count2);
1634           if (TREE_CODE (cond) == INTEGER_CST)
1635             return !integer_zerop (cond);
1636           else
1637             {
1638 #if 0
1639               extern int ignoring;
1640               if (!ignoring
1641                   && range_checking
1642                   && current_function_decl)
1643                 return cond;
1644 #endif
1645               return 1;
1646             }
1647         }
1648       return 0;
1649
1650     case RECORD_TYPE:
1651     case UNION_TYPE:
1652       for (t1 = TYPE_FIELDS (mode1), t2 = TYPE_FIELDS (mode2);
1653            t1 && t2;  t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2))
1654            {
1655              if (TREE_CODE (t1) != TREE_CODE (t2))
1656                return 0;
1657              /* Are the field modes equivalent? */
1658              if (integer_zerop (chill_equivalent (TREE_TYPE (t1),
1659                                                    TREE_TYPE (t2),
1660                                                    &node)))
1661                return 0;
1662            }
1663       return t1 == t2;
1664
1665     case FUNCTION_TYPE:
1666       if (!chill_l_equivalent (TREE_TYPE (mode1), TREE_TYPE (mode2), &node))
1667         return 0;
1668       for (t1 = TYPE_ARG_TYPES (mode1), t2 = TYPE_ARG_TYPES (mode2);
1669            t1 != NULL_TREE && t2 != NULL_TREE;
1670            t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2))
1671         {
1672           tree attr1 = TREE_PURPOSE (t1)
1673             ? TREE_PURPOSE (t1) : ridpointers[(int) RID_IN];
1674           tree attr2 = TREE_PURPOSE (t2)
1675             ? TREE_PURPOSE (t2) : ridpointers[(int) RID_IN];
1676           if (attr1 != attr2)
1677             return 0;
1678           if (!chill_l_equivalent (TREE_VALUE (t1), TREE_VALUE (t2), &node))
1679             return 0;
1680         }
1681       if (t1 != t2) /* Both NULL_TREE */
1682         return 0;
1683       /* check list of exception names */
1684       t1 = TYPE_RAISES_EXCEPTIONS (mode1);
1685       t2 = TYPE_RAISES_EXCEPTIONS (mode2);
1686       if (t1 == NULL_TREE && t2 != NULL_TREE)
1687         return 0;
1688       if (t1 != NULL_TREE && t2 == NULL_TREE)
1689         return 0;
1690       if (list_length (t1) != list_length (t2))
1691         return 0;
1692       while (t1 != NULL_TREE)
1693         {
1694           if (value_member (TREE_VALUE (t1), t2) == NULL_TREE)
1695             return 0;
1696           t1 = TREE_CHAIN (t1);
1697         }
1698       /* FIXME:  Should also check they have the same RECURSIVITY */
1699       return 1;
1700
1701     default:
1702       ;
1703 #if 0
1704       /* Need to handle row modes, instance modes,
1705          association modes, access modes, text modes,
1706          duration modes, absolute time modes, structure modes,
1707          parameterized structure modes */
1708 #endif
1709     }
1710   return 1;
1711 }
1712
1713 /* Return a node that is true iff MODE1 and MODE2 are equivalent.
1714    This is normally boolean_true_node or boolean_false_node,
1715    but can be dynamic for dynamic types.
1716    CHAIN is as for chill_similar.  */
1717
1718 tree
1719 chill_equivalent (mode1, mode2, chain)
1720      tree mode1, mode2;
1721      struct mode_chain *chain;
1722 {
1723   int varying1, varying2;
1724   int is_string1, is_string2;
1725   tree base_mode1, base_mode2;
1726
1727   /* Are the modes v-equivalent? */
1728 #if 0
1729   if (!chill_similar (mode1, mode2, chain)
1730       || CH_NOVELTY(mode1) != CH_NOVELTY(mode2))
1731     return boolean_false_node;
1732 #endif
1733   if (!chill_similar (mode1, mode2, chain))
1734     return boolean_false_node;
1735   else if (TREE_CODE (mode2) == FUNCTION_TYPE
1736            && TREE_CODE (mode1) == POINTER_TYPE
1737            && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE)
1738     /* don't check novelty in this case to avoid error in case of
1739        NEWMODE'd proceduremode gets assigned a function */
1740     return boolean_true_node;
1741   else if (CH_NOVELTY(mode1) != CH_NOVELTY(mode2))
1742     return boolean_false_node;
1743
1744   varying1 = chill_varying_type_p (mode1);
1745   varying2 = chill_varying_type_p (mode2);
1746
1747   if (varying1 != varying2)
1748     return boolean_false_node;
1749   base_mode1 = varying1 ? CH_VARYING_ARRAY_TYPE (mode1) : mode1;
1750   base_mode2 = varying2 ? CH_VARYING_ARRAY_TYPE (mode2) : mode2;
1751   is_string1 = CH_STRING_TYPE_P (base_mode1);
1752   is_string2 = CH_STRING_TYPE_P (base_mode2);
1753   if (is_string1 || is_string2)
1754     {
1755       if (is_string1 != is_string2)
1756         return boolean_false_node;
1757       return fold (build (EQ_EXPR, boolean_type_node,
1758                           TYPE_SIZE (base_mode1),
1759                           TYPE_SIZE (base_mode2)));
1760     }
1761
1762   /* && some more stuff FIXME! */
1763   if (TREE_CODE(mode1) == INTEGER_TYPE || TREE_CODE(mode2) == INTEGER_TYPE)
1764     {
1765       if (TREE_CODE(mode1) != INTEGER_TYPE || TREE_CODE(mode2) != INTEGER_TYPE)
1766         return boolean_false_node;
1767       /* If one is a range, the other has to be a range. */
1768       if ((TREE_TYPE (mode1) != NULL_TREE) != (TREE_TYPE (mode2) != NULL_TREE))
1769         return boolean_false_node;
1770       if (TYPE_PRECISION (mode1) != TYPE_PRECISION (mode2))
1771         return boolean_false_node;
1772       if (!tree_int_cst_equal (TYPE_MIN_VALUE (mode1), TYPE_MIN_VALUE (mode2)))
1773         return boolean_false_node;
1774       if (!tree_int_cst_equal (TYPE_MAX_VALUE (mode1), TYPE_MAX_VALUE (mode2)))
1775         return boolean_false_node;
1776     }
1777   return boolean_true_node;
1778 }
1779
1780 static int
1781 chill_l_equivalent (mode1, mode2, chain)
1782      tree mode1, mode2;
1783      struct mode_chain *chain;
1784 {
1785   /* Are the modes equivalent? */
1786   if (integer_zerop (chill_equivalent (mode1, mode2, chain)))
1787     return 0;
1788   if (TYPE_READONLY (mode1) != TYPE_READONLY (mode2))
1789     return 0;
1790 #if 0
1791   ... other conditions ...;
1792 #endif
1793   return 1;
1794 }
1795
1796 /* See Z200 12.1.2.12 */
1797
1798 int
1799 chill_read_compatible (modeM, modeN)
1800      tree modeM, modeN;
1801 {
1802   while (TREE_CODE (modeM) == REFERENCE_TYPE)
1803     modeM = TREE_TYPE (modeM);
1804   while (TREE_CODE (modeN) == REFERENCE_TYPE)
1805     modeN = TREE_TYPE (modeN);
1806
1807   if (!CH_EQUIVALENT (modeM, modeN))
1808     return 0;
1809   if (TYPE_READONLY (modeN))
1810     {
1811       if (!TYPE_READONLY (modeM))
1812         return 0;
1813       if (CH_IS_BOUND_REFERENCE_MODE (modeM)
1814           && CH_IS_BOUND_REFERENCE_MODE (modeN))
1815         {
1816           return chill_l_equivalent (TREE_TYPE (modeM), TREE_TYPE (modeN), 0);
1817         }
1818 #if 0
1819       ...;
1820 #endif
1821     }
1822   return 1;
1823 }
1824
1825 /* Tests if MODE is compatible with the class of EXPR.
1826    Cfr. Chill Blue Book 12.1.2.15. */
1827
1828 int
1829 chill_compatible (expr, mode)
1830      tree expr, mode;
1831 {
1832   struct ch_class class;
1833
1834   if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
1835     return 0;
1836   if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK)
1837     return 0;
1838
1839   while (TREE_CODE (mode) == REFERENCE_TYPE)
1840     mode = TREE_TYPE (mode);
1841
1842   if (TREE_TYPE (expr) == NULL_TREE)
1843     {
1844       if (TREE_CODE (expr) == CONSTRUCTOR)
1845         return TREE_CODE (mode) == RECORD_TYPE
1846           || ((TREE_CODE (mode) == SET_TYPE || TREE_CODE (mode) == ARRAY_TYPE)
1847               && ! TYPE_STRING_FLAG (mode));
1848       else
1849         return TREE_CODE (expr) == CASE_EXPR || TREE_CODE (expr) == COND_EXPR;
1850     }
1851
1852   class = chill_expr_class (expr);
1853   switch (class.kind)
1854     {
1855     case CH_ALL_CLASS:
1856       return 1;
1857     case CH_NULL_CLASS:
1858       return CH_IS_REFERENCE_MODE (mode) || CH_IS_PROCEDURE_MODE (mode)
1859         || CH_IS_INSTANCE_MODE (mode);
1860     case CH_VALUE_CLASS:
1861       if (CH_HAS_REFERENCING_PROPERTY (mode))
1862         return CH_RESTRICTABLE_TO(mode, class.mode);
1863       else
1864         return CH_V_EQUIVALENT(mode, class.mode);
1865     case CH_DERIVED_CLASS:
1866       return CH_SIMILAR (class.mode, mode);
1867     case CH_REFERENCE_CLASS:
1868       if (!CH_IS_REFERENCE_MODE (mode))
1869         return 0;
1870 #if 0
1871       /* FIXME! */
1872       if (class.mode is a row mode)
1873         ...;
1874       else if (class.mode is not a static mode)
1875         return 0; /* is this possible? FIXME */
1876 #endif
1877       return !CH_IS_BOUND_REFERENCE_MODE(mode)
1878         || CH_READ_COMPATIBLE (TREE_TYPE (mode), class.mode);
1879     }
1880   return 0; /* ERROR! */
1881 }
1882
1883 /* Tests if the class of of EXPR1 and EXPR2 are compatible.
1884    Cfr. Chill Blue Book 12.1.2.16. */
1885
1886 int
1887 chill_compatible_classes (expr1, expr2)
1888      tree expr1, expr2;
1889 {
1890   struct ch_class temp;
1891   struct ch_class class1, class2;
1892   class1 = chill_expr_class (expr1);
1893   class2 = chill_expr_class (expr2);
1894
1895   switch (class1.kind)
1896     {
1897     case CH_ALL_CLASS:
1898       return 1;
1899     case CH_NULL_CLASS:
1900       switch (class2.kind)
1901         {
1902         case CH_ALL_CLASS:
1903         case CH_NULL_CLASS:
1904         case CH_REFERENCE_CLASS:
1905           return 1;
1906         case CH_VALUE_CLASS:
1907         case CH_DERIVED_CLASS:
1908           goto rule4;
1909         }
1910     case CH_REFERENCE_CLASS:
1911       switch (class2.kind)
1912         {
1913         case CH_ALL_CLASS:
1914         case CH_NULL_CLASS:
1915           return 1;
1916         case CH_REFERENCE_CLASS:
1917           return CH_EQUIVALENT (class1.mode, class2.mode);
1918         case CH_VALUE_CLASS:
1919           goto rule6;
1920         case CH_DERIVED_CLASS:
1921           return 0;
1922         }
1923     case CH_DERIVED_CLASS:
1924       switch (class2.kind)
1925         {
1926         case CH_ALL_CLASS:
1927           return 1;
1928         case CH_VALUE_CLASS:
1929         case CH_DERIVED_CLASS:
1930           return CH_SIMILAR (class1.mode, class2.mode);
1931         case CH_NULL_CLASS:
1932           class2 = class1;
1933           goto rule4;
1934         case CH_REFERENCE_CLASS:
1935           return 0;
1936         }
1937     case CH_VALUE_CLASS:
1938       switch (class2.kind)
1939         {
1940         case CH_ALL_CLASS:
1941           return 1;
1942         case CH_DERIVED_CLASS:
1943           return CH_SIMILAR (class1.mode, class2.mode);
1944         case CH_VALUE_CLASS:
1945           return CH_V_EQUIVALENT (class1.mode, class2.mode);
1946         case CH_NULL_CLASS:
1947           class2 = class1;
1948           goto rule4;
1949         case CH_REFERENCE_CLASS:
1950           temp = class1;  class1 = class2;  class2 = temp;
1951           goto rule6;
1952         }
1953     }
1954  rule4:
1955   /* The Null class is Compatible with the M-derived class or M-value class
1956      if and only if M is a reference mdoe, procedure mode or instance mode.*/
1957   return CH_IS_REFERENCE_MODE (class2.mode)
1958     || CH_IS_PROCEDURE_MODE (class2.mode)
1959     || CH_IS_INSTANCE_MODE (class2.mode);
1960
1961  rule6:
1962   /* The M-reference class is compatible with the N-value class if and
1963      only if N is a reference mode and ... */
1964   if (!CH_IS_REFERENCE_MODE (class2.mode))
1965     return 0;
1966   if (1) /* If M is a static mode - FIXME */
1967     {
1968       if (!CH_IS_BOUND_REFERENCE_MODE (class2.mode))
1969         return 1;
1970       if (CH_EQUIVALENT (TREE_TYPE (class2.mode), class1.mode))
1971         return 1;
1972     }
1973   /* If N is a row mode whose .... FIXME */
1974   return 0;
1975 }
1976
1977 /* Cfr.  Blue Book 12.1.1.6, with some "extensions." */
1978
1979 tree
1980 chill_root_mode (mode)
1981      tree mode;
1982 {
1983   /* Reference types are not user-visible types.
1984      This seems like a good place to get rid of them. */
1985   if (TREE_CODE (mode) == REFERENCE_TYPE)
1986     mode = TREE_TYPE (mode);
1987
1988   while (TREE_CODE (mode) == INTEGER_TYPE && TREE_TYPE (mode) != NULL_TREE)
1989     mode = TREE_TYPE (mode);  /* a sub-range */
1990
1991   /* This extension in not in the Blue Book - which only has a
1992      single Integer type.
1993      We should probably use chill_integer_type_node rather
1994      than integer_type_node, but that is likely to bomb.
1995      At some point, these will become the same, I hope. FIXME */
1996   if (TREE_CODE (mode) == INTEGER_TYPE
1997       && TYPE_PRECISION (mode) < TYPE_PRECISION (integer_type_node)
1998       && CH_NOVELTY (mode) == NULL_TREE)
1999     mode = integer_type_node;
2000
2001   if (TREE_CODE (mode) == FUNCTION_TYPE)
2002     return build_pointer_type (mode);
2003
2004   return mode;
2005 }
2006
2007 /* Cfr.  Blue Book 12.1.1.7. */
2008
2009 tree
2010 chill_resulting_mode (mode1, mode2)
2011      tree mode1, mode2;
2012 {
2013   mode1 = CH_ROOT_MODE (mode1);
2014   mode2 = CH_ROOT_MODE (mode2);
2015   if (chill_varying_type_p (mode1))
2016     return mode1;
2017   if (chill_varying_type_p (mode2))
2018     return mode2;
2019   return mode1;
2020 }
2021
2022 /* Cfr.  Blue Book (z200, 1988) 12.1.1.7 Resulting class. */
2023
2024 struct ch_class
2025 chill_resulting_class (class1, class2)
2026      struct ch_class class1, class2;
2027 {
2028   struct ch_class class;
2029   switch (class1.kind)
2030     {
2031     case CH_VALUE_CLASS:
2032       switch (class2.kind)
2033         {
2034         case CH_DERIVED_CLASS:
2035         case CH_ALL_CLASS:
2036           class.kind = CH_VALUE_CLASS;
2037           class.mode = CH_ROOT_MODE (class1.mode);
2038           return class;
2039         case CH_VALUE_CLASS:
2040           class.kind = CH_VALUE_CLASS;
2041           class.mode
2042             = CH_ROOT_MODE (CH_RESULTING_MODE (class1.mode, class2.mode));
2043           return class;
2044         default:
2045           break;
2046         }
2047       break;
2048     case CH_DERIVED_CLASS:
2049       switch (class2.kind)
2050         {
2051         case CH_VALUE_CLASS:
2052           class.kind = CH_VALUE_CLASS;
2053           class.mode = CH_ROOT_MODE (class2.mode);
2054           return class;
2055         case CH_DERIVED_CLASS:
2056           class.kind = CH_DERIVED_CLASS;
2057           class.mode = CH_RESULTING_MODE (class1.mode, class2.mode);
2058           return class;
2059         case CH_ALL_CLASS:
2060           class.kind = CH_DERIVED_CLASS;
2061           class.mode = CH_ROOT_MODE (class1.mode);
2062           return class;
2063         default:
2064           break;
2065         }
2066       break;
2067     case CH_ALL_CLASS:
2068       switch (class2.kind)
2069         {
2070         case CH_VALUE_CLASS:
2071           class.kind = CH_VALUE_CLASS;
2072           class.mode = CH_ROOT_MODE (class2.mode);
2073           return class;
2074         case CH_ALL_CLASS:
2075           class.kind = CH_ALL_CLASS;
2076           class.mode = NULL_TREE;
2077           return class;
2078         case CH_DERIVED_CLASS:
2079           class.kind = CH_DERIVED_CLASS;
2080           class.mode = CH_ROOT_MODE (class2.mode);
2081           return class;
2082         default:
2083           break;
2084         }
2085       break;
2086     default:
2087       break;
2088     }
2089   error ("internal error in chill_root_resulting_mode");
2090   class.kind = CH_VALUE_CLASS;
2091   class.mode = CH_ROOT_MODE (class1.mode);
2092   return class;
2093 }
2094 \f
2095
2096 /*
2097  * See Z.200, section 6.3, static conditions. This function
2098  * returns bool_false_node if the condition is not met at compile time,
2099  *         bool_true_node if the condition is detectably met at compile time
2100  *         an expression if a runtime check would be required or was generated.
2101  * It should only be called with string modes and values.
2102  */
2103 tree
2104 string_assignment_condition (lhs_mode, rhs_value)
2105      tree lhs_mode, rhs_value;
2106 {
2107   tree lhs_size, rhs_size, cond;
2108   tree rhs_mode = TREE_TYPE (rhs_value);
2109   int lhs_varying = chill_varying_type_p (lhs_mode);
2110
2111   if (lhs_varying)
2112     lhs_size = size_in_bytes (CH_VARYING_ARRAY_TYPE (lhs_mode));
2113   else if (CH_BOOLS_TYPE_P (lhs_mode))
2114     lhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (lhs_mode));
2115   else
2116     lhs_size = size_in_bytes (lhs_mode);
2117   lhs_size = convert (chill_unsigned_type_node, lhs_size);
2118
2119   if (rhs_mode && TREE_CODE (rhs_mode) == REFERENCE_TYPE)
2120     rhs_mode = TREE_TYPE (rhs_mode);
2121   if (rhs_mode == NULL_TREE)
2122     {
2123       /* actually, count constructor's length */
2124       abort ();
2125     }
2126   else if (chill_varying_type_p (rhs_mode))
2127     rhs_size = build_component_ref (rhs_value, var_length_id);
2128   else if (CH_BOOLS_TYPE_P (rhs_mode))
2129     rhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (rhs_mode));
2130   else
2131     rhs_size = size_in_bytes (rhs_mode);
2132   rhs_size = convert (chill_unsigned_type_node, rhs_size);
2133
2134   /* validity condition */
2135   cond = fold (build (lhs_varying ? GE_EXPR : EQ_EXPR,
2136            boolean_type_node, lhs_size, rhs_size));
2137   return cond;
2138 }
2139 \f
2140 /*
2141  * take a basic CHILL type and wrap it in a VARYING structure.
2142  * Be sure the length field is initialized.  Return the wrapper.
2143  */
2144 tree
2145 build_varying_struct (type)
2146      tree type;
2147 {
2148   tree decl1, decl2, result;
2149
2150   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
2151     return error_mark_node;
2152
2153   decl1 = build_decl (FIELD_DECL, var_length_id, chill_integer_type_node);
2154   decl2 = build_decl (FIELD_DECL, var_data_id, type);
2155   TREE_CHAIN (decl1) = decl2;
2156   TREE_CHAIN (decl2) = NULL_TREE;
2157   result = build_chill_struct_type (decl1);
2158
2159   /* mark this so we don't complain about missing initializers.
2160      It's fine for a VARYING array to be partially initialized.. */
2161   C_TYPE_VARIABLE_SIZE(type) = 1;
2162   return result;
2163 }
2164
2165
2166 /*
2167  * This is the struct type that forms the runtime initializer
2168  * list.  There's at least one of these generated per module.
2169  * It's attached to the global initializer list by the module's
2170  * 'constructor' code.  Should only be called in pass 2.
2171  */
2172 tree
2173 build_init_struct ()
2174 {
2175   tree decl1, decl2, result;
2176   /* We temporarily reset the maximum_field_alignment to zero so the
2177      compiler's init data structures can be compatible with the
2178      run-time system, even when we're compiling with -fpack. */
2179   extern int maximum_field_alignment;
2180   int save_maximum_field_alignment = maximum_field_alignment;
2181   maximum_field_alignment = 0;
2182
2183   decl1 = build_decl (FIELD_DECL, get_identifier ("__INIT_ENTRY"),
2184             build_chill_pointer_type (
2185               build_function_type (void_type_node, NULL_TREE)));
2186
2187   decl2 = build_decl (FIELD_DECL, get_identifier ("__INIT_NEXT"),
2188                       build_chill_pointer_type (void_type_node));
2189
2190   TREE_CHAIN (decl1) = decl2;
2191   TREE_CHAIN (decl2) = NULL_TREE;
2192   result = build_chill_struct_type (decl1);
2193   maximum_field_alignment = save_maximum_field_alignment;
2194   return result;
2195 }
2196 \f
2197 \f
2198 /*
2199  * Return 1 if the given type is a single-bit boolean set,
2200  *          in which the domain's min and max values
2201  *          are both zero,
2202  *        0 if not.  This can become a macro later..
2203  */
2204 int
2205 ch_singleton_set (type)
2206      tree type;
2207 {
2208   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
2209     return 0;
2210   if (TREE_CODE (type) != SET_TYPE)
2211     return 0;
2212   if (TREE_TYPE (type) == NULL_TREE
2213       || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE)
2214     return 0;
2215   if (TYPE_DOMAIN (type) == NULL_TREE)
2216     return 0;
2217   if (! tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
2218                             integer_zero_node))
2219     return 0;
2220   if (! tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
2221                             integer_zero_node))
2222     return 0;
2223   return 1;
2224 }
2225 \f
2226 /* return non-zero if TYPE is a compiler-generated VARYING
2227    array of some base type */
2228 int
2229 chill_varying_type_p (type)
2230      tree type;
2231 {
2232   if (type == NULL_TREE)
2233     return 0;
2234   if (TREE_CODE (type) != RECORD_TYPE)
2235     return 0;
2236   if (TYPE_FIELDS (type) == NULL_TREE
2237       || TREE_CHAIN (TYPE_FIELDS (type)) == NULL_TREE)
2238     return 0;
2239   if (DECL_NAME (TYPE_FIELDS (type)) != var_length_id)
2240     return 0;
2241   if (DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) != var_data_id)
2242     return 0;
2243   if (TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))) != NULL_TREE)
2244     return 0;
2245   return 1;
2246 }
2247
2248 /* return non-zero if TYPE is a compiler-generated VARYING
2249    string record */
2250 int
2251 chill_varying_string_type_p (type)
2252      tree type;
2253 {
2254   tree var_data_type;
2255
2256   if (!chill_varying_type_p (type))
2257       return 0;
2258
2259   var_data_type = CH_VARYING_ARRAY_TYPE (type);
2260   return CH_CHARS_TYPE_P (var_data_type);
2261 }
2262 \f
2263 /* swiped from c-typeck.c */
2264 /* Build an assignment expression of lvalue LHS from value RHS. */
2265
2266 tree
2267 build_chill_modify_expr (lhs, rhs)
2268      tree lhs, rhs;
2269 {
2270   register tree result;
2271
2272
2273   tree lhstype = TREE_TYPE (lhs);
2274
2275   /* Avoid duplicate error messages from operands that had errors.  */
2276   if (lhs == NULL_TREE || TREE_CODE (lhs) == ERROR_MARK || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK)
2277     return error_mark_node;
2278
2279   /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue.  */
2280   /* Do not use STRIP_NOPS here.  We do not want an enumerator
2281      whose value is 0 to count as a null pointer constant.  */
2282   if (TREE_CODE (rhs) == NON_LVALUE_EXPR)
2283     rhs = TREE_OPERAND (rhs, 0);
2284
2285 #if 0
2286   /* Handle a cast used as an "lvalue".
2287      We have already performed any binary operator using the value as cast.
2288      Now convert the result to the cast type of the lhs,
2289      and then true type of the lhs and store it there;
2290      then convert result back to the cast type to be the value
2291      of the assignment.  */
2292
2293   switch (TREE_CODE (lhs))
2294     {
2295     case NOP_EXPR:
2296     case CONVERT_EXPR:
2297     case FLOAT_EXPR:
2298     case FIX_TRUNC_EXPR:
2299     case FIX_FLOOR_EXPR:
2300     case FIX_ROUND_EXPR:
2301     case FIX_CEIL_EXPR:
2302       {
2303         tree inner_lhs = TREE_OPERAND (lhs, 0);
2304         tree result;
2305         result = build_chill_modify_expr (inner_lhs,
2306                    convert (TREE_TYPE (inner_lhs),
2307                      convert (lhstype, rhs)));
2308         pedantic_lvalue_warning (CONVERT_EXPR);
2309         return convert (TREE_TYPE (lhs), result);
2310       }
2311     }
2312
2313   /* Now we have handled acceptable kinds of LHS that are not truly lvalues.
2314      Reject anything strange now.  */
2315
2316   if (!lvalue_or_else (lhs, "assignment"))
2317     return error_mark_node;
2318 #endif
2319   /* FIXME: need to generate a RANGEFAIL if the RHS won't
2320      fit into the LHS. */
2321
2322   if (TREE_CODE (lhs) != VAR_DECL
2323       && ((TREE_CODE (TREE_TYPE (lhs)) == ARRAY_TYPE &&
2324            (TREE_TYPE (rhs) && TREE_CODE (TREE_TYPE (rhs)) == ARRAY_TYPE)) ||
2325           chill_varying_type_p (TREE_TYPE (lhs)) ||
2326           chill_varying_type_p (TREE_TYPE (rhs))))
2327     {
2328       int lhs_varying = chill_varying_type_p (TREE_TYPE (lhs));
2329       int rhs_varying = chill_varying_type_p (TREE_TYPE (rhs));
2330
2331       /* point at actual RHS data's type */
2332       tree rhs_data_type = rhs_varying ?
2333         CH_VARYING_ARRAY_TYPE (TREE_TYPE (rhs)) :
2334           TREE_TYPE (rhs);
2335       {
2336         /* point at actual LHS data's type */
2337         tree lhs_data_type = lhs_varying ?
2338           CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)) :
2339             TREE_TYPE (lhs);
2340
2341         int lhs_bytes = int_size_in_bytes (lhs_data_type);
2342         int rhs_bytes = int_size_in_bytes (rhs_data_type);
2343
2344         /* if both sides not varying, and sizes not dynamically
2345            computed, sizes must *match* */
2346         if (! lhs_varying && ! rhs_varying && lhs_bytes != rhs_bytes
2347             && lhs_bytes > 0 && rhs_bytes > 0)
2348           {
2349             error ("string lengths not equal");
2350             return error_mark_node;
2351           }
2352         /* Must have enough space on LHS for static size of RHS */
2353
2354         if (lhs_bytes > 0 && rhs_bytes > 0
2355             && lhs_bytes < rhs_bytes)
2356           {
2357             if (rhs_varying)
2358               {
2359                 /* FIXME: generate runtime test for room */
2360                 ;
2361               }
2362             else
2363               {
2364                 error ("can't do ARRAY assignment - too large");
2365                 return error_mark_node;
2366               }
2367           }
2368       }
2369
2370       /* now we know the RHS will fit in LHS, build trees for the
2371          emit_block_move parameters */
2372
2373       if (lhs_varying)
2374         rhs = convert (TREE_TYPE (lhs), rhs);
2375       else
2376         {
2377           if (rhs_varying)
2378             rhs = build_component_ref (rhs, var_data_id);
2379
2380           if (! mark_addressable (rhs))
2381             {
2382               error ("rhs of array assignment is not addressable");
2383               return error_mark_node;
2384             }
2385
2386           lhs = force_addr_of (lhs);
2387           rhs = build1 (ADDR_EXPR, const_ptr_type_node, rhs);
2388           return
2389           build_chill_function_call (lookup_name (get_identifier ("memmove")),
2390             tree_cons (NULL_TREE, lhs,
2391               tree_cons (NULL_TREE, rhs,
2392                 tree_cons (NULL_TREE, size_in_bytes (rhs_data_type),
2393                    NULL_TREE))));
2394         }
2395     }
2396
2397   result = build (MODIFY_EXPR, lhstype, lhs, rhs);
2398   TREE_SIDE_EFFECTS (result) = 1;
2399
2400   return result;
2401 }
2402 \f
2403 /* Constructors for pointer, array and function types.
2404    (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are
2405    constructed by language-dependent code, not here.)  */
2406
2407 /* Construct, lay out and return the type of pointers to TO_TYPE.
2408    If such a type has already been constructed, reuse it.  */
2409
2410 tree
2411 make_chill_pointer_type (to_type, code)
2412      tree to_type;
2413      enum tree_code code;  /* POINTER_TYPE or REFERENCE_TYPE */
2414 {
2415   extern struct obstack *current_obstack;
2416   extern struct obstack *saveable_obstack;
2417   extern struct obstack  permanent_obstack;
2418   tree t;
2419   register struct obstack *ambient_obstack = current_obstack;
2420   register struct obstack *ambient_saveable_obstack = saveable_obstack;
2421
2422   /* If TO_TYPE is permanent, make this permanent too.  */
2423   if (TREE_PERMANENT (to_type))
2424     {
2425       current_obstack = &permanent_obstack;
2426       saveable_obstack = &permanent_obstack;
2427     }
2428
2429   t = make_node (code);
2430   TREE_TYPE (t) = to_type;
2431
2432   current_obstack = ambient_obstack;
2433   saveable_obstack = ambient_saveable_obstack;
2434   return t;
2435 }
2436
2437
2438 tree
2439 build_chill_pointer_type (to_type)
2440      tree to_type;
2441 {
2442   int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't';
2443   register tree t = is_type_node ? TYPE_POINTER_TO (to_type) : NULL_TREE;
2444
2445   /* First, if we already have a type for pointers to TO_TYPE, use it.  */
2446
2447   if (t)
2448     return t;
2449
2450   /* We need a new one. */
2451   t = make_chill_pointer_type (to_type, POINTER_TYPE);
2452
2453   /* Lay out the type.  This function has many callers that are concerned
2454      with expression-construction, and this simplifies them all.
2455      Also, it guarantees the TYPE_SIZE is permanent if the type is.  */
2456   if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE))
2457       || pass == 2)
2458     {
2459       /* Record this type as the pointer to TO_TYPE.  */
2460       TYPE_POINTER_TO (to_type) = t;
2461       layout_type (t);
2462     }
2463
2464   return t;
2465 }
2466
2467 tree
2468 build_chill_reference_type (to_type)
2469      tree to_type;
2470 {
2471   int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't';
2472   register tree t = is_type_node ? TYPE_REFERENCE_TO (to_type) : NULL_TREE;
2473
2474   /* First, if we already have a type for references to TO_TYPE, use it.  */
2475
2476   if (t)
2477     return t;
2478
2479   /* We need a new one. */
2480   t = make_chill_pointer_type (to_type, REFERENCE_TYPE);
2481
2482   /* Lay out the type.  This function has many callers that are concerned
2483      with expression-construction, and this simplifies them all.
2484      Also, it guarantees the TYPE_SIZE is permanent if the type is.  */
2485   if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE))
2486       || pass == 2)
2487     {
2488       /* Record this type as the reference to TO_TYPE.  */
2489       TYPE_REFERENCE_TO (to_type) = t;
2490       layout_type (t);
2491       CH_NOVELTY (t) = CH_NOVELTY (to_type);
2492     }
2493
2494   return t;
2495 }
2496 \f
2497 tree
2498 make_chill_range_type (type, lowval, highval)
2499      tree type, lowval, highval;
2500 {
2501   register tree itype = make_node (INTEGER_TYPE);
2502   TREE_TYPE (itype) = type;
2503   TYPE_MIN_VALUE (itype) = lowval;
2504   TYPE_MAX_VALUE (itype) = highval;
2505   return itype;
2506 }
2507
2508 tree
2509 layout_chill_range_type (rangetype, must_be_const)
2510      tree rangetype;
2511      int must_be_const;
2512 {
2513   tree type = TREE_TYPE (rangetype);
2514   tree lowval = TYPE_MIN_VALUE (rangetype);
2515   tree highval = TYPE_MAX_VALUE (rangetype);
2516   int bad_limits = 0;
2517
2518   if (TYPE_SIZE (rangetype) != NULL_TREE)
2519     return rangetype;
2520
2521   /* process BIN */
2522   if (type == ridpointers[(int) RID_BIN])
2523     {
2524       int binsize;
2525
2526       /* make a range out of it */
2527       if (TREE_CODE (highval) != INTEGER_CST)
2528         {
2529           error ("non-constant expression for BIN");
2530           return error_mark_node;
2531         }
2532       binsize = TREE_INT_CST_LOW (highval);
2533       if (binsize < 0)
2534         {
2535           error ("expression for BIN must not be negative");
2536           return error_mark_node;
2537         }
2538       if (binsize > 32)
2539         {
2540           error ("cannot process BIN (>32)");
2541           return error_mark_node;
2542         }
2543       type = ridpointers [(int) RID_RANGE];
2544       lowval = integer_zero_node;
2545       highval = build_int_2 ((1 << binsize) - 1, 0);
2546     }
2547
2548   if (TREE_CODE (lowval) == ERROR_MARK ||
2549       TREE_CODE (highval) == ERROR_MARK)
2550     return error_mark_node;
2551
2552   if (!CH_COMPATIBLE_CLASSES (lowval, highval))
2553     {
2554       error ("bounds of range are not compatible");
2555       return error_mark_node;
2556     }
2557
2558   if (type == string_index_type_dummy)
2559     {
2560       if (TREE_CODE (highval) == INTEGER_CST
2561           && compare_int_csts (LT_EXPR, highval, integer_minus_one_node))
2562         {
2563           error ("negative string length");
2564           highval = integer_minus_one_node;
2565         }
2566       if (compare_int_csts (EQ_EXPR, highval, integer_minus_one_node))
2567         type = integer_type_node;
2568       else
2569         type = sizetype;
2570       TREE_TYPE (rangetype) = type;
2571     }
2572   else if (type == ridpointers[(int) RID_RANGE])
2573     {
2574       /* This isn't 100% right, since the Blue Book definition
2575          uses Resulting Class, rather than Resulting Mode,
2576          but it's close enough. */
2577       type = CH_ROOT_RESULTING_CLASS (lowval, highval).mode;
2578
2579       /* The default TYPE is the type of the constants -
2580          except if the constants are integers, we choose an
2581          integer type that fits. */
2582       if (TREE_CODE (type) == INTEGER_TYPE
2583           && TREE_CODE (lowval) == INTEGER_CST
2584           && TREE_CODE (highval) == INTEGER_CST)
2585         {
2586           /* The logic of this code has been copied from finish_enum
2587              in c-decl.c.  FIXME duplication! */
2588           int precision = 0;
2589           HOST_WIDE_INT maxvalue = TREE_INT_CST_LOW (highval);
2590           HOST_WIDE_INT minvalue = TREE_INT_CST_LOW (lowval);
2591           if (TREE_INT_CST_HIGH (lowval) >= 0
2592               ? tree_int_cst_lt (TYPE_MAX_VALUE (unsigned_type_node), highval)
2593               : (tree_int_cst_lt (lowval, TYPE_MIN_VALUE (integer_type_node))
2594                  || tree_int_cst_lt (TYPE_MAX_VALUE (integer_type_node), highval)))
2595             precision = TYPE_PRECISION (long_long_integer_type_node);
2596           else
2597             {
2598               if (maxvalue > 0)
2599                 precision = floor_log2 (maxvalue) + 1;
2600               if (minvalue < 0)
2601                 {
2602                   /* Compute number of bits to represent magnitude of a
2603                      negative value.  Add one to MINVALUE since range of
2604                      negative numbers includes the power of two.  */
2605                   int negprecision = floor_log2 (-minvalue - 1) + 1;
2606                   if (negprecision > precision)
2607                     precision = negprecision;
2608                   precision += 1;       /* room for sign bit */
2609                 }
2610
2611               if (!precision)
2612                 precision = 1;
2613             }
2614           type = type_for_size (precision, minvalue >= 0);
2615
2616         }
2617       TREE_TYPE (rangetype) = type;
2618     }
2619   else
2620     {
2621       if (!CH_COMPATIBLE (lowval, type))
2622         {
2623           error ("range's lower bound and parent mode don't match");
2624           return integer_type_node;    /* an innocuous fake */
2625         }
2626       if (!CH_COMPATIBLE (highval, type))
2627         {
2628           error ("range's upper bound and parent mode don't match");
2629           return integer_type_node;    /* an innocuous fake */
2630         }
2631     }
2632
2633   if (TREE_CODE (type) == ERROR_MARK)
2634     return type;
2635   else if (TREE_CODE_CLASS (TREE_CODE (type)) != 't')
2636     {
2637       error ("making range from non-mode");
2638       return error_mark_node;
2639     }
2640
2641   if (TREE_CODE (lowval) == REAL_CST || TREE_CODE (highval) == REAL_CST)
2642     {
2643       sorry ("floating point ranges");
2644       return integer_type_node; /* another fake */
2645     }
2646
2647   if (TREE_CODE (lowval) != INTEGER_CST || TREE_CODE (highval) != INTEGER_CST)
2648     {
2649       if (must_be_const)
2650         {
2651           error ("range mode has non-constant limits");
2652           bad_limits = 1;
2653         }
2654     }
2655   else if (tree_int_cst_equal (lowval, integer_zero_node)
2656            && tree_int_cst_equal (highval, integer_minus_one_node))
2657     ; /* do nothing - this is the index type for an empty string */
2658   else if (compare_int_csts (LT_EXPR, highval, TYPE_MIN_VALUE (type)))
2659     {
2660       error ("range's high bound < mode's low bound");
2661       bad_limits = 1;
2662     }
2663   else if (compare_int_csts (GT_EXPR, highval, TYPE_MAX_VALUE (type)))
2664     {
2665       error ("range's high bound > mode's high bound");
2666       bad_limits = 1;
2667     }
2668   else if (compare_int_csts (LT_EXPR, highval, lowval))
2669     {
2670       error ("range mode high bound < range mode low bound");
2671       bad_limits = 1;
2672     }
2673   else if (compare_int_csts (LT_EXPR, lowval, TYPE_MIN_VALUE (type)))
2674     {
2675       error ("range's low bound < mode's low bound");
2676       bad_limits = 1;
2677     }
2678   else if (compare_int_csts (GT_EXPR, lowval, TYPE_MAX_VALUE (type)))
2679     {
2680       error ("range's low bound > mode's high bound");
2681       bad_limits = 1;
2682     }
2683
2684   if (bad_limits)
2685     {
2686       lowval = TYPE_MIN_VALUE (type);
2687       highval = lowval;
2688     }
2689
2690   highval = convert (type, highval);
2691   lowval =  convert (type, lowval);
2692   TYPE_MIN_VALUE (rangetype) = lowval;
2693   TYPE_MAX_VALUE (rangetype) = highval;
2694   TYPE_PRECISION (rangetype) = TYPE_PRECISION (type);
2695   TYPE_MODE (rangetype) = TYPE_MODE (type);
2696   TYPE_SIZE (rangetype) = TYPE_SIZE (type);
2697   TYPE_SIZE_UNIT (rangetype) = TYPE_SIZE_UNIT (type);
2698   TYPE_ALIGN (rangetype) = TYPE_ALIGN (type);
2699   TREE_UNSIGNED (rangetype) = TREE_UNSIGNED (type);
2700   CH_NOVELTY (rangetype) = CH_NOVELTY (type);
2701   return rangetype;
2702 }
2703
2704 /* Build a _TYPE node that has range bounds associated with its values.
2705    TYPE is the base type for the range type. */
2706 tree
2707 build_chill_range_type (type, lowval, highval)
2708      tree type, lowval, highval;
2709 {
2710   tree rangetype;
2711
2712   if (type == NULL_TREE)
2713     type = ridpointers[(int) RID_RANGE];
2714   else if (TREE_CODE (type) == ERROR_MARK)
2715     return error_mark_node;
2716
2717   rangetype = make_chill_range_type (type, lowval, highval);
2718   if (pass != 1)
2719     rangetype = layout_chill_range_type (rangetype, 0);
2720
2721   return rangetype;
2722 }
2723
2724 /* Build a CHILL array type, but with minimal checking etc. */
2725
2726 tree
2727 build_simple_array_type (type, idx, layout)
2728      tree type, idx, layout;
2729 {
2730   tree array_type = make_node (ARRAY_TYPE);
2731   TREE_TYPE (array_type) = type;
2732   TYPE_DOMAIN (array_type) = idx;
2733   TYPE_ATTRIBUTES (array_type) = layout;
2734   if (pass != 1)
2735     array_type = layout_chill_array_type (array_type);
2736   return array_type;
2737 }
2738
2739 static void
2740 apply_chill_array_layout (array_type)
2741      tree array_type;
2742 {
2743   tree layout, temp, what, element_type;
2744   int stepsize=0, word, start_bit=0, length, natural_length;
2745   int stepsize_specified;
2746   int start_bit_error = 0;
2747   int length_error = 0;
2748
2749   layout = TYPE_ATTRIBUTES (array_type);
2750   if (layout == NULL_TREE)
2751     return;
2752
2753   if (layout == integer_zero_node) /* NOPACK */
2754     {
2755       TYPE_PACKED (array_type) = 0;
2756       return;
2757     }
2758
2759   /* Allow for the packing of 1 bit discrete modes at the bit level. */
2760   element_type = TREE_TYPE (array_type);
2761   if (discrete_type_p (element_type)
2762       && get_type_precision (TYPE_MIN_VALUE (element_type),
2763                              TYPE_MAX_VALUE (element_type)) == 1)
2764     natural_length = 1;
2765   else
2766     natural_length = TREE_INT_CST_LOW (TYPE_SIZE (element_type));
2767
2768   if (layout == integer_one_node) /* PACK */
2769     {
2770       if (natural_length == 1)
2771         TYPE_PACKED (array_type) = 1;
2772       return;
2773     }
2774
2775   /* The layout is a STEP (...).
2776      The current implementation restricts STEP specifications to be of the form
2777      STEP(POS(0,0,n),n) where n is the natural size of the element mode. */
2778   stepsize_specified = 0;
2779   temp = TREE_VALUE (layout);
2780   if (TREE_VALUE (temp) != NULL_TREE)
2781     {
2782       if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
2783         error ("Stepsize in STEP must be an integer constant");
2784       else
2785         {
2786           stepsize = TREE_INT_CST_LOW (TREE_VALUE (temp));
2787           if (stepsize <= 0)
2788             error ("Stepsize in STEP must be > 0");
2789           else
2790             stepsize_specified = 1;
2791
2792           if (stepsize != natural_length)
2793             sorry ("Stepsize in STEP must be the natural width of "
2794                    "the array element mode");
2795         }
2796     }
2797
2798   temp = TREE_PURPOSE (temp);
2799   if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
2800     error ("Starting word in POS must be an integer constant");
2801   else
2802     {
2803       word = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
2804       if (word < 0)
2805         error ("Starting word in POS must be >= 0");
2806       if (word != 0)
2807         sorry ("Starting word in POS within STEP must be 0");
2808     }
2809
2810   length = natural_length;
2811   temp = TREE_VALUE (temp);
2812   if (temp != NULL_TREE)
2813     {
2814       int wordsize = TYPE_PRECISION (chill_integer_type_node);
2815       if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
2816         {
2817           error ("Starting bit in POS must be an integer constant");
2818           start_bit_error = 1;
2819         }
2820       else
2821         {
2822           start_bit = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
2823           if (start_bit != 0)
2824             sorry ("Starting bit in POS within STEP must be 0");
2825           if (start_bit < 0)
2826             {
2827               error ("Starting bit in POS must be >= 0");
2828               start_bit = 0;
2829               start_bit_error = 1;
2830             }
2831           else if (start_bit >= wordsize)
2832             {
2833               error ("Starting bit in POS must be < the width of a word");
2834               start_bit = 0;
2835               start_bit_error = 1;
2836             }
2837         }
2838
2839       temp = TREE_VALUE (temp);
2840       if (temp != NULL_TREE)
2841         {
2842           what = TREE_PURPOSE (temp);
2843           if (what == integer_zero_node)
2844             {
2845               if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
2846                 {
2847                   error ("Length in POS must be an integer constant");
2848                   length_error = 1;
2849                 }
2850               else
2851                 {
2852                   length = TREE_INT_CST_LOW (TREE_VALUE (temp));
2853                   if (length <= 0)
2854                     error ("Length in POS must be > 0");
2855                 }
2856             }
2857           else
2858             {
2859               if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
2860                 {
2861                   error ("End bit in POS must be an integer constant");
2862                   length_error = 1;
2863                 }
2864               else
2865                 {
2866                   int end_bit = TREE_INT_CST_LOW (TREE_VALUE (temp));
2867                   if (end_bit < start_bit)
2868                     {
2869                       error ("End bit in POS must be >= the start bit");
2870                       end_bit = wordsize - 1;
2871                       length_error = 1;
2872                     }
2873                   else if (end_bit >= wordsize)
2874                     {
2875                       error ("End bit in POS must be < the width of a word");
2876                       end_bit = wordsize - 1;
2877                       length_error = 1;
2878                     }
2879                   else if (start_bit_error)
2880                     length_error = 1;
2881                   else
2882                     length = end_bit - start_bit + 1;
2883                 }
2884             }
2885           if (! length_error && length != natural_length)
2886             {
2887               sorry ("The length specified on POS within STEP must be "
2888                      "the natural length of the array element type");
2889             }
2890         }
2891     }
2892
2893   if (! length_error && stepsize_specified && stepsize < length)
2894     error ("Step size in STEP must be >= the length in POS");
2895
2896   if (length == 1)
2897     TYPE_PACKED (array_type) = 1;
2898 }
2899
2900 tree
2901 layout_chill_array_type (array_type)
2902      tree array_type;
2903 {
2904   tree itype;
2905   tree element_type = TREE_TYPE (array_type);
2906
2907   if (TREE_CODE (element_type) == ARRAY_TYPE
2908       && TYPE_SIZE (element_type) == 0)
2909     layout_chill_array_type (element_type);
2910
2911   itype = TYPE_DOMAIN (array_type);
2912
2913   if (TREE_CODE (itype) == ERROR_MARK
2914       || TREE_CODE (element_type) == ERROR_MARK)
2915     return error_mark_node;
2916
2917   /* do a lower/upper bound check. */
2918   if (TREE_CODE (itype) == INTEGER_CST)
2919     {
2920       error ("array index must be a range, not a single integer");
2921       return error_mark_node;
2922     }
2923   if (TREE_CODE_CLASS (TREE_CODE (itype)) != 't'
2924       || !discrete_type_p (itype))
2925     {
2926       error ("array index is not a discrete mode");
2927       return error_mark_node;
2928     }
2929
2930   /* apply the array layout, if specified. */
2931   apply_chill_array_layout (array_type);
2932   TYPE_ATTRIBUTES (array_type) = NULL_TREE;
2933
2934   /* Make sure TYPE_POINTER_TO (element_type) is filled in.  */
2935   build_pointer_type (element_type);
2936
2937   if (TYPE_SIZE (array_type) == 0)
2938     layout_type (array_type);
2939
2940   if (TYPE_READONLY_PROPERTY (element_type))
2941     TYPE_FIELDS_READONLY (array_type) = 1;
2942
2943   TYPE_ARRAY_MAX_SIZE (array_type) = size_in_bytes (array_type);
2944   return array_type;
2945 }
2946
2947 /* Build a CHILL array type.
2948
2949    TYPE is the element type of the array.
2950    IDXLIST is the list of dimensions of the array.
2951    VARYING_P is non-zero if the array is a varying array.
2952    LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
2953    meaning (default, pack, nopack, STEP (...) ).  */
2954 tree
2955 build_chill_array_type (type, idxlist, varying_p, layouts)
2956      tree type, idxlist;
2957      int varying_p;
2958      tree layouts;
2959 {
2960   tree array_type = type;
2961
2962   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
2963     return error_mark_node;
2964   if (idxlist == NULL_TREE || TREE_CODE (idxlist) == ERROR_MARK)
2965     return error_mark_node;
2966
2967   /* We have to walk down the list of index decls, building inner
2968      array types as we go. We need to reverse the list of layouts so that the
2969      first layout applies to the last index etc. */
2970   layouts = nreverse (layouts);
2971   for ( ; idxlist; idxlist = TREE_CHAIN (idxlist))
2972     {
2973       if (layouts != NULL_TREE)
2974         {
2975           type = build_simple_array_type (
2976                    type, TREE_VALUE (idxlist), TREE_VALUE (layouts));
2977           layouts = TREE_CHAIN (layouts);
2978         }
2979       else
2980         type = build_simple_array_type (type, TREE_VALUE (idxlist), NULL_TREE);
2981     }
2982   array_type = type;
2983   if (varying_p)
2984     array_type = build_varying_struct (array_type);
2985   return array_type;
2986 }
2987
2988 /* Function to help qsort sort FIELD_DECLs by name order.  */
2989
2990 static int
2991 field_decl_cmp (x, y)
2992      tree *x, *y;
2993 {
2994   return (long)DECL_NAME (*x) - (long)DECL_NAME (*y);
2995 }
2996
2997 tree
2998 make_chill_struct_type (fieldlist)
2999      tree fieldlist;
3000 {
3001   tree t, x;
3002   if (TREE_UNION_ELEM (fieldlist))
3003     t = make_node (UNION_TYPE);
3004   else
3005     t = make_node (RECORD_TYPE);
3006   /* Install struct as DECL_CONTEXT of each field decl. */
3007   for (x = fieldlist; x; x = TREE_CHAIN (x))
3008     {
3009       DECL_CONTEXT (x) = t;
3010       DECL_FIELD_SIZE (x) = 0;
3011     }
3012
3013   /* Delete all duplicate fields from the fieldlist */
3014   for (x = fieldlist; x && TREE_CHAIN (x);)
3015     /* Anonymous fields aren't duplicates.  */
3016     if (DECL_NAME (TREE_CHAIN (x)) == 0)
3017       x = TREE_CHAIN (x);
3018     else
3019       {
3020         register tree y = fieldlist;
3021
3022         while (1)
3023           {
3024             if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x)))
3025               break;
3026             if (y == x)
3027               break;
3028             y = TREE_CHAIN (y);
3029           }
3030         if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x)))
3031           {
3032             error_with_decl (TREE_CHAIN (x), "duplicate member `%s'");
3033             TREE_CHAIN (x) = TREE_CHAIN (TREE_CHAIN (x));
3034           }
3035         else x = TREE_CHAIN (x);
3036       }
3037
3038   TYPE_FIELDS (t) = fieldlist;
3039
3040   return t;
3041 }
3042
3043 /* decl is a FIELD_DECL.
3044    DECL_INIT (decl) is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
3045    meaning (default, pack, nopack, POS (...) ).
3046    The return value is a boolean: 1 if POS specified, 0 if not */
3047 static int
3048 apply_chill_field_layout (decl, next_struct_offset)
3049      tree decl;
3050      int* next_struct_offset;
3051 {
3052   tree layout, type, temp, what;
3053   int word = 0, wordsize, start_bit, offset, length, natural_length;
3054   int pos_error = 0;
3055   int is_discrete;
3056
3057   type = TREE_TYPE (decl);
3058   is_discrete = discrete_type_p (type);
3059   if (is_discrete)
3060     natural_length = get_type_precision (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
3061   else
3062     natural_length = TREE_INT_CST_LOW (TYPE_SIZE (type));
3063
3064   layout = DECL_INITIAL (decl);
3065   if (layout == integer_zero_node) /* NOPACK */
3066     {
3067       DECL_PACKED (decl) = 0;
3068       *next_struct_offset += natural_length;
3069       return 0; /* not POS */
3070     }
3071
3072   if (layout == integer_one_node) /* PACK */
3073     {
3074       if (is_discrete)
3075         DECL_BIT_FIELD (decl) = 1;
3076       else
3077         {
3078           DECL_BIT_FIELD (decl) = 0;
3079           DECL_ALIGN (decl) = BITS_PER_UNIT;
3080         }
3081       DECL_PACKED (decl) = 1;
3082       DECL_FIELD_SIZE (decl) = natural_length;
3083       *next_struct_offset += natural_length;
3084       return 0; /* not POS */
3085     }
3086
3087   /* The layout is a POS (...). The current implementation restricts the use
3088      of POS to monotonically increasing fields whose width must be the
3089      natural width of the underlying type. */
3090   temp = TREE_PURPOSE (layout);
3091
3092   if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
3093     {
3094       error ("Starting word in POS must be an integer constant");
3095       pos_error = 1;
3096     }
3097   else
3098     {
3099       word = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
3100       if (word < 0)
3101         {
3102           error ("Starting word in POS must be >= 0");
3103           word = 0;
3104           pos_error = 1;
3105         }
3106     }
3107
3108   wordsize = TYPE_PRECISION (chill_integer_type_node);
3109   offset = word * wordsize;
3110   length = natural_length;
3111
3112   temp = TREE_VALUE (temp);
3113   if (temp != NULL_TREE)
3114     {
3115       if (TREE_CODE (TREE_PURPOSE (temp)) != INTEGER_CST)
3116         {
3117           error ("Starting bit in POS must be an integer constant");
3118           start_bit = *next_struct_offset - offset;
3119           pos_error = 1;
3120         }
3121       else
3122         {
3123           start_bit = TREE_INT_CST_LOW (TREE_PURPOSE (temp));
3124           if (start_bit < 0)
3125             {
3126               error ("Starting bit in POS must be >= 0");
3127               start_bit = *next_struct_offset - offset;
3128               pos_error = 1;
3129             }
3130           else if (start_bit >= wordsize)
3131             {
3132               error ("Starting bit in POS must be < the width of a word");
3133               start_bit = *next_struct_offset - offset;
3134               pos_error = 1;
3135             }
3136         }
3137
3138       temp = TREE_VALUE (temp);
3139       if (temp != NULL_TREE)
3140         {
3141           what = TREE_PURPOSE (temp);
3142           if (what == integer_zero_node)
3143             {
3144               if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
3145                 {
3146                   error ("Length in POS must be an integer constant");
3147                   pos_error = 1;
3148                 }
3149               else
3150                 {
3151                   length = TREE_INT_CST_LOW (TREE_VALUE (temp));
3152                   if (length <= 0)
3153                     {
3154                       error ("Length in POS must be > 0");
3155                       length = natural_length;
3156                       pos_error = 1;
3157                     }
3158                 }
3159             }
3160           else
3161             {
3162               if (TREE_CODE (TREE_VALUE (temp)) != INTEGER_CST)
3163                 {
3164                   error ("End bit in POS must be an integer constant");
3165                   pos_error = 1;
3166                 }
3167               else
3168                 {
3169                   int end_bit = TREE_INT_CST_LOW (TREE_VALUE (temp));
3170                   if (end_bit < start_bit)
3171                     {
3172                       error ("End bit in POS must be >= the start bit");
3173                       pos_error = 1;
3174                     }
3175                   else if (end_bit >= wordsize)
3176                     {
3177                       error ("End bit in POS must be < the width of a word");
3178                       pos_error = 1;
3179                     }
3180                   else
3181                     length = end_bit - start_bit + 1;
3182                 }
3183             }
3184           if (length != natural_length && ! pos_error)
3185             {
3186               sorry ("The length specified on POS must be the natural length "
3187                      "of the field type");
3188               length = natural_length;
3189             }
3190         }
3191
3192       offset += start_bit;
3193     }
3194
3195   if (offset != *next_struct_offset && ! pos_error)
3196     sorry ("STRUCT fields must be layed out in monotonically increasing order");
3197
3198   DECL_PACKED (decl) = 1;
3199   DECL_BIT_FIELD (decl) = is_discrete;
3200   DECL_FIELD_SIZE (decl) = length;
3201   *next_struct_offset += natural_length;
3202
3203   return 1; /* was POS */
3204 }
3205
3206 tree
3207 layout_chill_struct_type (t)
3208      tree t;
3209 {
3210   tree fieldlist = TYPE_FIELDS (t);
3211   tree x;
3212   int old_momentary;
3213   int was_pos;
3214   int pos_seen = 0;
3215   int pos_error = 0;
3216   int next_struct_offset;
3217
3218   old_momentary = suspend_momentary ();
3219
3220   /* Process specified field sizes.
3221      Set DECL_FIELD_SIZE to the specified size, or 0 if none specified.
3222      The specified size is found in the DECL_INITIAL.
3223      Store 0 there, except for ": 0" fields (so we can find them
3224      and delete them, below).  */
3225
3226   next_struct_offset = 0;
3227   for (x = fieldlist; x; x = TREE_CHAIN (x))
3228     {
3229       /* An EVENT or BUFFER mode is implemented as a RECORD_TYPE
3230          which may contain a CONST_DECL for the maximum queue size. */
3231       if (TREE_CODE (x) == CONST_DECL)
3232         continue;
3233
3234       /* If any field is const, the structure type is pseudo-const.  */
3235       /* A field that is pseudo-const makes the structure likewise.  */
3236       if (TREE_READONLY (x) || TYPE_READONLY_PROPERTY (TREE_TYPE (x)))
3237         TYPE_FIELDS_READONLY (t) = 1;
3238
3239       /* Any field that is volatile means variables of this type must be
3240          treated in some ways as volatile.  */
3241       if (TREE_THIS_VOLATILE (x))
3242         C_TYPE_FIELDS_VOLATILE (t) = 1;
3243
3244       if (DECL_INITIAL (x) != NULL_TREE)
3245         {
3246           was_pos = apply_chill_field_layout (x, &next_struct_offset);
3247           DECL_INITIAL (x) = NULL_TREE;
3248         }
3249       else
3250         {
3251           unsigned int min_align = TYPE_ALIGN (TREE_TYPE (x));
3252           DECL_ALIGN (x) = MAX (DECL_ALIGN (x), min_align);
3253           was_pos = 0;
3254         }
3255       if ((! was_pos && pos_seen) || (was_pos && ! pos_seen && x != fieldlist))
3256         pos_error = 1;
3257       pos_seen |= was_pos;
3258     }
3259
3260   if (pos_error)
3261     error ("If one field has a POS layout, then all fields must have a POS layout");
3262
3263   /* Now DECL_INITIAL is null on all fields.  */
3264
3265   layout_type (t);
3266
3267   /*  Now we have the truly final field list.
3268       Store it in this type and in the variants.  */
3269
3270   TYPE_FIELDS (t) = fieldlist;
3271
3272   /* If there are lots of fields, sort so we can look through them fast.
3273      We arbitrarily consider 16 or more elts to be "a lot".  */
3274   {
3275     int len = 0;
3276
3277     for (x = fieldlist; x; x = TREE_CHAIN (x))
3278       {
3279         if (len > 15)
3280           break;
3281         len += 1;
3282       }
3283     if (len > 15)
3284       {
3285         tree *field_array;
3286         char *space;
3287
3288         len += list_length (x);
3289         /* Use the same allocation policy here that make_node uses, to
3290            ensure that this lives as long as the rest of the struct decl.
3291            All decls in an inline function need to be saved.  */
3292         if (allocation_temporary_p ())
3293           space = savealloc (sizeof (struct lang_type) + len * sizeof (tree));
3294         else
3295           space = oballoc (sizeof (struct lang_type) + len * sizeof (tree));
3296
3297         TYPE_LANG_SPECIFIC (t) = (struct lang_type *) space;
3298         TYPE_LANG_SPECIFIC (t)->foo.rec.len = len;
3299
3300         field_array = &TYPE_LANG_SPECIFIC (t)->foo.rec.elts[0];
3301         len = 0;
3302         for (x = fieldlist; x; x = TREE_CHAIN (x))
3303           field_array[len++] = x;
3304
3305         qsort (field_array, len, sizeof (tree), field_decl_cmp);
3306       }
3307   }
3308
3309   for (x = TYPE_MAIN_VARIANT (t); x; x = TYPE_NEXT_VARIANT (x))
3310     {
3311       TYPE_FIELDS (x) = TYPE_FIELDS (t);
3312       TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (t);
3313       TYPE_ALIGN (x) = TYPE_ALIGN (t);
3314     }
3315
3316   resume_momentary (old_momentary);
3317
3318   return t;
3319 }
3320
3321 /* Given a list of fields, FIELDLIST, return a structure
3322    type that contains these fields.  The returned type is
3323    always a new type.  */
3324 tree
3325 build_chill_struct_type (fieldlist)
3326      tree fieldlist;
3327 {
3328   register tree t;
3329
3330   if (fieldlist == NULL_TREE || TREE_CODE (fieldlist) == ERROR_MARK)
3331     return error_mark_node;
3332
3333   t = make_chill_struct_type (fieldlist);
3334   if (pass != 1)
3335     t = layout_chill_struct_type (t);
3336
3337 /*   pushtag (NULL_TREE, t); */
3338
3339   return t;
3340 }
3341
3342 /* Fix a LANG_TYPE.  These are used for three different uses:
3343    - representing a 'READ M' (in which case TYPE_READONLY is set);
3344    - for a  NEWMODE or SYNMODE (CH_NOVELTY is set for a NEWMODE); and
3345    - for a parameterised type (TREE_TYPE points to base type,
3346      while TYPE_DOMAIN is the parameter or parameter list).
3347    Called from satisfy. */
3348 tree
3349 smash_dummy_type (type)
3350      tree type;
3351 {
3352   /* Save fields that we don't want to copy from ORIGIN. */
3353   tree origin = TREE_TYPE (type);
3354   tree main_tree = TYPE_MAIN_VARIANT (origin);
3355   int  save_uid = TYPE_UID (type);
3356   struct obstack *save_obstack = TYPE_OBSTACK (type);
3357   tree save_name = TYPE_NAME (type);
3358   int  save_permanent = TREE_PERMANENT (type);
3359   int  save_readonly = TYPE_READONLY (type);
3360   tree  save_novelty = CH_NOVELTY (type);
3361   tree save_domain = TYPE_DOMAIN (type);
3362
3363   if (origin == NULL_TREE)
3364     abort ();
3365
3366   if (save_domain)
3367     {
3368       if (TREE_CODE (save_domain) == ERROR_MARK)
3369         return error_mark_node;
3370       if (origin == char_type_node)
3371         { /* Old-fashioned CHAR(N) declaration. */
3372           origin = build_string_type (origin, save_domain);
3373         }
3374       else
3375         { /* Handle parameterised modes. */
3376           int is_varying = chill_varying_type_p (origin);
3377           tree new_max = save_domain;
3378           tree origin_novelty = CH_NOVELTY (origin);
3379           if (is_varying)
3380             origin = CH_VARYING_ARRAY_TYPE (origin);
3381           if (CH_STRING_TYPE_P (origin))
3382             {
3383               tree oldindex = TYPE_DOMAIN (origin);
3384               new_max = check_range (new_max, new_max, NULL_TREE,
3385                                      size_binop (PLUS_EXPR,
3386                                                  TYPE_MAX_VALUE (oldindex),
3387                                                  integer_one_node));
3388               origin = build_string_type (TREE_TYPE (origin), new_max);
3389             }
3390           else if (TREE_CODE (origin) == ARRAY_TYPE)
3391             {
3392               tree oldindex = TYPE_DOMAIN (origin);
3393               tree upper = check_range (new_max, new_max, NULL_TREE,
3394                                         TYPE_MAX_VALUE (oldindex));
3395               tree newindex
3396                 = build_chill_range_type (TREE_TYPE (oldindex),
3397                                           TYPE_MIN_VALUE (oldindex), upper);
3398               origin = build_simple_array_type (TREE_TYPE (origin), newindex, NULL_TREE);
3399             }
3400           else if (TREE_CODE (origin) == RECORD_TYPE)
3401             {
3402               error ("parameterised structures not implemented");
3403               return error_mark_node;
3404             }
3405           else
3406             {
3407               error ("invalid parameterised type");
3408               return error_mark_node;
3409             }
3410
3411           SET_CH_NOVELTY (origin, origin_novelty);
3412           if (is_varying)
3413             {
3414               origin = build_varying_struct (origin);
3415               SET_CH_NOVELTY (origin, origin_novelty);
3416             }
3417         }
3418       save_domain = NULL_TREE;
3419     }
3420
3421   if (TREE_CODE (origin) == ERROR_MARK)
3422     return error_mark_node;
3423
3424   *(struct tree_type*)type = *(struct tree_type*)origin;
3425   /* The following is so that the debug code for
3426      the copy is different from the original type.
3427      The two statements usually duplicate each other
3428      (because they clear fields of the same union),
3429      but the optimizer should catch that. */
3430   TYPE_SYMTAB_POINTER (type) = 0;
3431   TYPE_SYMTAB_ADDRESS (type) = 0;
3432
3433   /* Restore fields that we didn't want copied from ORIGIN. */
3434   TYPE_UID (type) = save_uid;
3435   TYPE_OBSTACK (type) = save_obstack;
3436   TREE_PERMANENT (type) = save_permanent;
3437   TYPE_NAME (type) = save_name;
3438
3439   TREE_CHAIN (type) = NULL_TREE;
3440   TYPE_VOLATILE (type) = 0;
3441   TYPE_POINTER_TO (type) = 0;
3442   TYPE_REFERENCE_TO (type) = 0;
3443
3444   if (save_readonly)
3445     { /* TYPE is READ ORIGIN.
3446          Add this type to the chain of variants of TYPE.  */
3447       TYPE_NEXT_VARIANT (type) = TYPE_NEXT_VARIANT (main_tree);
3448       TYPE_NEXT_VARIANT (main_tree) = type;
3449       TYPE_READONLY (type) = save_readonly;
3450     }
3451   else
3452     {
3453       /* TYPE is the copy of the RHS in a NEWMODE or SYNMODE.
3454        We also get here after old-fashioned CHAR(N) declaration (see above). */
3455       TYPE_MAIN_VARIANT (type) = type;
3456       TYPE_NEXT_VARIANT (type) = NULL_TREE;
3457       if (save_name)
3458         DECL_ORIGINAL_TYPE (save_name) = origin;
3459
3460       if (save_novelty != NULL_TREE)  /* A NEWMODE declaration. */
3461         {
3462           CH_NOVELTY (type) = save_novelty;
3463
3464           /* Z.200: "If the DEFINING mode of the NEWMODE name is a range mode,
3465              then the virtual mode &name is introduced as the PARENT mode
3466              of the NEWMODE name. The DEFINING mode of &name is the PARENT
3467              mode of the range mode, and the NOVELTY of &name is that of
3468              the NEWMODE name." */
3469
3470           if (TREE_CODE (type) == INTEGER_TYPE && TREE_TYPE (type))
3471             {
3472               tree parent;
3473               /* PARENT is the virtual mode &name mentioned above. */
3474               push_obstacks_nochange ();
3475               end_temporary_allocation ();
3476               parent = copy_novelty (save_novelty,TREE_TYPE (type));
3477               pop_obstacks ();
3478
3479               TREE_TYPE (type) = parent;
3480               TYPE_MIN_VALUE (type) = convert (parent, TYPE_MIN_VALUE (type));
3481               TYPE_MAX_VALUE (type) = convert (parent, TYPE_MAX_VALUE (type));
3482             }
3483         }
3484     }
3485   return type;
3486 }
3487
3488 /* This generates a LANG_TYPE node that represents 'READ TYPE'. */
3489
3490 tree
3491 build_readonly_type (type)
3492      tree type;
3493 {
3494   tree node = make_node (LANG_TYPE);
3495   TREE_TYPE (node) = type;
3496   TYPE_READONLY (node) = 1;
3497   if (pass != 1)
3498     node = smash_dummy_type (node);
3499   return node;
3500 }
3501
3502 \f
3503 /* Return an unsigned type the same as TYPE in other respects.  */
3504
3505 tree
3506 unsigned_type (type)
3507      tree type;
3508 {
3509   tree type1 = TYPE_MAIN_VARIANT (type);
3510   if (type1 == signed_char_type_node || type1 == char_type_node)
3511     return unsigned_char_type_node;
3512   if (type1 == integer_type_node)
3513     return unsigned_type_node;
3514   if (type1 == short_integer_type_node)
3515     return short_unsigned_type_node;
3516   if (type1 == long_integer_type_node)
3517     return long_unsigned_type_node;
3518   if (type1 == long_long_integer_type_node)
3519     return long_long_unsigned_type_node;
3520
3521   return signed_or_unsigned_type (1, type);
3522 }
3523
3524 /* Return a signed type the same as TYPE in other respects.  */
3525
3526 tree
3527 signed_type (type)
3528      tree type;
3529 {
3530   tree type1 = TYPE_MAIN_VARIANT (type);
3531   while (TREE_CODE (type1) == INTEGER_TYPE && TREE_TYPE (type1) != NULL_TREE)
3532     type1 = TREE_TYPE (type1);
3533   if (type1 == unsigned_char_type_node || type1 == char_type_node)
3534     return signed_char_type_node;
3535   if (type1 == unsigned_type_node)
3536     return integer_type_node;
3537   if (type1 == short_unsigned_type_node)
3538     return short_integer_type_node;
3539   if (type1 == long_unsigned_type_node)
3540     return long_integer_type_node;
3541   if (type1 == long_long_unsigned_type_node)
3542     return long_long_integer_type_node;
3543   if (TYPE_PRECISION (type1) == 1)
3544     return signed_boolean_type_node;
3545
3546   return signed_or_unsigned_type (0, type);
3547 }
3548
3549 /* Return a type the same as TYPE except unsigned or
3550    signed according to UNSIGNEDP.  */
3551
3552 tree
3553 signed_or_unsigned_type (unsignedp, type)
3554      int unsignedp;
3555      tree type;
3556 {
3557   if (! INTEGRAL_TYPE_P (type)
3558       || TREE_UNSIGNED (type) == unsignedp)
3559     return type;
3560
3561   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
3562     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3563   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
3564     return unsignedp ? unsigned_type_node : integer_type_node;
3565   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
3566     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
3567   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
3568     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
3569   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
3570     return (unsignedp ? long_long_unsigned_type_node
3571             : long_long_integer_type_node);
3572   return type;
3573 }
3574 \f
3575 /* Mark EXP saying that we need to be able to take the
3576    address of it; it should not be allocated in a register.
3577    Value is 1 if successful.  */
3578
3579 int
3580 mark_addressable (exp)
3581      tree exp;
3582 {
3583   register tree x = exp;
3584   while (1)
3585     switch (TREE_CODE (x))
3586       {
3587       case ADDR_EXPR:
3588       case COMPONENT_REF:
3589       case ARRAY_REF:
3590       case REALPART_EXPR:
3591       case IMAGPART_EXPR:
3592         x = TREE_OPERAND (x, 0);
3593         break;
3594
3595       case TRUTH_ANDIF_EXPR:
3596       case TRUTH_ORIF_EXPR:
3597       case COMPOUND_EXPR:
3598         x = TREE_OPERAND (x, 1);
3599         break;
3600
3601       case COND_EXPR:
3602         return mark_addressable (TREE_OPERAND (x, 1))
3603           & mark_addressable (TREE_OPERAND (x, 2));
3604
3605       case CONSTRUCTOR:
3606         TREE_ADDRESSABLE (x) = 1;
3607         return 1;
3608
3609       case INDIRECT_REF:
3610         /* We sometimes add a cast *(TYPE*)&FOO to handle type and mode
3611            incompatibility problems.  Handle this case by marking FOO.  */
3612         if (TREE_CODE (TREE_OPERAND (x, 0)) == NOP_EXPR
3613             && TREE_CODE (TREE_OPERAND (TREE_OPERAND (x, 0), 0)) == ADDR_EXPR)
3614           {
3615             x = TREE_OPERAND (TREE_OPERAND (x, 0), 0);
3616             break;
3617           }
3618         if (TREE_CODE (TREE_OPERAND (x, 0)) == ADDR_EXPR)
3619           {
3620             x = TREE_OPERAND (x, 0);
3621             break;
3622           }
3623         return 1;
3624
3625       case VAR_DECL:
3626       case CONST_DECL:
3627       case PARM_DECL:
3628       case RESULT_DECL:
3629         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
3630             && DECL_NONLOCAL (x))
3631           {
3632             if (TREE_PUBLIC (x))
3633               {
3634                 error ("global register variable `%s' used in nested function",
3635                        IDENTIFIER_POINTER (DECL_NAME (x)));
3636                 return 0;
3637               }
3638             pedwarn ("register variable `%s' used in nested function",
3639                      IDENTIFIER_POINTER (DECL_NAME (x)));
3640           }
3641         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
3642           {
3643             if (TREE_PUBLIC (x))
3644               {
3645                 error ("address of global register variable `%s' requested",
3646                        IDENTIFIER_POINTER (DECL_NAME (x)));
3647                 return 0;
3648               }
3649
3650             /* If we are making this addressable due to its having
3651                volatile components, give a different error message.  Also
3652                handle the case of an unnamed parameter by not trying
3653                to give the name.  */
3654
3655             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
3656               {
3657                 error ("cannot put object with volatile field into register");
3658                 return 0;
3659               }
3660
3661             pedwarn ("address of register variable `%s' requested",
3662                      IDENTIFIER_POINTER (DECL_NAME (x)));
3663           }
3664         put_var_into_stack (x);
3665
3666         /* drops through */
3667       case FUNCTION_DECL:
3668         TREE_ADDRESSABLE (x) = 1;
3669 #if 0  /* poplevel deals with this now.  */
3670         if (DECL_CONTEXT (x) == 0)
3671           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
3672 #endif
3673         /* drops through */
3674       default:
3675         return 1;
3676     }
3677 }
3678 \f
3679 /* Return nonzero if VALUE is a valid constant-valued expression
3680    for use in initializing a static variable; one that can be an
3681    element of a "constant" initializer.
3682
3683    Return null_pointer_node if the value is absolute;
3684    if it is relocatable, return the variable that determines the relocation.
3685    We assume that VALUE has been folded as much as possible;
3686    therefore, we do not need to check for such things as
3687    arithmetic-combinations of integers.  */
3688
3689 tree
3690 initializer_constant_valid_p (value, endtype)
3691      tree value;
3692      tree endtype;
3693 {
3694   switch (TREE_CODE (value))
3695     {
3696     case CONSTRUCTOR:
3697       if (TREE_CODE (TREE_TYPE (value)) == UNION_TYPE
3698           && TREE_CONSTANT (value))
3699         return
3700           initializer_constant_valid_p (TREE_VALUE (CONSTRUCTOR_ELTS (value)),
3701                                         endtype);
3702
3703       return TREE_STATIC (value) ? null_pointer_node : 0;
3704
3705     case INTEGER_CST:
3706     case REAL_CST:
3707     case STRING_CST:
3708     case COMPLEX_CST:
3709       return null_pointer_node;
3710
3711     case ADDR_EXPR:
3712       return TREE_OPERAND (value, 0);
3713
3714     case NON_LVALUE_EXPR:
3715       return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
3716
3717     case CONVERT_EXPR:
3718     case NOP_EXPR:
3719       /* Allow conversions between pointer types.  */
3720       if (TREE_CODE (TREE_TYPE (value)) == POINTER_TYPE
3721           && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == POINTER_TYPE)
3722         return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
3723
3724       /* Allow conversions between real types.  */
3725       if (TREE_CODE (TREE_TYPE (value)) == REAL_TYPE
3726           && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == REAL_TYPE)
3727         return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
3728
3729       /* Allow length-preserving conversions between integer types.  */
3730       if (TREE_CODE (TREE_TYPE (value)) == INTEGER_TYPE
3731           && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == INTEGER_TYPE
3732           && (TYPE_PRECISION (TREE_TYPE (value))
3733               == TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (value, 0)))))
3734         return initializer_constant_valid_p (TREE_OPERAND (value, 0), endtype);
3735
3736       /* Allow conversions between other integer types only if
3737          explicit value.  */
3738       if (TREE_CODE (TREE_TYPE (value)) == INTEGER_TYPE
3739           && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == INTEGER_TYPE)
3740         {
3741           tree inner = initializer_constant_valid_p (TREE_OPERAND (value, 0),
3742                                                      endtype);
3743           if (inner == null_pointer_node)
3744             return null_pointer_node;
3745           return 0;
3746         }
3747
3748       /* Allow (int) &foo provided int is as wide as a pointer.  */
3749       if (TREE_CODE (TREE_TYPE (value)) == INTEGER_TYPE
3750           && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == POINTER_TYPE
3751           && (TYPE_PRECISION (TREE_TYPE (value))
3752               >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (value, 0)))))
3753         return initializer_constant_valid_p (TREE_OPERAND (value, 0),
3754                                              endtype);
3755
3756       /* Likewise conversions from int to pointers.  */
3757       if (TREE_CODE (TREE_TYPE (value)) == POINTER_TYPE
3758           && TREE_CODE (TREE_TYPE (TREE_OPERAND (value, 0))) == INTEGER_TYPE
3759           && (TYPE_PRECISION (TREE_TYPE (value))
3760               <= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (value, 0)))))
3761         return initializer_constant_valid_p (TREE_OPERAND (value, 0),
3762                                              endtype);
3763
3764       /* Allow conversions to union types if the value inside is okay.  */
3765       if (TREE_CODE (TREE_TYPE (value)) == UNION_TYPE)
3766         return initializer_constant_valid_p (TREE_OPERAND (value, 0),
3767                                              endtype);
3768       return 0;
3769
3770     case PLUS_EXPR:
3771       if (TREE_CODE (endtype) == INTEGER_TYPE
3772           && TYPE_PRECISION (endtype) < POINTER_SIZE)
3773         return 0;
3774       {
3775         tree valid0 = initializer_constant_valid_p (TREE_OPERAND (value, 0),
3776                                                     endtype);
3777         tree valid1 = initializer_constant_valid_p (TREE_OPERAND (value, 1),
3778                                                     endtype);
3779         /* If either term is absolute, use the other terms relocation.  */
3780         if (valid0 == null_pointer_node)
3781           return valid1;
3782         if (valid1 == null_pointer_node)
3783           return valid0;
3784         return 0;
3785       }
3786
3787     case MINUS_EXPR:
3788       if (TREE_CODE (endtype) == INTEGER_TYPE
3789           && TYPE_PRECISION (endtype) < POINTER_SIZE)
3790         return 0;
3791       {
3792         tree valid0 = initializer_constant_valid_p (TREE_OPERAND (value, 0),
3793                                                     endtype);
3794         tree valid1 = initializer_constant_valid_p (TREE_OPERAND (value, 1),
3795                                                     endtype);
3796         /* Win if second argument is absolute.  */
3797         if (valid1 == null_pointer_node)
3798           return valid0;
3799         /* Win if both arguments have the same relocation.
3800            Then the value is absolute.  */
3801         if (valid0 == valid1)
3802           return null_pointer_node;
3803         return 0;
3804       }
3805     default:
3806       return 0;
3807     }
3808 }
3809 \f
3810 /* Return an integer type with BITS bits of precision,
3811    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
3812
3813 tree
3814 type_for_size (bits, unsignedp)
3815      unsigned bits;
3816      int unsignedp;
3817 {
3818   if (bits == TYPE_PRECISION (integer_type_node))
3819     return unsignedp ? unsigned_type_node : integer_type_node;
3820
3821   if (bits == TYPE_PRECISION (signed_char_type_node))
3822     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3823
3824   if (bits == TYPE_PRECISION (short_integer_type_node))
3825     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
3826
3827   if (bits == TYPE_PRECISION (long_integer_type_node))
3828     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
3829
3830   if (bits == TYPE_PRECISION (long_long_integer_type_node))
3831     return (unsignedp ? long_long_unsigned_type_node
3832             : long_long_integer_type_node);
3833
3834   if (bits <= TYPE_PRECISION (intQI_type_node))
3835     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
3836
3837   if (bits <= TYPE_PRECISION (intHI_type_node))
3838     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
3839
3840   if (bits <= TYPE_PRECISION (intSI_type_node))
3841     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
3842
3843   if (bits <= TYPE_PRECISION (intDI_type_node))
3844     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
3845
3846 #if HOST_BITS_PER_WIDE_INT >= 64
3847   if (bits <= TYPE_PRECISION (intTI_type_node))
3848     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
3849 #endif
3850
3851   return 0;
3852 }
3853
3854 /* Return a data type that has machine mode MODE.
3855    If the mode is an integer,
3856    then UNSIGNEDP selects between signed and unsigned types.  */
3857
3858 tree
3859 type_for_mode (mode, unsignedp)
3860      enum machine_mode mode;
3861      int unsignedp;
3862 {
3863   if ((int)mode == (int)TYPE_MODE (integer_type_node))
3864     return unsignedp ? unsigned_type_node : integer_type_node;
3865
3866   if ((int)mode == (int)TYPE_MODE (signed_char_type_node))
3867     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3868
3869   if ((int)mode == (int)TYPE_MODE (short_integer_type_node))
3870     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
3871
3872   if ((int)mode == (int)TYPE_MODE (long_integer_type_node))
3873     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
3874
3875   if ((int)mode == (int)TYPE_MODE (long_long_integer_type_node))
3876     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
3877
3878   if ((int)mode == (int)TYPE_MODE (intQI_type_node))
3879     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
3880
3881   if ((int)mode == (int)TYPE_MODE (intHI_type_node))
3882     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
3883
3884   if ((int)mode == (int)TYPE_MODE (intSI_type_node))
3885     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
3886
3887   if ((int)mode == (int)TYPE_MODE (intDI_type_node))
3888     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
3889
3890 #if HOST_BITS_PER_WIDE_INT >= 64
3891   if ((int)mode == (int)TYPE_MODE (intTI_type_node))
3892     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
3893 #endif
3894
3895   if ((int)mode == (int)TYPE_MODE (float_type_node))
3896     return float_type_node;
3897
3898   if ((int)mode == (int)TYPE_MODE (double_type_node))
3899     return double_type_node;
3900
3901   if ((int)mode == (int)TYPE_MODE (long_double_type_node))
3902     return long_double_type_node;
3903
3904   if ((int)mode == (int)TYPE_MODE (build_pointer_type (char_type_node)))
3905     return build_pointer_type (char_type_node);
3906
3907   if ((int)mode == (int)TYPE_MODE (build_pointer_type (integer_type_node)))
3908     return build_pointer_type (integer_type_node);
3909
3910   return 0;
3911 }