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