gcc/ch/typeck.c

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