gcc/ch/typeck.c

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