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