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 compatibility
 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 necessary ??? */
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       /* Need to handle row modes, instance modes,
1726          association modes, access modes, text modes,
1727          duration modes, absolute time modes, structure modes,
1728          parameterized structure modes */
1729     }
1730   return 1;
1731 }
1732
1733 /* Return a node that is true iff MODE1 and MODE2 are equivalent.
1734    This is normally boolean_true_node or boolean_false_node,
1735    but can be dynamic for dynamic types.
1736    CHAIN is as for chill_similar.  */
1737
1738 tree
1739 chill_equivalent (mode1, mode2, chain)
1740      tree mode1, mode2;
1741      struct mode_chain *chain;
1742 {
1743   int varying1, varying2;
1744   int is_string1, is_string2;
1745   tree base_mode1, base_mode2;
1746
1747   /* Are the modes v-equivalent? */
1748 #if 0
1749   if (!chill_similar (mode1, mode2, chain)
1750       || CH_NOVELTY(mode1) != CH_NOVELTY(mode2))
1751     return boolean_false_node;
1752 #endif
1753   if (!chill_similar (mode1, mode2, chain))
1754     return boolean_false_node;
1755   else if (TREE_CODE (mode2) == FUNCTION_TYPE
1756            && TREE_CODE (mode1) == POINTER_TYPE
1757            && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE)
1758     /* don't check novelty in this case to avoid error in case of
1759        NEWMODE'd proceduremode gets assigned a function */
1760     return boolean_true_node;
1761   else if (CH_NOVELTY(mode1) != CH_NOVELTY(mode2))
1762     return boolean_false_node;
1763
1764   varying1 = chill_varying_type_p (mode1);
1765   varying2 = chill_varying_type_p (mode2);
1766
1767   if (varying1 != varying2)
1768     return boolean_false_node;
1769   base_mode1 = varying1 ? CH_VARYING_ARRAY_TYPE (mode1) : mode1;
1770   base_mode2 = varying2 ? CH_VARYING_ARRAY_TYPE (mode2) : mode2;
1771   is_string1 = CH_STRING_TYPE_P (base_mode1);
1772   is_string2 = CH_STRING_TYPE_P (base_mode2);
1773   if (is_string1 || is_string2)
1774     {
1775       if (is_string1 != is_string2)
1776         return boolean_false_node;
1777       return fold (build (EQ_EXPR, boolean_type_node,
1778                           TYPE_SIZE (base_mode1),
1779                           TYPE_SIZE (base_mode2)));
1780     }
1781
1782   /* && some more stuff FIXME! */
1783   if (TREE_CODE(mode1) == INTEGER_TYPE || TREE_CODE(mode2) == INTEGER_TYPE)
1784     {
1785       if (TREE_CODE(mode1) != INTEGER_TYPE || TREE_CODE(mode2) != INTEGER_TYPE)
1786         return boolean_false_node;
1787       /* If one is a range, the other has to be a range. */
1788       if ((TREE_TYPE (mode1) != NULL_TREE) != (TREE_TYPE (mode2) != NULL_TREE))
1789         return boolean_false_node;
1790       if (TYPE_PRECISION (mode1) != TYPE_PRECISION (mode2))
1791         return boolean_false_node;
1792       if (!tree_int_cst_equal (TYPE_MIN_VALUE (mode1), TYPE_MIN_VALUE (mode2)))
1793         return boolean_false_node;
1794       if (!tree_int_cst_equal (TYPE_MAX_VALUE (mode1), TYPE_MAX_VALUE (mode2)))
1795         return boolean_false_node;
1796     }
1797   return boolean_true_node;
1798 }
1799
1800 static int
1801 chill_l_equivalent (mode1, mode2, chain)
1802      tree mode1, mode2;
1803      struct mode_chain *chain;
1804 {
1805   /* Are the modes equivalent? */
1806   if (integer_zerop (chill_equivalent (mode1, mode2, chain)))
1807     return 0;
1808   if (TYPE_READONLY (mode1) != TYPE_READONLY (mode2))
1809     return 0;
1810 /*
1811   ... other conditions ...;
1812  */
1813   return 1;
1814 }
1815
1816 /* See Z200 12.1.2.12 */
1817
1818 int
1819 chill_read_compatible (modeM, modeN)
1820      tree modeM, modeN;
1821 {
1822   while (TREE_CODE (modeM) == REFERENCE_TYPE)
1823     modeM = TREE_TYPE (modeM);
1824   while (TREE_CODE (modeN) == REFERENCE_TYPE)
1825     modeN = TREE_TYPE (modeN);
1826
1827   if (!CH_EQUIVALENT (modeM, modeN))
1828     return 0;
1829   if (TYPE_READONLY (modeN))
1830     {
1831       if (!TYPE_READONLY (modeM))
1832         return 0;
1833       if (CH_IS_BOUND_REFERENCE_MODE (modeM)
1834           && CH_IS_BOUND_REFERENCE_MODE (modeN))
1835         {
1836           return chill_l_equivalent (TREE_TYPE (modeM), TREE_TYPE (modeN), 0);
1837         }
1838 /*
1839       ...;
1840 */
1841     }
1842   return 1;
1843 }
1844
1845 /* Tests if MODE is compatible with the class of EXPR.
1846    Cfr. Chill Blue Book 12.1.2.15. */
1847
1848 int
1849 chill_compatible (expr, mode)
1850      tree expr, mode;
1851 {
1852   struct ch_class class;
1853
1854   if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
1855     return 0;
1856   if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK)
1857     return 0;
1858
1859   while (TREE_CODE (mode) == REFERENCE_TYPE)
1860     mode = TREE_TYPE (mode);
1861
1862   if (TREE_TYPE (expr) == NULL_TREE)
1863     {
1864       if (TREE_CODE (expr) == CONSTRUCTOR)
1865         return TREE_CODE (mode) == RECORD_TYPE
1866           || ((TREE_CODE (mode) == SET_TYPE || TREE_CODE (mode) == ARRAY_TYPE)
1867               && ! TYPE_STRING_FLAG (mode));
1868       else
1869         return TREE_CODE (expr) == CASE_EXPR || TREE_CODE (expr) == COND_EXPR;
1870     }
1871
1872   class = chill_expr_class (expr);
1873   switch (class.kind)
1874     {
1875     case CH_ALL_CLASS:
1876       return 1;
1877     case CH_NULL_CLASS:
1878       return CH_IS_REFERENCE_MODE (mode) || CH_IS_PROCEDURE_MODE (mode)
1879         || CH_IS_INSTANCE_MODE (mode);
1880     case CH_VALUE_CLASS:
1881       if (CH_HAS_REFERENCING_PROPERTY (mode))
1882         return CH_RESTRICTABLE_TO(mode, class.mode);
1883       else
1884         return CH_V_EQUIVALENT(mode, class.mode);
1885     case CH_DERIVED_CLASS:
1886       return CH_SIMILAR (class.mode, mode);
1887     case CH_REFERENCE_CLASS:
1888       if (!CH_IS_REFERENCE_MODE (mode))
1889         return 0;
1890 /* FIXME!
1891       if (class.mode is a row mode)
1892         ...;
1893       else if (class.mode is not a static mode)
1894         return 0; is this possible?
1895 */
1896       return !CH_IS_BOUND_REFERENCE_MODE(mode)
1897         || CH_READ_COMPATIBLE (TREE_TYPE (mode), class.mode);
1898     }
1899   return 0; /* ERROR! */
1900 }
1901
1902 /* Tests if the class of of EXPR1 and EXPR2 are compatible.
1903    Cfr. Chill Blue Book 12.1.2.16. */
1904
1905 int
1906 chill_compatible_classes (expr1, expr2)
1907      tree expr1, expr2;
1908 {
1909   struct ch_class temp;
1910   struct ch_class class1, class2;
1911   class1 = chill_expr_class (expr1);
1912   class2 = chill_expr_class (expr2);
1913
1914   switch (class1.kind)
1915     {
1916     case CH_ALL_CLASS:
1917       return 1;
1918     case CH_NULL_CLASS:
1919       switch (class2.kind)
1920         {
1921         case CH_ALL_CLASS:
1922         case CH_NULL_CLASS:
1923         case CH_REFERENCE_CLASS:
1924           return 1;
1925         case CH_VALUE_CLASS:
1926         case CH_DERIVED_CLASS:
1927           goto rule4;
1928         }
1929     case CH_REFERENCE_CLASS:
1930       switch (class2.kind)
1931         {
1932         case CH_ALL_CLASS:
1933         case CH_NULL_CLASS:
1934           return 1;
1935         case CH_REFERENCE_CLASS:
1936           return CH_EQUIVALENT (class1.mode, class2.mode);
1937         case CH_VALUE_CLASS:
1938           goto rule6;
1939         case CH_DERIVED_CLASS:
1940           return 0;
1941         }
1942     case CH_DERIVED_CLASS:
1943       switch (class2.kind)
1944         {
1945         case CH_ALL_CLASS:
1946           return 1;
1947         case CH_VALUE_CLASS:
1948         case CH_DERIVED_CLASS:
1949           return CH_SIMILAR (class1.mode, class2.mode);
1950         case CH_NULL_CLASS:
1951           class2 = class1;
1952           goto rule4;
1953         case CH_REFERENCE_CLASS:
1954           return 0;
1955         }
1956     case CH_VALUE_CLASS:
1957       switch (class2.kind)
1958         {
1959         case CH_ALL_CLASS:
1960           return 1;
1961         case CH_DERIVED_CLASS:
1962           return CH_SIMILAR (class1.mode, class2.mode);
1963         case CH_VALUE_CLASS:
1964           return CH_V_EQUIVALENT (class1.mode, class2.mode);
1965         case CH_NULL_CLASS:
1966           class2 = class1;
1967           goto rule4;
1968         case CH_REFERENCE_CLASS:
1969           temp = class1;  class1 = class2;  class2 = temp;
1970           goto rule6;
1971         }
1972     }
1973  rule4:
1974   /* The Null class is Compatible with the M-derived class or M-value class
1975      if and only if M is a reference mdoe, procedure mode or instance mode.*/
1976   return CH_IS_REFERENCE_MODE (class2.mode)
1977     || CH_IS_PROCEDURE_MODE (class2.mode)
1978     || CH_IS_INSTANCE_MODE (class2.mode);
1979
1980  rule6:
1981   /* The M-reference class is compatible with the N-value class if and
1982      only if N is a reference mode and ... */
1983   if (!CH_IS_REFERENCE_MODE (class2.mode))
1984     return 0;
1985   if (1) /* If M is a static mode - FIXME */
1986     {
1987       if (!CH_IS_BOUND_REFERENCE_MODE (class2.mode))
1988         return 1;
1989       if (CH_EQUIVALENT (TREE_TYPE (class2.mode), class1.mode))
1990         return 1;
1991     }
1992   /* If N is a row mode whose .... FIXME */
1993   return 0;
1994 }
1995
1996 /* Cfr.  Blue Book 12.1.1.6, with some "extensions." */
1997
1998 tree
1999 chill_root_mode (mode)
2000      tree mode;
2001 {
2002   /* Reference types are not user-visible types.
2003      This seems like a good place to get rid of them. */
2004   if (TREE_CODE (mode) == REFERENCE_TYPE)
2005     mode = TREE_TYPE (mode);
2006
2007   while (TREE_CODE (mode) == INTEGER_TYPE && TREE_TYPE (mode) != NULL_TREE)
2008     mode = TREE_TYPE (mode);  /* a sub-range */
2009
2010   /* This extension in not in the Blue Book - which only has a
2011      single Integer type.
2012      We should probably use chill_integer_type_node rather
2013      than integer_type_node, but that is likely to bomb.
2014      At some point, these will become the same, I hope. FIXME */
2015   if (TREE_CODE (mode) == INTEGER_TYPE
2016       && TYPE_PRECISION (mode) < TYPE_PRECISION (integer_type_node)
2017       && CH_NOVELTY (mode) == NULL_TREE)
2018     mode = integer_type_node;
2019
2020   if (TREE_CODE (mode) == FUNCTION_TYPE)
2021     return build_pointer_type (mode);
2022
2023   return mode;
2024 }
2025
2026 /* Cfr.  Blue Book 12.1.1.7. */
2027
2028 tree
2029 chill_resulting_mode (mode1, mode2)
2030      tree mode1, mode2;
2031 {
2032   mode1 = CH_ROOT_MODE (mode1);
2033   mode2 = CH_ROOT_MODE (mode2);
2034   if (chill_varying_type_p (mode1))
2035     return mode1;
2036   if (chill_varying_type_p (mode2))
2037     return mode2;
2038   return mode1;
2039 }
2040
2041 /* Cfr.  Blue Book (z200, 1988) 12.1.1.7 Resulting class. */
2042
2043 struct ch_class
2044 chill_resulting_class (class1, class2)
2045      struct ch_class class1, class2;
2046 {
2047   struct ch_class class;
2048   switch (class1.kind)
2049     {
2050     case CH_VALUE_CLASS:
2051       switch (class2.kind)
2052         {
2053         case CH_DERIVED_CLASS:
2054         case CH_ALL_CLASS:
2055           class.kind = CH_VALUE_CLASS;
2056           class.mode = CH_ROOT_MODE (class1.mode);
2057           return class;
2058         case CH_VALUE_CLASS:
2059           class.kind = CH_VALUE_CLASS;
2060           class.mode
2061             = CH_ROOT_MODE (CH_RESULTING_MODE (class1.mode, class2.mode));
2062           return class;
2063         default:
2064           break;
2065         }
2066       break;
2067     case CH_DERIVED_CLASS:
2068       switch (class2.kind)
2069         {
2070         case CH_VALUE_CLASS:
2071           class.kind = CH_VALUE_CLASS;
2072           class.mode = CH_ROOT_MODE (class2.mode);
2073           return class;
2074         case CH_DERIVED_CLASS:
2075           class.kind = CH_DERIVED_CLASS;
2076           class.mode = CH_RESULTING_MODE (class1.mode, class2.mode);
2077           return class;
2078         case CH_ALL_CLASS:
2079           class.kind = CH_DERIVED_CLASS;
2080           class.mode = CH_ROOT_MODE (class1.mode);
2081           return class;
2082         default:
2083           break;
2084         }
2085       break;
2086     case CH_ALL_CLASS:
2087       switch (class2.kind)
2088         {
2089         case CH_VALUE_CLASS:
2090           class.kind = CH_VALUE_CLASS;
2091           class.mode = CH_ROOT_MODE (class2.mode);
2092           return class;
2093         case CH_ALL_CLASS:
2094           class.kind = CH_ALL_CLASS;
2095           class.mode = NULL_TREE;
2096           return class;
2097         case CH_DERIVED_CLASS:
2098           class.kind = CH_DERIVED_CLASS;
2099           class.mode = CH_ROOT_MODE (class2.mode);
2100           return class;
2101         default:
2102           break;
2103         }
2104       break;
2105     default:
2106       break;
2107     }
2108   error ("internal error in chill_root_resulting_mode");
2109   class.kind = CH_VALUE_CLASS;
2110   class.mode = CH_ROOT_MODE (class1.mode);
2111   return class;
2112 }
2113 \f
2114
2115 /*
2116  * See Z.200, section 6.3, static conditions. This function
2117  * returns bool_false_node if the condition is not met at compile time,
2118  *         bool_true_node if the condition is detectably met at compile time
2119  *         an expression if a runtime check would be required or was generated.
2120  * It should only be called with string modes and values.
2121  */
2122 tree
2123 string_assignment_condition (lhs_mode, rhs_value)
2124      tree lhs_mode, rhs_value;
2125 {
2126   tree lhs_size, rhs_size, cond;
2127   tree rhs_mode = TREE_TYPE (rhs_value);
2128   int lhs_varying = chill_varying_type_p (lhs_mode);
2129
2130   if (lhs_varying)
2131     lhs_size = size_in_bytes (CH_VARYING_ARRAY_TYPE (lhs_mode));
2132   else if (CH_BOOLS_TYPE_P (lhs_mode))
2133     lhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (lhs_mode));
2134   else
2135     lhs_size = size_in_bytes (lhs_mode);
2136   lhs_size = convert (chill_unsigned_type_node, lhs_size);
2137
2138   if (rhs_mode && TREE_CODE (rhs_mode) == REFERENCE_TYPE)
2139     rhs_mode = TREE_TYPE (rhs_mode);
2140   if (rhs_mode == NULL_TREE)
2141     {
2142       /* actually, count constructor's length */
2143       abort ();
2144     }
2145   else if (chill_varying_type_p (rhs_mode))
2146     rhs_size = build_component_ref (rhs_value, var_length_id);
2147   else if (CH_BOOLS_TYPE_P (rhs_mode))
2148     rhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (rhs_mode));
2149   else
2150     rhs_size = size_in_bytes (rhs_mode);
2151   rhs_size = convert (chill_unsigned_type_node, rhs_size);
2152
2153   /* validity condition */
2154   cond = fold (build (lhs_varying ? GE_EXPR : EQ_EXPR,
2155            boolean_type_node, lhs_size, rhs_size));
2156   return cond;
2157 }
2158 \f
2159 /*
2160  * take a basic CHILL type and wrap it in a VARYING structure.
2161  * Be sure the length field is initialized.  Return the wrapper.
2162  */
2163 tree
2164 build_varying_struct (type)
2165      tree type;
2166 {
2167   tree decl1, decl2, result;
2168
2169   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
2170     return error_mark_node;
2171
2172   decl1 = build_decl (FIELD_DECL, var_length_id, chill_integer_type_node);
2173   decl2 = build_decl (FIELD_DECL, var_data_id, type);
2174   TREE_CHAIN (decl1) = decl2;
2175   TREE_CHAIN (decl2) = NULL_TREE;
2176   result = build_chill_struct_type (decl1);
2177
2178   /* mark this so we don't complain about missing initializers.
2179      It's fine for a VARYING array to be partially initialized.. */
2180   C_TYPE_VARIABLE_SIZE(type) = 1;
2181   return result;
2182 }
2183
2184
2185 /*
2186  * This is the struct type that forms the runtime initializer
2187  * list.  There's at least one of these generated per module.
2188  * It's attached to the global initializer list by the module's
2189  * 'constructor' code.  Should only be called in pass 2.
2190  */
2191 tree
2192 build_init_struct ()
2193 {
2194   tree decl1, decl2, result;
2195   /* We temporarily reset the maximum_field_alignment to zero so the
2196      compiler's init data structures can be compatible with the
2197      run-time system, even when we're compiling with -fpack. */
2198   unsigned int save_maximum_field_alignment = maximum_field_alignment;
2199   maximum_field_alignment = 0;
2200
2201   decl1 = build_decl (FIELD_DECL, get_identifier ("__INIT_ENTRY"),
2202             build_chill_pointer_type (
2203               build_function_type (void_type_node, NULL_TREE)));
2204
2205   decl2 = build_decl (FIELD_DECL, get_identifier ("__INIT_NEXT"),
2206                       build_chill_pointer_type (void_type_node));
2207
2208   TREE_CHAIN (decl1) = decl2;
2209   TREE_CHAIN (decl2) = NULL_TREE;
2210   result = build_chill_struct_type (decl1);
2211   maximum_field_alignment = save_maximum_field_alignment;
2212   return result;
2213 }
2214 \f
2215 \f
2216 /*
2217  * Return 1 if the given type is a single-bit boolean set,
2218  *          in which the domain's min and max values
2219  *          are both zero,
2220  *        0 if not.  This can become a macro later..
2221  */
2222 int
2223 ch_singleton_set (type)
2224      tree type;
2225 {
2226   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
2227     return 0;
2228   if (TREE_CODE (type) != SET_TYPE)
2229     return 0;
2230   if (TREE_TYPE (type) == NULL_TREE
2231       || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE)
2232     return 0;
2233   if (TYPE_DOMAIN (type) == NULL_TREE)
2234     return 0;
2235   if (! tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)),
2236                             integer_zero_node))
2237     return 0;
2238   if (! tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)),
2239                             integer_zero_node))
2240     return 0;
2241   return 1;
2242 }
2243 \f
2244 /* return non-zero if TYPE is a compiler-generated VARYING
2245    array of some base type */
2246 int
2247 chill_varying_type_p (type)
2248      tree type;
2249 {
2250   if (type == NULL_TREE)
2251     return 0;
2252   if (TREE_CODE (type) != RECORD_TYPE)
2253     return 0;
2254   if (TYPE_FIELDS (type) == NULL_TREE
2255       || TREE_CHAIN (TYPE_FIELDS (type)) == NULL_TREE)
2256     return 0;
2257   if (DECL_NAME (TYPE_FIELDS (type)) != var_length_id)
2258     return 0;
2259   if (DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) != var_data_id)
2260     return 0;
2261   if (TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))) != NULL_TREE)
2262     return 0;
2263   return 1;
2264 }
2265
2266 /* return non-zero if TYPE is a compiler-generated VARYING
2267    string record */
2268 int
2269 chill_varying_string_type_p (type)
2270      tree type;
2271 {
2272   tree var_data_type;
2273
2274   if (!chill_varying_type_p (type))
2275       return 0;
2276
2277   var_data_type = CH_VARYING_ARRAY_TYPE (type);
2278   return CH_CHARS_TYPE_P (var_data_type);
2279 }
2280 \f
2281 /* swiped from c-typeck.c */
2282 /* Build an assignment expression of lvalue LHS from value RHS. */
2283
2284 tree
2285 build_chill_modify_expr (lhs, rhs)
2286      tree lhs, rhs;
2287 {
2288   register tree result;
2289
2290
2291   tree lhstype = TREE_TYPE (lhs);
2292
2293   /* Avoid duplicate error messages from operands that had errors.  */
2294   if (lhs == NULL_TREE || TREE_CODE (lhs) == ERROR_MARK || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK)
2295     return error_mark_node;
2296
2297   /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue.  */
2298   /* Do not use STRIP_NOPS here.  We do not want an enumerator
2299      whose value is 0 to count as a null pointer constant.  */
2300   if (TREE_CODE (rhs) == NON_LVALUE_EXPR)
2301     rhs = TREE_OPERAND (rhs, 0);
2302
2303 #if 0
2304   /* Handle a cast used as an "lvalue".
2305      We have already performed any binary operator using the value as cast.
2306      Now convert the result to the cast type of the lhs,
2307      and then true type of the lhs and store it there;
2308      then convert result back to the cast type to be the value
2309      of the assignment.  */
2310
2311   switch (TREE_CODE (lhs))
2312     {
2313     case NOP_EXPR:
2314     case CONVERT_EXPR:
2315     case FLOAT_EXPR:
2316     case FIX_TRUNC_EXPR:
2317     case FIX_FLOOR_EXPR:
2318     case FIX_ROUND_EXPR:
2319     case FIX_CEIL_EXPR:
2320       {
2321         tree inner_lhs = TREE_OPERAND (lhs, 0);
2322         tree result;
2323         result = build_chill_modify_expr (inner_lhs,
2324                    convert (TREE_TYPE (inner_lhs),
2325                      convert (lhstype, rhs)));
2326         pedantic_lvalue_warning (CONVERT_EXPR);
2327         return convert (TREE_TYPE (lhs), result);
2328       }
2329     }
2330
2331   /* Now we have handled acceptable kinds of LHS that are not truly lvalues.
2332      Reject anything strange now.  */
2333
2334   if (!lvalue_or_else (lhs, "assignment"))
2335     return error_mark_node;
2336 #endif
2337   /* FIXME: need to generate a RANGEFAIL if the RHS won't
2338      fit into the LHS. */
2339
2340   if (TREE_CODE (lhs) != VAR_DECL
2341       && ((TREE_CODE (TREE_TYPE (lhs)) == ARRAY_TYPE &&
2342            (TREE_TYPE (rhs) && TREE_CODE (TREE_TYPE (rhs)) == ARRAY_TYPE)) ||
2343           chill_varying_type_p (TREE_TYPE (lhs)) ||
2344           chill_varying_type_p (TREE_TYPE (rhs))))
2345     {
2346       int lhs_varying = chill_varying_type_p (TREE_TYPE (lhs));
2347       int rhs_varying = chill_varying_type_p (TREE_TYPE (rhs));
2348
2349       /* point at actual RHS data's type */
2350       tree rhs_data_type = rhs_varying ?
2351         CH_VARYING_ARRAY_TYPE (TREE_TYPE (rhs)) :
2352           TREE_TYPE (rhs);
2353       {
2354         /* point at actual LHS data's type */
2355         tree lhs_data_type = lhs_varying ?
2356           CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)) :
2357             TREE_TYPE (lhs);
2358
2359         int lhs_bytes = int_size_in_bytes (lhs_data_type);
2360         int rhs_bytes = int_size_in_bytes (rhs_data_type);
2361
2362         /* if both sides not varying, and sizes not dynamically
2363            computed, sizes must *match* */
2364         if (! lhs_varying && ! rhs_varying && lhs_bytes != rhs_bytes
2365             && lhs_bytes > 0 && rhs_bytes > 0)
2366           {
2367             error ("string lengths not equal");
2368             return error_mark_node;
2369           }
2370         /* Must have enough space on LHS for static size of RHS */
2371
2372         if (lhs_bytes > 0 && rhs_bytes > 0
2373             && lhs_bytes < rhs_bytes)
2374           {
2375             if (rhs_varying)
2376               {
2377                 /* FIXME: generate runtime test for room */
2378                 ;
2379               }
2380             else
2381               {
2382                 error ("can't do ARRAY assignment - too large");
2383                 return error_mark_node;
2384               }
2385           }
2386       }
2387
2388       /* now we know the RHS will fit in LHS, build trees for the
2389          emit_block_move parameters */
2390
2391       if (lhs_varying)
2392         rhs = convert (TREE_TYPE (lhs), rhs);
2393       else
2394         {
2395           if (rhs_varying)
2396             rhs = build_component_ref (rhs, var_data_id);
2397
2398           if (! mark_addressable (rhs))
2399             {
2400               error ("rhs of array assignment is not addressable");
2401               return error_mark_node;
2402             }
2403
2404           lhs = force_addr_of (lhs);
2405           rhs = build1 (ADDR_EXPR, const_ptr_type_node, rhs);
2406           return
2407           build_chill_function_call (lookup_name (get_identifier ("memmove")),
2408             tree_cons (NULL_TREE, lhs,
2409               tree_cons (NULL_TREE, rhs,
2410                 tree_cons (NULL_TREE, size_in_bytes (rhs_data_type),
2411                    NULL_TREE))));
2412         }
2413     }
2414
2415   result = build (MODIFY_EXPR, lhstype, lhs, rhs);
2416   TREE_SIDE_EFFECTS (result) = 1;
2417
2418   return result;
2419 }
2420 \f
2421 /* Constructors for pointer, array and function types.
2422    (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are
2423    constructed by language-dependent code, not here.)  */
2424
2425 /* Construct, lay out and return the type of pointers to TO_TYPE.
2426    If such a type has already been constructed, reuse it.  */
2427
2428 static tree
2429 make_chill_pointer_type (to_type, code)
2430      tree to_type;
2431      enum tree_code code;  /* POINTER_TYPE or REFERENCE_TYPE */
2432 {
2433   extern struct obstack *current_obstack;
2434   extern struct obstack *saveable_obstack;
2435   extern struct obstack  permanent_obstack;
2436   tree t;
2437   register struct obstack *ambient_obstack = current_obstack;
2438   register struct obstack *ambient_saveable_obstack = saveable_obstack;
2439
2440   /* If TO_TYPE is permanent, make this permanent too.  */
2441   if (TREE_PERMANENT (to_type))
2442     {
2443       current_obstack = &permanent_obstack;
2444       saveable_obstack = &permanent_obstack;
2445     }
2446
2447   t = make_node (code);
2448   TREE_TYPE (t) = to_type;
2449
2450   current_obstack = ambient_obstack;
2451   saveable_obstack = ambient_saveable_obstack;
2452   return t;
2453 }
2454
2455
2456 tree
2457 build_chill_pointer_type (to_type)
2458      tree to_type;
2459 {
2460   int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't';
2461   register tree t = is_type_node ? TYPE_POINTER_TO (to_type) : NULL_TREE;
2462
2463   /* First, if we already have a type for pointers to TO_TYPE, use it.  */
2464
2465   if (t)
2466     return t;
2467
2468   /* We need a new one. */
2469   t = make_chill_pointer_type (to_type, POINTER_TYPE);
2470
2471   /* Lay out the type.  This function has many callers that are concerned
2472      with expression-construction, and this simplifies them all.
2473      Also, it guarantees the TYPE_SIZE is permanent if the type is.  */
2474   if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE))
2475       || pass == 2)
2476     {
2477       /* Record this type as the pointer to TO_TYPE.  */
2478       TYPE_POINTER_TO (to_type) = t;
2479       layout_type (t);
2480     }
2481
2482   return t;
2483 }
2484
2485 tree
2486 build_chill_reference_type (to_type)
2487      tree to_type;
2488 {
2489   int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't';
2490   register tree t = is_type_node ? TYPE_REFERENCE_TO (to_type) : NULL_TREE;
2491
2492   /* First, if we already have a type for references to TO_TYPE, use it.  */
2493
2494   if (t)
2495     return t;
2496
2497   /* We need a new one. */
2498   t = make_chill_pointer_type (to_type, REFERENCE_TYPE);
2499
2500   /* Lay out the type.  This function has many callers that are concerned
2501      with expression-construction, and this simplifies them all.
2502      Also, it guarantees the TYPE_SIZE is permanent if the type is.  */
2503   if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE))
2504       || pass == 2)
2505     {
2506       /* Record this type as the reference to TO_TYPE.  */
2507       TYPE_REFERENCE_TO (to_type) = t;
2508       layout_type (t);
2509       CH_NOVELTY (t) = CH_NOVELTY (to_type);
2510     }
2511
2512   return t;
2513 }
2514 \f
2515 static tree
2516 make_chill_range_type (type, lowval, highval)
2517      tree type, lowval, highval;
2518 {
2519   register tree itype = make_node (INTEGER_TYPE);
2520   TREE_TYPE (itype) = type;
2521   TYPE_MIN_VALUE (itype) = lowval;
2522   TYPE_MAX_VALUE (itype) = highval;
2523   return itype;
2524 }
2525
2526 \f
2527 /* Return the minimum number of bits needed to represent VALUE in a
2528    signed or unsigned type, UNSIGNEDP says which.  */
2529
2530 static unsigned int
2531 min_precision (value, unsignedp)
2532      tree value;
2533      int unsignedp;
2534 {
2535   int log;
2536
2537   /* If the value is negative, compute its negative minus 1.  The latter
2538      adjustment is because the absolute value of the largest negative value
2539      is one larger than the largest positive value.  This is equivalent to
2540      a bit-wise negation, so use that operation instead.  */
2541
2542   if (tree_int_cst_sgn (value) < 0)
2543     value = fold (build1 (BIT_NOT_EXPR, TREE_TYPE (value), value));
2544
2545   /* Return the number of bits needed, taking into account the fact
2546      that we need one more bit for a signed than unsigned type.  */
2547
2548   if (integer_zerop (value))
2549     log = 0;
2550   else
2551     log = tree_floor_log2 (value);
2552
2553   return log + 1 + ! unsignedp;
2554 }
2555
2556 tree
2557 layout_chill_range_type (rangetype, must_be_const)
2558      tree rangetype;
2559      int must_be_const;
2560 {
2561   tree type = TREE_TYPE (rangetype);
2562   tree lowval = TYPE_MIN_VALUE (rangetype);
2563   tree highval = TYPE_MAX_VALUE (rangetype);
2564   int bad_limits = 0;
2565
2566   if (TYPE_SIZE (rangetype) != NULL_TREE)
2567     return rangetype;
2568
2569   /* process BIN */
2570   if (type == ridpointers[(int) RID_BIN])
2571     {
2572       int binsize;
2573
2574       /* Make a range out of it */
2575       if (TREE_CODE (highval) != INTEGER_CST)
2576         {
2577           error ("non-constant expression for BIN");
2578           return error_mark_node;
2579         }
2580       else if (tree_int_cst_sgn (highval) < 0)
2581         {
2582           error ("expression for BIN must not be negative");
2583           return error_mark_node;
2584         }
2585       else if (compare_tree_int (highval, 32) > 0)
2586         {
2587           error ("cannot process BIN (>32)");
2588           return error_mark_node;
2589         }
2590
2591       binsize = tree_low_cst (highval, 1);
2592       type = ridpointers [(int) RID_RANGE];
2593       lowval = integer_zero_node;
2594       highval = build_int_2 ((1 << binsize) - 1, 0);
2595     }
2596
2597   if (TREE_CODE (lowval) == ERROR_MARK
2598       || TREE_CODE (highval) == ERROR_MARK)
2599     return error_mark_node;
2600
2601   if (!CH_COMPATIBLE_CLASSES (lowval, highval))
2602     {
2603       error ("bounds of range are not compatible");
2604       return error_mark_node;
2605     }
2606
2607   if (type == string_index_type_dummy)
2608     {
2609       if (TREE_CODE (highval) == INTEGER_CST
2610           && compare_int_csts (LT_EXPR, highval, integer_minus_one_node))
2611         {
2612           error ("negative string length");
2613           highval = integer_minus_one_node;
2614         }
2615       if (compare_int_csts (EQ_EXPR, highval, integer_minus_one_node))
2616         type = integer_type_node;
2617       else
2618         type = sizetype;
2619       TREE_TYPE (rangetype) = type;
2620     }
2621   else if (type == ridpointers[(int) RID_RANGE])
2622     {
2623       /* This isn't 100% right, since the Blue Book definition
2624          uses Resulting Class, rather than Resulting Mode,
2625          but it's close enough. */
2626       type = CH_ROOT_RESULTING_CLASS (lowval, highval).mode;
2627
2628       /* The default TYPE is the type of the constants -
2629          except if the constants are integers, we choose an
2630          integer type that fits. */
2631       if (TREE_CODE (type) == INTEGER_TYPE
2632           && TREE_CODE (lowval) == INTEGER_CST
2633           && TREE_CODE (highval) == INTEGER_CST)
2634         {
2635           int unsignedp = tree_int_cst_sgn (lowval) >= 0;
2636           unsigned int precision = MAX (min_precision (highval, unsignedp),
2637                                         min_precision (lowval, unsignedp));
2638
2639           type = type_for_size (precision, unsignedp);
2640
2641         }
2642
2643       TREE_TYPE (rangetype) = type;
2644     }
2645   else
2646     {
2647       if (!CH_COMPATIBLE (lowval, type))
2648         {
2649           error ("range's lower bound and parent mode don't match");
2650           return integer_type_node;    /* an innocuous fake */
2651         }
2652       if (!CH_COMPATIBLE (highval, type))
2653         {
2654           error ("range's upper bound and parent mode don't match");
2655           return integer_type_node;    /* an innocuous fake */
2656         }
2657     }
2658
2659   if (TREE_CODE (type) == ERROR_MARK)
2660     return type;
2661   else if (TREE_CODE_CLASS (TREE_CODE (type)) != 't')
2662     {
2663       error ("making range from non-mode");
2664       return error_mark_node;
2665     }
2666
2667   if (TREE_CODE (lowval) == REAL_CST || TREE_CODE (highval) == REAL_CST)
2668     {
2669       sorry ("floating point ranges");
2670       return integer_type_node; /* another fake */
2671     }
2672
2673   if (TREE_CODE (lowval) != INTEGER_CST || TREE_CODE (highval) != INTEGER_CST)
2674     {
2675       if (must_be_const)
2676         {
2677           error ("range mode has non-constant limits");
2678           bad_limits = 1;
2679         }
2680     }
2681   else if (tree_int_cst_equal (lowval, integer_zero_node)
2682            && tree_int_cst_equal (highval, integer_minus_one_node))
2683     ; /* do nothing - this is the index type for an empty string */
2684   else if (compare_int_csts (LT_EXPR, highval, TYPE_MIN_VALUE (type)))
2685     {
2686       error ("range's high bound < mode's low bound");
2687       bad_limits = 1;
2688     }
2689   else if (compare_int_csts (GT_EXPR, highval, TYPE_MAX_VALUE (type)))
2690     {
2691       error ("range's high bound > mode's high bound");
2692       bad_limits = 1;
2693     }
2694   else if (compare_int_csts (LT_EXPR, highval, lowval))
2695     {
2696       error ("range mode high bound < range mode low bound");
2697       bad_limits = 1;
2698     }
2699   else if (compare_int_csts (LT_EXPR, lowval, TYPE_MIN_VALUE (type)))
2700     {
2701       error ("range's low bound < mode's low bound");
2702       bad_limits = 1;
2703     }
2704   else if (compare_int_csts (GT_EXPR, lowval, TYPE_MAX_VALUE (type)))
2705     {
2706       error ("range's low bound > mode's high bound");
2707       bad_limits = 1;
2708     }
2709
2710   if (bad_limits)
2711     {
2712       lowval = TYPE_MIN_VALUE (type);
2713       highval = lowval;
2714     }
2715
2716   highval = convert (type, highval);
2717   lowval =  convert (type, lowval);
2718   TYPE_MIN_VALUE (rangetype) = lowval;
2719   TYPE_MAX_VALUE (rangetype) = highval;
2720   TYPE_PRECISION (rangetype) = TYPE_PRECISION (type);
2721   TYPE_MODE (rangetype) = TYPE_MODE (type);
2722   TYPE_SIZE (rangetype) = TYPE_SIZE (type);
2723   TYPE_SIZE_UNIT (rangetype) = TYPE_SIZE_UNIT (type);
2724   TYPE_ALIGN (rangetype) = TYPE_ALIGN (type);
2725   TYPE_USER_ALIGN (rangetype) = TYPE_USER_ALIGN (type);
2726   TREE_UNSIGNED (rangetype) = TREE_UNSIGNED (type);
2727   CH_NOVELTY (rangetype) = CH_NOVELTY (type);
2728   return rangetype;
2729 }
2730
2731 /* Build a _TYPE node that has range bounds associated with its values.
2732    TYPE is the base type for the range type. */
2733 tree
2734 build_chill_range_type (type, lowval, highval)
2735      tree type, lowval, highval;
2736 {
2737   tree rangetype;
2738
2739   if (type == NULL_TREE)
2740     type = ridpointers[(int) RID_RANGE];
2741   else if (TREE_CODE (type) == ERROR_MARK)
2742     return error_mark_node;
2743
2744   rangetype = make_chill_range_type (type, lowval, highval);
2745   if (pass != 1)
2746     rangetype = layout_chill_range_type (rangetype, 0);
2747
2748   return rangetype;
2749 }
2750
2751 /* Build a CHILL array type, but with minimal checking etc. */
2752
2753 tree
2754 build_simple_array_type (type, idx, layout)
2755      tree type, idx, layout;
2756 {
2757   tree array_type = make_node (ARRAY_TYPE);
2758   TREE_TYPE (array_type) = type;
2759   TYPE_DOMAIN (array_type) = idx;
2760   TYPE_ATTRIBUTES (array_type) = layout;
2761   if (pass != 1)
2762     array_type = layout_chill_array_type (array_type);
2763   return array_type;
2764 }
2765
2766 static void
2767 apply_chill_array_layout (array_type)
2768      tree array_type;
2769 {
2770   tree layout, temp, what, element_type;
2771   HOST_WIDE_INT stepsize = 0;
2772   HOST_WIDE_INT word, start_bit = 0, length;
2773   HOST_WIDE_INT natural_length;
2774   int stepsize_specified;
2775   int start_bit_error = 0;
2776   int length_error = 0;
2777
2778   layout = TYPE_ATTRIBUTES (array_type);
2779   if (layout == NULL_TREE)
2780     return;
2781
2782   if (layout == integer_zero_node) /* NOPACK */
2783     {
2784       TYPE_PACKED (array_type) = 0;
2785       return;
2786     }
2787
2788   /* Allow for the packing of 1 bit discrete modes at the bit level. */
2789   element_type = TREE_TYPE (array_type);
2790   if (discrete_type_p (element_type)
2791       && get_type_precision (TYPE_MIN_VALUE (element_type),
2792                              TYPE_MAX_VALUE (element_type)) == 1)
2793     natural_length = 1;
2794   else if (host_integerp (TYPE_SIZE (element_type), 1))
2795     natural_length = tree_low_cst (TYPE_SIZE (element_type), 1);
2796   else
2797     natural_length = -1;
2798
2799   if (layout == integer_one_node) /* PACK */
2800     {
2801       if (natural_length == 1)
2802         TYPE_PACKED (array_type) = 1;
2803       return;
2804     }
2805
2806   /* The layout is a STEP (...).
2807      The current implementation restricts STEP specifications to be of the form
2808      STEP(POS(0,0,n),n) where n is the natural size of the element mode. */
2809   stepsize_specified = 0;
2810   temp = TREE_VALUE (layout);
2811   if (TREE_VALUE (temp) != NULL_TREE)
2812     {
2813       if (! host_integerp (TREE_VALUE (temp), 0))
2814         error ("stepsize in STEP must be an integer constant");
2815       else
2816         {
2817           if (tree_int_cst_sgn (TREE_VALUE (temp)) <= 0)
2818             error ("stepsize in STEP must be > 0");
2819           else
2820             stepsize_specified = 1;
2821
2822           stepsize = tree_low_cst (TREE_VALUE (temp), 1);
2823           if (stepsize != natural_length)
2824             sorry ("stepsize in STEP must be the natural width of the array element mode");
2825         }
2826     }
2827
2828   temp = TREE_PURPOSE (temp);
2829   if (! host_integerp (TREE_PURPOSE (temp), 0))
2830     error ("starting word in POS must be an integer constant");
2831   else
2832     {
2833       if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0)
2834         error ("starting word in POS must be >= 0");
2835       if (! integer_zerop (TREE_PURPOSE (temp)))
2836         sorry ("starting word in POS within STEP must be 0");
2837
2838       word = tree_low_cst (TREE_PURPOSE (temp), 0);
2839     }
2840
2841   length = natural_length;
2842   temp = TREE_VALUE (temp);
2843   if (temp != NULL_TREE)
2844     {
2845       int wordsize = TYPE_PRECISION (chill_integer_type_node);
2846       if (! host_integerp (TREE_PURPOSE (temp), 0))
2847         {
2848           error ("starting bit in POS must be an integer constant");
2849           start_bit_error = 1;
2850         }
2851       else
2852         {
2853           if (! integer_zerop (TREE_PURPOSE (temp)))
2854             sorry ("starting bit in POS within STEP must be 0");
2855
2856           if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0)
2857             {
2858               error ("starting bit in POS must be >= 0");
2859               start_bit = 0;
2860               start_bit_error = 1;
2861             }
2862
2863           start_bit = tree_low_cst (TREE_PURPOSE (temp), 0);
2864           if (start_bit >= wordsize)
2865             {
2866               error ("starting bit in POS must be < the width of a word");
2867               start_bit = 0;
2868               start_bit_error = 1;
2869             }
2870         }
2871
2872       temp = TREE_VALUE (temp);
2873       if (temp != NULL_TREE)
2874         {
2875           what = TREE_PURPOSE (temp);
2876           if (what == integer_zero_node)
2877             {
2878               if (! host_integerp (TREE_VALUE (temp), 0))
2879                 {
2880                   error ("length in POS must be an integer constant");
2881                   length_error = 1;
2882                 }
2883               else
2884                 {
2885                   length = tree_low_cst (TREE_VALUE (temp), 0);
2886                   if (length <= 0)
2887                     error ("length in POS must be > 0");
2888                 }
2889             }
2890           else
2891             {
2892               if (! host_integerp (TREE_VALUE (temp), 0))
2893                 {
2894                   error ("end bit in POS must be an integer constant");
2895                   length_error = 1;
2896                 }
2897               else
2898                 {
2899                   HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0);
2900
2901                   if (end_bit < start_bit)
2902                     {
2903                       error ("end bit in POS must be >= the start bit");
2904                       end_bit = wordsize - 1;
2905                       length_error = 1;
2906                     }
2907                   else if (end_bit >= wordsize)
2908                     {
2909                       error ("end bit in POS must be < the width of a word");
2910                       end_bit = wordsize - 1;
2911                       length_error = 1;
2912                     }
2913                   else if (start_bit_error)
2914                     length_error = 1;
2915                   else
2916                     length = end_bit - start_bit + 1;
2917                 }
2918             }
2919
2920           if (! length_error && length != natural_length)
2921             sorry ("the length specified on POS within STEP must be the natural length of the array element type");
2922         }
2923     }
2924
2925   if (! length_error && stepsize_specified && stepsize < length)
2926     error ("step size in STEP must be >= the length in POS");
2927
2928   if (length == 1)
2929     TYPE_PACKED (array_type) = 1;
2930 }
2931
2932 tree
2933 layout_chill_array_type (array_type)
2934      tree array_type;
2935 {
2936   tree itype;
2937   tree element_type = TREE_TYPE (array_type);
2938
2939   if (TREE_CODE (element_type) == ARRAY_TYPE
2940       && TYPE_SIZE (element_type) == 0)
2941     layout_chill_array_type (element_type);
2942
2943   itype = TYPE_DOMAIN (array_type);
2944
2945   if (TREE_CODE (itype) == ERROR_MARK
2946       || TREE_CODE (element_type) == ERROR_MARK)
2947     return error_mark_node;
2948
2949   /* do a lower/upper bound check. */
2950   if (TREE_CODE (itype) == INTEGER_CST)
2951     {
2952       error ("array index must be a range, not a single integer");
2953       return error_mark_node;
2954     }
2955   if (TREE_CODE_CLASS (TREE_CODE (itype)) != 't'
2956       || !discrete_type_p (itype))
2957     {
2958       error ("array index is not a discrete mode");
2959       return error_mark_node;
2960     }
2961
2962   /* apply the array layout, if specified. */
2963   apply_chill_array_layout (array_type);
2964   TYPE_ATTRIBUTES (array_type) = NULL_TREE;
2965
2966   /* Make sure TYPE_POINTER_TO (element_type) is filled in.  */
2967   build_pointer_type (element_type);
2968
2969   if (TYPE_SIZE (array_type) == 0)
2970     layout_type (array_type);
2971
2972   if (TYPE_READONLY_PROPERTY (element_type))
2973     TYPE_FIELDS_READONLY (array_type) = 1;
2974
2975   TYPE_ARRAY_MAX_SIZE (array_type) = size_in_bytes (array_type);
2976   return array_type;
2977 }
2978
2979 /* Build a CHILL array type.
2980
2981    TYPE is the element type of the array.
2982    IDXLIST is the list of dimensions of the array.
2983    VARYING_P is non-zero if the array is a varying array.
2984    LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
2985    meaning (default, pack, nopack, STEP (...) ).  */
2986 tree
2987 build_chill_array_type (type, idxlist, varying_p, layouts)
2988      tree type, idxlist;
2989      int varying_p;
2990      tree layouts;
2991 {
2992   tree array_type = type;
2993
2994   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
2995     return error_mark_node;
2996   if (idxlist == NULL_TREE || TREE_CODE (idxlist) == ERROR_MARK)
2997     return error_mark_node;
2998
2999   /* We have to walk down the list of index decls, building inner
3000      array types as we go. We need to reverse the list of layouts so that the
3001      first layout applies to the last index etc. */
3002   layouts = nreverse (layouts);
3003   for ( ; idxlist; idxlist = TREE_CHAIN (idxlist))
3004     {
3005       if (layouts != NULL_TREE)
3006         {
3007           type = build_simple_array_type (
3008                    type, TREE_VALUE (idxlist), TREE_VALUE (layouts));
3009           layouts = TREE_CHAIN (layouts);
3010         }
3011       else
3012         type = build_simple_array_type (type, TREE_VALUE (idxlist), NULL_TREE);
3013     }
3014   array_type = type;
3015   if (varying_p)
3016     array_type = build_varying_struct (array_type);
3017   return array_type;
3018 }
3019
3020 /* Function to help qsort sort FIELD_DECLs by name order.  */
3021
3022 static int
3023 field_decl_cmp (x, y)
3024      tree *x, *y;
3025 {
3026   return (long)DECL_NAME (*x) - (long)DECL_NAME (*y);
3027 }
3028
3029 static tree
3030 make_chill_struct_type (fieldlist)
3031      tree fieldlist;
3032 {
3033   tree t, x;
3034
3035   t = make_node (TREE_UNION_ELEM (fieldlist) ? UNION_TYPE : RECORD_TYPE);
3036
3037   /* Install struct as DECL_CONTEXT of each field decl. */
3038   for (x = fieldlist; x; x = TREE_CHAIN (x))
3039     DECL_CONTEXT (x) = t;
3040
3041   /* Delete all duplicate fields from the fieldlist */
3042   for (x = fieldlist; x && TREE_CHAIN (x);)
3043     /* Anonymous fields aren't duplicates.  */
3044     if (DECL_NAME (TREE_CHAIN (x)) == 0)
3045       x = TREE_CHAIN (x);
3046     else
3047       {
3048         register tree y = fieldlist;
3049
3050         while (1)
3051           {
3052             if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x)))
3053               break;
3054             if (y == x)
3055               break;
3056             y = TREE_CHAIN (y);
3057           }
3058         if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x)))
3059           {
3060             error_with_decl (TREE_CHAIN (x), "duplicate member `%s'");
3061             TREE_CHAIN (x) = TREE_CHAIN (TREE_CHAIN (x));
3062           }
3063         else x = TREE_CHAIN (x);
3064       }
3065
3066   TYPE_FIELDS (t) = fieldlist;
3067
3068   return t;
3069 }
3070
3071 /* DECL is a FIELD_DECL.
3072    DECL_INIT (decl) is
3073        (NULL_TREE, integer_one_node, integer_zero_node, tree_list)
3074     meaning
3075         (default, pack, nopack, POS (...) ).
3076
3077    The return value is a boolean: 1 if POS specified, 0 if not */
3078
3079 static int
3080 apply_chill_field_layout (decl, next_struct_offset)
3081      tree decl;
3082      int *next_struct_offset;
3083 {
3084   tree layout = DECL_INITIAL (decl);
3085   tree type = TREE_TYPE (decl);
3086   tree temp, what;
3087   HOST_WIDE_INT word = 0;
3088   HOST_WIDE_INT wordsize, start_bit, offset, length, natural_length;
3089   int pos_error = 0;
3090   int is_discrete = discrete_type_p (type);
3091
3092   if (is_discrete)
3093     natural_length
3094       = get_type_precision (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
3095   else if (host_integerp (TYPE_SIZE (type), 1))
3096     natural_length = tree_low_cst (TYPE_SIZE (type), 1);
3097   else
3098     natural_length = -1;
3099
3100   if (layout == integer_zero_node) /* NOPACK */
3101     {
3102       *next_struct_offset += natural_length;
3103       return 0; /* not POS */
3104     }
3105
3106   if (layout == integer_one_node) /* PACK */
3107     {
3108       if (is_discrete)
3109         {
3110           DECL_BIT_FIELD (decl) = 1;
3111           DECL_SIZE (decl) = bitsize_int (natural_length);
3112         }
3113       else
3114         {
3115           DECL_ALIGN (decl) = BITS_PER_UNIT;
3116           DECL_USER_ALIGN (decl) = 0;
3117         }
3118
3119       DECL_PACKED (decl) = 1;
3120       *next_struct_offset += natural_length;
3121       return 0; /* not POS */
3122     }
3123
3124   /* The layout is a POS (...). The current implementation restricts the use
3125      of POS to monotonically increasing fields whose width must be the
3126      natural width of the underlying type. */
3127   temp = TREE_PURPOSE (layout);
3128
3129   if (! host_integerp (TREE_PURPOSE (temp), 0))
3130     {
3131       error ("starting word in POS must be an integer constant");
3132       pos_error = 1;
3133     }
3134   else
3135     {
3136       if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0)
3137         {
3138           error ("starting word in POS must be >= 0");
3139           word = 0;
3140           pos_error = 1;
3141         }
3142       else
3143         word = tree_low_cst (TREE_PURPOSE (temp), 0);
3144     }
3145
3146   wordsize = TYPE_PRECISION (chill_integer_type_node);
3147   offset = word * wordsize;
3148   length = natural_length;
3149
3150   temp = TREE_VALUE (temp);
3151   if (temp != NULL_TREE)
3152     {
3153       if (! host_integerp (TREE_PURPOSE (temp), 0))
3154         {
3155           error ("starting bit in POS must be an integer constant");
3156           start_bit = *next_struct_offset - offset;
3157           pos_error = 1;
3158         }
3159       else
3160         {
3161           if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0)
3162             {
3163               error ("starting bit in POS must be >= 0");
3164               start_bit = *next_struct_offset - offset;
3165               pos_error = 1;
3166             }
3167
3168           start_bit = tree_low_cst (TREE_PURPOSE (temp), 0);
3169           if (start_bit >= wordsize)
3170             {
3171               error ("starting bit in POS must be < the width of a word");
3172               start_bit = *next_struct_offset - offset;
3173               pos_error = 1;
3174             }
3175         }
3176
3177       temp = TREE_VALUE (temp);
3178       if (temp != NULL_TREE)
3179         {
3180           what = TREE_PURPOSE (temp);
3181           if (what == integer_zero_node)
3182             {
3183               if (! host_integerp (TREE_VALUE (temp), 0))
3184                 {
3185                   error ("length in POS must be an integer constant");
3186                   pos_error = 1;
3187                 }
3188               else
3189                 {
3190                   if (tree_int_cst_sgn (TREE_VALUE (temp)) < 0)
3191                     {
3192                       error ("length in POS must be > 0");
3193                       length = natural_length;
3194                       pos_error = 1;
3195                     }
3196                   else
3197                     length = tree_low_cst (TREE_VALUE (temp), 0);
3198
3199                 }
3200             }
3201           else
3202             {
3203               if (! host_integerp (TREE_VALUE (temp), 0))
3204                 {
3205                   error ("end bit in POS must be an integer constant");
3206                   pos_error = 1;
3207                 }
3208               else
3209                 {
3210                   HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0);
3211
3212                   if (end_bit < start_bit)
3213                     {
3214                       error ("end bit in POS must be >= the start bit");
3215                       pos_error = 1;
3216                     }
3217                   else if (end_bit >= wordsize)
3218                     {
3219                       error ("end bit in POS must be < the width of a word");
3220                       pos_error = 1;
3221                     }
3222                   else
3223                     length = end_bit - start_bit + 1;
3224                 }
3225             }
3226
3227           if (length != natural_length && ! pos_error)
3228             {
3229               sorry ("the length specified on POS must be the natural length of the field type");
3230               length = natural_length;
3231             }
3232         }
3233
3234       offset += start_bit;
3235     }
3236
3237   if (offset != *next_struct_offset && ! pos_error)
3238     sorry ("STRUCT fields must be layed out in monotonically increasing order");
3239
3240   DECL_PACKED (decl) = 1;
3241   DECL_BIT_FIELD (decl) = is_discrete;
3242
3243   if (is_discrete)
3244     DECL_SIZE (decl) = bitsize_int (length);
3245
3246   *next_struct_offset += natural_length;
3247
3248   return 1; /* was POS */
3249 }
3250
3251 tree
3252 layout_chill_struct_type (t)
3253      tree t;
3254 {
3255   tree fieldlist = TYPE_FIELDS (t);
3256   tree x;
3257   int old_momentary;
3258   int was_pos;
3259   int pos_seen = 0;
3260   int pos_error = 0;
3261   int next_struct_offset;
3262
3263   old_momentary = suspend_momentary ();
3264
3265   /* Process specified field sizes.  */
3266   next_struct_offset = 0;
3267   for (x = fieldlist; x; x = TREE_CHAIN (x))
3268     {
3269       /* An EVENT or BUFFER mode is implemented as a RECORD_TYPE
3270          which may contain a CONST_DECL for the maximum queue size. */
3271       if (TREE_CODE (x) == CONST_DECL)
3272         continue;
3273
3274       /* If any field is const, the structure type is pseudo-const.  */
3275       /* A field that is pseudo-const makes the structure likewise.  */
3276       if (TREE_READONLY (x) || TYPE_READONLY_PROPERTY (TREE_TYPE (x)))
3277         TYPE_FIELDS_READONLY (t) = 1;
3278
3279       /* Any field that is volatile means variables of this type must be
3280          treated in some ways as volatile.  */
3281       if (TREE_THIS_VOLATILE (x))
3282         C_TYPE_FIELDS_VOLATILE (t) = 1;
3283
3284       if (DECL_INITIAL (x) != NULL_TREE)
3285         {
3286           was_pos = apply_chill_field_layout (x, &next_struct_offset);
3287           DECL_INITIAL (x) = NULL_TREE;
3288         }
3289       else
3290         {
3291           unsigned int min_align = TYPE_ALIGN (TREE_TYPE (x));
3292           DECL_ALIGN (x) = MAX (DECL_ALIGN (x), min_align);
3293           was_pos = 0;
3294         }
3295       if ((! was_pos && pos_seen) || (was_pos && ! pos_seen && x != fieldlist))
3296         pos_error = 1;
3297       pos_seen |= was_pos;
3298     }
3299
3300   if (pos_error)
3301     error ("if one field has a POS layout, then all fields must have a POS layout");
3302
3303   /* Now DECL_INITIAL is null on all fields.  */
3304
3305   layout_type (t);
3306
3307   /*  Now we have the truly final field list.
3308       Store it in this type and in the variants.  */
3309
3310   TYPE_FIELDS (t) = fieldlist;
3311
3312   /* If there are lots of fields, sort so we can look through them fast.
3313      We arbitrarily consider 16 or more elts to be "a lot".  */
3314   {
3315     int len = 0;
3316
3317     for (x = fieldlist; x; x = TREE_CHAIN (x))
3318       {
3319         if (len > 15)
3320           break;
3321         len += 1;
3322       }
3323     if (len > 15)
3324       {
3325         tree *field_array;
3326         char *space;
3327
3328         len += list_length (x);
3329         /* Use the same allocation policy here that make_node uses, to
3330            ensure that this lives as long as the rest of the struct decl.
3331            All decls in an inline function need to be saved.  */
3332         if (allocation_temporary_p ())
3333           space = savealloc (sizeof (struct lang_type) + len * sizeof (tree));
3334         else
3335           space = oballoc (sizeof (struct lang_type) + len * sizeof (tree));
3336
3337         TYPE_LANG_SPECIFIC (t) = (struct lang_type *) space;
3338         TYPE_LANG_SPECIFIC (t)->foo.rec.len = len;
3339
3340         field_array = &TYPE_LANG_SPECIFIC (t)->foo.rec.elts[0];
3341         len = 0;
3342         for (x = fieldlist; x; x = TREE_CHAIN (x))
3343           field_array[len++] = x;
3344
3345         qsort (field_array, len, sizeof (tree),
3346                (int (*) PARAMS ((const void *, const void *))) field_decl_cmp);
3347       }
3348   }
3349
3350   for (x = TYPE_MAIN_VARIANT (t); x; x = TYPE_NEXT_VARIANT (x))
3351     {
3352       TYPE_FIELDS (x) = TYPE_FIELDS (t);
3353       TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (t);
3354       TYPE_ALIGN (x) = TYPE_ALIGN (t);
3355       TYPE_USER_ALIGN (x) = TYPE_USER_ALIGN (t);
3356     }
3357
3358   resume_momentary (old_momentary);
3359
3360   return t;
3361 }
3362
3363 /* Given a list of fields, FIELDLIST, return a structure
3364    type that contains these fields.  The returned type is
3365    always a new type.  */
3366 tree
3367 build_chill_struct_type (fieldlist)
3368      tree fieldlist;
3369 {
3370   register tree t;
3371
3372   if (fieldlist == NULL_TREE || TREE_CODE (fieldlist) == ERROR_MARK)
3373     return error_mark_node;
3374
3375   t = make_chill_struct_type (fieldlist);
3376   if (pass != 1)
3377     t = layout_chill_struct_type (t);
3378
3379 /*   pushtag (NULL_TREE, t); */
3380
3381   return t;
3382 }
3383
3384 /* Fix a LANG_TYPE.  These are used for three different uses:
3385    - representing a 'READ M' (in which case TYPE_READONLY is set);
3386    - for a  NEWMODE or SYNMODE (CH_NOVELTY is set for a NEWMODE); and
3387    - for a parameterised type (TREE_TYPE points to base type,
3388      while TYPE_DOMAIN is the parameter or parameter list).
3389    Called from satisfy. */
3390 tree
3391 smash_dummy_type (type)
3392      tree type;
3393 {
3394   /* Save fields that we don't want to copy from ORIGIN. */
3395   tree origin = TREE_TYPE (type);
3396   tree main_tree = TYPE_MAIN_VARIANT (origin);
3397   int  save_uid = TYPE_UID (type);
3398   struct obstack *save_obstack = TYPE_OBSTACK (type);
3399   tree save_name = TYPE_NAME (type);
3400   int  save_permanent = TREE_PERMANENT (type);
3401   int  save_readonly = TYPE_READONLY (type);
3402   tree  save_novelty = CH_NOVELTY (type);
3403   tree save_domain = TYPE_DOMAIN (type);
3404
3405   if (origin == NULL_TREE)
3406     abort ();
3407
3408   if (save_domain)
3409     {
3410       if (TREE_CODE (save_domain) == ERROR_MARK)
3411         return error_mark_node;
3412       if (origin == char_type_node)
3413         { /* Old-fashioned CHAR(N) declaration. */
3414           origin = build_string_type (origin, save_domain);
3415         }
3416       else
3417         { /* Handle parameterised modes. */
3418           int is_varying = chill_varying_type_p (origin);
3419           tree new_max = save_domain;
3420           tree origin_novelty = CH_NOVELTY (origin);
3421           if (is_varying)
3422             origin = CH_VARYING_ARRAY_TYPE (origin);
3423           if (CH_STRING_TYPE_P (origin))
3424             {
3425               tree oldindex = TYPE_DOMAIN (origin);
3426               new_max = check_range (new_max, new_max, NULL_TREE,
3427                                      fold (build (PLUS_EXPR, integer_type_node,
3428                                                   TYPE_MAX_VALUE (oldindex),
3429                                                   integer_one_node)));
3430               origin = build_string_type (TREE_TYPE (origin), new_max);
3431             }
3432           else if (TREE_CODE (origin) == ARRAY_TYPE)
3433             {
3434               tree oldindex = TYPE_DOMAIN (origin);
3435               tree upper = check_range (new_max, new_max, NULL_TREE,
3436                                         TYPE_MAX_VALUE (oldindex));
3437               tree newindex
3438                 = build_chill_range_type (TREE_TYPE (oldindex),
3439                                           TYPE_MIN_VALUE (oldindex), upper);
3440               origin = build_simple_array_type (TREE_TYPE (origin), newindex, NULL_TREE);
3441             }
3442           else if (TREE_CODE (origin) == RECORD_TYPE)
3443             {
3444               error ("parameterised structures not implemented");
3445               return error_mark_node;
3446             }
3447           else
3448             {
3449               error ("invalid parameterised type");
3450               return error_mark_node;
3451             }
3452
3453           SET_CH_NOVELTY (origin, origin_novelty);
3454           if (is_varying)
3455             {
3456               origin = build_varying_struct (origin);
3457               SET_CH_NOVELTY (origin, origin_novelty);
3458             }
3459         }
3460       save_domain = NULL_TREE;
3461     }
3462
3463   if (TREE_CODE (origin) == ERROR_MARK)
3464     return error_mark_node;
3465
3466   *(struct tree_type*)type = *(struct tree_type*)origin;
3467   /* The following is so that the debug code for
3468      the copy is different from the original type.
3469      The two statements usually duplicate each other
3470      (because they clear fields of the same union),
3471      but the optimizer should catch that. */
3472   TYPE_SYMTAB_POINTER (type) = 0;
3473   TYPE_SYMTAB_ADDRESS (type) = 0;
3474
3475   /* Restore fields that we didn't want copied from ORIGIN. */
3476   TYPE_UID (type) = save_uid;
3477   TYPE_OBSTACK (type) = save_obstack;
3478   TREE_PERMANENT (type) = save_permanent;
3479   TYPE_NAME (type) = save_name;
3480
3481   TREE_CHAIN (type) = NULL_TREE;
3482   TYPE_VOLATILE (type) = 0;
3483   TYPE_POINTER_TO (type) = 0;
3484   TYPE_REFERENCE_TO (type) = 0;
3485
3486   if (save_readonly)
3487     { /* TYPE is READ ORIGIN.
3488          Add this type to the chain of variants of TYPE.  */
3489       TYPE_NEXT_VARIANT (type) = TYPE_NEXT_VARIANT (main_tree);
3490       TYPE_NEXT_VARIANT (main_tree) = type;
3491       TYPE_READONLY (type) = save_readonly;
3492     }
3493   else
3494     {
3495       /* TYPE is the copy of the RHS in a NEWMODE or SYNMODE.
3496        We also get here after old-fashioned CHAR(N) declaration (see above). */
3497       TYPE_MAIN_VARIANT (type) = type;
3498       TYPE_NEXT_VARIANT (type) = NULL_TREE;
3499       if (save_name)
3500         DECL_ORIGINAL_TYPE (save_name) = origin;
3501
3502       if (save_novelty != NULL_TREE)  /* A NEWMODE declaration. */
3503         {
3504           CH_NOVELTY (type) = save_novelty;
3505
3506           /* Z.200: "If the DEFINING mode of the NEWMODE name is a range mode,
3507              then the virtual mode &name is introduced as the PARENT mode
3508              of the NEWMODE name. The DEFINING mode of &name is the PARENT
3509              mode of the range mode, and the NOVELTY of &name is that of
3510              the NEWMODE name." */
3511
3512           if (TREE_CODE (type) == INTEGER_TYPE && TREE_TYPE (type))
3513             {
3514               tree parent;
3515               /* PARENT is the virtual mode &name mentioned above. */
3516               push_obstacks_nochange ();
3517               end_temporary_allocation ();
3518               parent = copy_novelty (save_novelty,TREE_TYPE (type));
3519               pop_obstacks ();
3520
3521               TREE_TYPE (type) = parent;
3522               TYPE_MIN_VALUE (type) = convert (parent, TYPE_MIN_VALUE (type));
3523               TYPE_MAX_VALUE (type) = convert (parent, TYPE_MAX_VALUE (type));
3524             }
3525         }
3526     }
3527   return type;
3528 }
3529
3530 /* This generates a LANG_TYPE node that represents 'READ TYPE'. */
3531
3532 tree
3533 build_readonly_type (type)
3534      tree type;
3535 {
3536   tree node = make_node (LANG_TYPE);
3537   TREE_TYPE (node) = type;
3538   TYPE_READONLY (node) = 1;
3539   if (pass != 1)
3540     node = smash_dummy_type (node);
3541   return node;
3542 }
3543
3544 \f
3545 /* Return an unsigned type the same as TYPE in other respects.  */
3546
3547 tree
3548 unsigned_type (type)
3549      tree type;
3550 {
3551   tree type1 = TYPE_MAIN_VARIANT (type);
3552   if (type1 == signed_char_type_node || type1 == char_type_node)
3553     return unsigned_char_type_node;
3554   if (type1 == integer_type_node)
3555     return unsigned_type_node;
3556   if (type1 == short_integer_type_node)
3557     return short_unsigned_type_node;
3558   if (type1 == long_integer_type_node)
3559     return long_unsigned_type_node;
3560   if (type1 == long_long_integer_type_node)
3561     return long_long_unsigned_type_node;
3562
3563   return signed_or_unsigned_type (1, type);
3564 }
3565
3566 /* Return a signed type the same as TYPE in other respects.  */
3567
3568 tree
3569 signed_type (type)
3570      tree type;
3571 {
3572   tree type1 = TYPE_MAIN_VARIANT (type);
3573   while (TREE_CODE (type1) == INTEGER_TYPE && TREE_TYPE (type1) != NULL_TREE)
3574     type1 = TREE_TYPE (type1);
3575   if (type1 == unsigned_char_type_node || type1 == char_type_node)
3576     return signed_char_type_node;
3577   if (type1 == unsigned_type_node)
3578     return integer_type_node;
3579   if (type1 == short_unsigned_type_node)
3580     return short_integer_type_node;
3581   if (type1 == long_unsigned_type_node)
3582     return long_integer_type_node;
3583   if (type1 == long_long_unsigned_type_node)
3584     return long_long_integer_type_node;
3585   if (TYPE_PRECISION (type1) == 1)
3586     return signed_boolean_type_node;
3587
3588   return signed_or_unsigned_type (0, type);
3589 }
3590
3591 /* Return a type the same as TYPE except unsigned or
3592    signed according to UNSIGNEDP.  */
3593
3594 tree
3595 signed_or_unsigned_type (unsignedp, type)
3596      int unsignedp;
3597      tree type;
3598 {
3599   if (! INTEGRAL_TYPE_P (type)
3600       || TREE_UNSIGNED (type) == unsignedp)
3601     return type;
3602
3603   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
3604     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3605   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
3606     return unsignedp ? unsigned_type_node : integer_type_node;
3607   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
3608     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
3609   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
3610     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
3611   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
3612     return (unsignedp ? long_long_unsigned_type_node
3613             : long_long_integer_type_node);
3614   return type;
3615 }
3616 \f
3617 /* Mark EXP saying that we need to be able to take the
3618    address of it; it should not be allocated in a register.
3619    Value is 1 if successful.  */
3620
3621 int
3622 mark_addressable (exp)
3623      tree exp;
3624 {
3625   register tree x = exp;
3626   while (1)
3627     switch (TREE_CODE (x))
3628       {
3629       case ADDR_EXPR:
3630       case COMPONENT_REF:
3631       case ARRAY_REF:
3632       case REALPART_EXPR:
3633       case IMAGPART_EXPR:
3634         x = TREE_OPERAND (x, 0);
3635         break;
3636
3637       case TRUTH_ANDIF_EXPR:
3638       case TRUTH_ORIF_EXPR:
3639       case COMPOUND_EXPR:
3640         x = TREE_OPERAND (x, 1);
3641         break;
3642
3643       case COND_EXPR:
3644         return mark_addressable (TREE_OPERAND (x, 1))
3645           & mark_addressable (TREE_OPERAND (x, 2));
3646
3647       case CONSTRUCTOR:
3648         TREE_ADDRESSABLE (x) = 1;
3649         return 1;
3650
3651       case INDIRECT_REF:
3652         /* We sometimes add a cast *(TYPE*)&FOO to handle type and mode
3653            incompatibility problems.  Handle this case by marking FOO.  */
3654         if (TREE_CODE (TREE_OPERAND (x, 0)) == NOP_EXPR
3655             && TREE_CODE (TREE_OPERAND (TREE_OPERAND (x, 0), 0)) == ADDR_EXPR)
3656           {
3657             x = TREE_OPERAND (TREE_OPERAND (x, 0), 0);
3658             break;
3659           }
3660         if (TREE_CODE (TREE_OPERAND (x, 0)) == ADDR_EXPR)
3661           {
3662             x = TREE_OPERAND (x, 0);
3663             break;
3664           }
3665         return 1;
3666
3667       case VAR_DECL:
3668       case CONST_DECL:
3669       case PARM_DECL:
3670       case RESULT_DECL:
3671         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
3672             && DECL_NONLOCAL (x))
3673           {
3674             if (TREE_PUBLIC (x))
3675               {
3676                 error ("global register variable `%s' used in nested function",
3677                        IDENTIFIER_POINTER (DECL_NAME (x)));
3678                 return 0;
3679               }
3680             pedwarn ("register variable `%s' used in nested function",
3681                      IDENTIFIER_POINTER (DECL_NAME (x)));
3682           }
3683         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
3684           {
3685             if (TREE_PUBLIC (x))
3686               {
3687                 error ("address of global register variable `%s' requested",
3688                        IDENTIFIER_POINTER (DECL_NAME (x)));
3689                 return 0;
3690               }
3691
3692             /* If we are making this addressable due to its having
3693                volatile components, give a different error message.  Also
3694                handle the case of an unnamed parameter by not trying
3695                to give the name.  */
3696
3697             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
3698               {
3699                 error ("cannot put object with volatile field into register");
3700                 return 0;
3701               }
3702
3703             pedwarn ("address of register variable `%s' requested",
3704                      IDENTIFIER_POINTER (DECL_NAME (x)));
3705           }
3706         put_var_into_stack (x);
3707
3708         /* drops through */
3709       case FUNCTION_DECL:
3710         TREE_ADDRESSABLE (x) = 1;
3711 #if 0  /* poplevel deals with this now.  */
3712         if (DECL_CONTEXT (x) == 0)
3713           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
3714 #endif
3715         /* drops through */
3716       default:
3717         return 1;
3718     }
3719 }
3720 \f
3721 /* Return an integer type with BITS bits of precision,
3722    that is unsigned if UNSIGNEDP is nonzero, otherwise signed.  */
3723
3724 tree
3725 type_for_size (bits, unsignedp)
3726      unsigned bits;
3727      int unsignedp;
3728 {
3729   if (bits == TYPE_PRECISION (integer_type_node))
3730     return unsignedp ? unsigned_type_node : integer_type_node;
3731
3732   if (bits == TYPE_PRECISION (signed_char_type_node))
3733     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3734
3735   if (bits == TYPE_PRECISION (short_integer_type_node))
3736     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
3737
3738   if (bits == TYPE_PRECISION (long_integer_type_node))
3739     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
3740
3741   if (bits == TYPE_PRECISION (long_long_integer_type_node))
3742     return (unsignedp ? long_long_unsigned_type_node
3743             : long_long_integer_type_node);
3744
3745   if (bits <= TYPE_PRECISION (intQI_type_node))
3746     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
3747
3748   if (bits <= TYPE_PRECISION (intHI_type_node))
3749     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
3750
3751   if (bits <= TYPE_PRECISION (intSI_type_node))
3752     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
3753
3754   if (bits <= TYPE_PRECISION (intDI_type_node))
3755     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
3756
3757 #if HOST_BITS_PER_WIDE_INT >= 64
3758   if (bits <= TYPE_PRECISION (intTI_type_node))
3759     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
3760 #endif
3761
3762   return 0;
3763 }
3764
3765 /* Return a data type that has machine mode MODE.
3766    If the mode is an integer,
3767    then UNSIGNEDP selects between signed and unsigned types.  */
3768
3769 tree
3770 type_for_mode (mode, unsignedp)
3771      enum machine_mode mode;
3772      int unsignedp;
3773 {
3774   if ((int)mode == (int)TYPE_MODE (integer_type_node))
3775     return unsignedp ? unsigned_type_node : integer_type_node;
3776
3777   if ((int)mode == (int)TYPE_MODE (signed_char_type_node))
3778     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
3779
3780   if ((int)mode == (int)TYPE_MODE (short_integer_type_node))
3781     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
3782
3783   if ((int)mode == (int)TYPE_MODE (long_integer_type_node))
3784     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
3785
3786   if ((int)mode == (int)TYPE_MODE (long_long_integer_type_node))
3787     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
3788
3789   if ((int)mode == (int)TYPE_MODE (intQI_type_node))
3790     return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
3791
3792   if ((int)mode == (int)TYPE_MODE (intHI_type_node))
3793     return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
3794
3795   if ((int)mode == (int)TYPE_MODE (intSI_type_node))
3796     return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
3797
3798   if ((int)mode == (int)TYPE_MODE (intDI_type_node))
3799     return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
3800
3801 #if HOST_BITS_PER_WIDE_INT >= 64
3802   if ((int)mode == (int)TYPE_MODE (intTI_type_node))
3803     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
3804 #endif
3805
3806   if ((int)mode == (int)TYPE_MODE (float_type_node))
3807     return float_type_node;
3808
3809   if ((int)mode == (int)TYPE_MODE (double_type_node))
3810     return double_type_node;
3811
3812   if ((int)mode == (int)TYPE_MODE (long_double_type_node))
3813     return long_double_type_node;
3814
3815   if ((int)mode == (int)TYPE_MODE (build_pointer_type (char_type_node)))
3816     return build_pointer_type (char_type_node);
3817
3818   if ((int)mode == (int)TYPE_MODE (build_pointer_type (integer_type_node)))
3819     return build_pointer_type (integer_type_node);
3820
3821   return 0;
3822 }