gcc/ch/tree.c

   1 /* Language-dependent node constructors for parse phase of GNU compiler.
   2    Copyright (C) 1992, 93, 94, 98, 99, 2000  Free Software Foundation, Inc.
   3
   4 This file is part of GNU CC.
   5
   6 GNU CC is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU CC is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU CC; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "obstack.h"
  24 #include "tree.h"
  25 #include "ch-tree.h"
  26 #include "toplev.h"
  27
  28 /* Here is how primitive or already-canonicalized types'
  29    hash codes are made.  */
  30 #define TYPE_HASH(TYPE) ((HOST_WIDE_INT) (TYPE) & 0777777)
  31
  32 extern struct obstack permanent_obstack;
  33 /* This is special sentinel used to communicate from build_string_type
  34    to layout_chill_range_type for the index range of a string. */
  35 tree string_index_type_dummy;
  36
  37 static tree make_powerset_type                          PARAMS ((tree));
  38 \f
  39 /* Build a chill string type.
  40    For a character string, ELT_TYPE==char_type_node;
  41    for a bit-string, ELT_TYPE==boolean_type_node. */
  42
  43 tree
  44 build_string_type (elt_type, length)
  45      tree elt_type;
  46      tree length;
  47 {
  48   register tree t;
  49
  50   if (TREE_CODE (elt_type) == ERROR_MARK || TREE_CODE (length) == ERROR_MARK)
  51     return error_mark_node;
  52
  53   /* Allocate the array after the pointer type,
  54      in case we free it in type_hash_canon.  */
  55
  56   if (pass > 0 && TREE_CODE (length) == INTEGER_CST
  57       && ! tree_int_cst_equal (length, integer_zero_node)
  58       && compare_int_csts (LT_EXPR, TYPE_MAX_VALUE (chill_unsigned_type_node),
  59                            length))
  60     {
  61       error ("string length > UPPER (UINT)");
  62       length = integer_one_node;
  63     }
  64
  65   /* Subtract 1 from length to get max index value.
  66      Note we cannot use size_binop for pass 1 expressions. */
  67   if (TREE_CODE (length) == INTEGER_CST || pass != 1)
  68     length = size_binop (MINUS_EXPR, length, integer_one_node);
  69   else
  70     length = build (MINUS_EXPR, sizetype, length, integer_one_node);
  71
  72   t = make_node (elt_type == boolean_type_node ? SET_TYPE : ARRAY_TYPE);
  73   TREE_TYPE (t) = elt_type;
  74
  75   MARK_AS_STRING_TYPE (t);
  76
  77   TYPE_DOMAIN (t) = build_chill_range_type (string_index_type_dummy,
  78                                             integer_zero_node, length);
  79   if (pass == 1 && TREE_CODE (length) == INTEGER_CST)
  80     TYPE_DOMAIN (t) = layout_chill_range_type (TYPE_DOMAIN (t), 0);
  81
  82   if (pass != 1
  83       || (TREE_CODE (length) == INTEGER_CST && TYPE_SIZE (elt_type)))
  84     {
  85       if (TREE_CODE (t) == SET_TYPE)
  86         t = layout_powerset_type (t);
  87       else
  88         t = layout_chill_array_type (t);
  89     }
  90   return t;
  91 }
  92 \f
  93 static tree
  94 make_powerset_type (domain)
  95      tree domain;
  96 {
  97   tree t = make_node (SET_TYPE);
  98
  99   TREE_TYPE (t) = boolean_type_node;
 100   TYPE_DOMAIN (t) = domain;
 101
 102   return t;
 103 }
 104
 105 /* Used to layout both bitstring and powerset types. */
 106
 107 tree
 108 layout_powerset_type (type)
 109      tree type;
 110 {
 111   tree domain = TYPE_DOMAIN (type);
 112
 113   if (! discrete_type_p (domain))
 114     {
 115       error ("Can only build a powerset from a discrete mode");
 116       return error_mark_node;
 117     }
 118
 119   if (TREE_CODE (TYPE_MAX_VALUE (domain)) == ERROR_MARK ||
 120       TREE_CODE (TYPE_MIN_VALUE (domain)) == ERROR_MARK)
 121     return error_mark_node;
 122
 123   if (TREE_CODE (TYPE_MAX_VALUE (domain)) != INTEGER_CST
 124       || TREE_CODE (TYPE_MIN_VALUE (domain)) != INTEGER_CST)
 125     {
 126       if (CH_BOOLS_TYPE_P (type))
 127         error ("non-constant bitstring size invalid");
 128       else
 129         error ("non-constant powerset size invalid");
 130       return error_mark_node;
 131     }
 132
 133   if (TYPE_SIZE (type) == 0)
 134     layout_type (type);
 135   return type;
 136 }
 137
 138 /* Build a SET_TYPE node whose elements are from the set of values
 139    in TYPE.  TYPE must be a discrete mode; we check for that here. */
 140 tree
 141 build_powerset_type (type)
 142      tree type;
 143 {
 144   tree t = make_powerset_type (type);
 145   if (pass != 1)
 146     t = layout_powerset_type (t);
 147   return t;
 148 }
 149
 150 tree
 151 build_bitstring_type (size_in_bits)
 152      tree size_in_bits;
 153 {
 154   return build_string_type (boolean_type_node, size_in_bits);
 155 }
 156
 157 /* Return get_identifier (the concatenations of part1, part2, and part3). */
 158
 159 tree
 160 get_identifier3 (part1, part2, part3)
 161      const char *part1, *part2, *part3;
 162 {
 163   char *buf = (char*)
 164     alloca (strlen(part1) + strlen(part2) + strlen(part3) + 1);
 165   sprintf (buf, "%s%s%s", part1, part2, part3);
 166   return get_identifier (buf);
 167 }
 168
 169 /* Build an ALIAS_DECL for the prefix renamed clause:
 170    (OLD_PREFIX -> NEW_PREFIX) ! POSTFIX. */
 171
 172 tree
 173 build_alias_decl (old_prefix, new_prefix, postfix)
 174      tree old_prefix, new_prefix, postfix;
 175 {
 176   tree decl = make_node (ALIAS_DECL);
 177
 178   const char *postfix_pointer = IDENTIFIER_POINTER (postfix);
 179   int postfix_length = IDENTIFIER_LENGTH (postfix);
 180   int old_length = old_prefix ? IDENTIFIER_LENGTH(old_prefix) : 0;
 181   int new_length = new_prefix ? IDENTIFIER_LENGTH(new_prefix) : 0;
 182
 183   char *buf = (char*) alloca (old_length + new_length + postfix_length + 3);
 184
 185   /* Convert (OP->NP)!P!ALL to (OP!P->NP!P)!ALL */
 186   if (postfix_length > 1 && postfix_pointer[postfix_length-1] == '*')
 187     {
 188       int chopped_length = postfix_length - 2; /* Without final "!*" */
 189       if (old_prefix)
 190         sprintf (buf, "%s!%.*s", IDENTIFIER_POINTER (old_prefix),
 191                  chopped_length, postfix_pointer);
 192       else
 193         sprintf (buf, "%.*s", chopped_length, postfix_pointer);
 194       old_prefix = get_identifier (buf);
 195       if (new_prefix)
 196         sprintf (buf, "%s!%.*s", IDENTIFIER_POINTER (new_prefix),
 197                  chopped_length, postfix_pointer);
 198       else
 199         sprintf (buf, "%.*s", chopped_length, postfix_pointer);
 200       new_prefix = get_identifier (buf);
 201       postfix = ALL_POSTFIX;
 202     }
 203
 204   DECL_OLD_PREFIX (decl) = old_prefix;
 205   DECL_NEW_PREFIX (decl) = new_prefix;
 206   DECL_POSTFIX (decl) = postfix;
 207
 208   if (DECL_POSTFIX_ALL (decl))
 209     DECL_NAME (decl) = NULL_TREE;
 210   else if (new_prefix == NULL_TREE)
 211     DECL_NAME (decl) = postfix;
 212   else
 213     DECL_NAME (decl) = get_identifier3 (IDENTIFIER_POINTER (new_prefix),
 214                                         "!", IDENTIFIER_POINTER (postfix));
 215
 216   return decl;
 217 }
 218
 219 /* Return the "old name string" of an ALIAS_DECL. */
 220
 221 tree
 222 decl_old_name (decl)
 223      tree decl;
 224 {
 225
 226   if (DECL_OLD_PREFIX (decl) == NULL_TREE)
 227     return DECL_POSTFIX (decl);
 228   return get_identifier3 (IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl)),
 229                           "!", IDENTIFIER_POINTER (DECL_POSTFIX (decl)));
 230 }
 231
 232 /* See if OLD_NAME (an identifier) matches the OLD_PREFIX!POSTFIX
 233    of ALIAS.  If so, return the corresponding NEW_NEW!POSTFIX. */
 234
 235 tree
 236 decl_check_rename (alias, old_name)
 237      tree alias, old_name;
 238 {
 239   const char *old_pointer = IDENTIFIER_POINTER (old_name);
 240   int old_len = IDENTIFIER_LENGTH (old_name);
 241   if (DECL_OLD_PREFIX (alias))
 242     {
 243       int old_prefix_len = IDENTIFIER_LENGTH (DECL_OLD_PREFIX (alias));
 244       if (old_prefix_len >= old_len
 245           || old_pointer[old_prefix_len] != '!'
 246           || strncmp (old_pointer, IDENTIFIER_POINTER (DECL_OLD_PREFIX (alias)), old_prefix_len) != 0)
 247         return NULL_TREE;
 248
 249       /* Skip the old prefix. */
 250       old_pointer += old_prefix_len + 1; /* Also skip the '!', */
 251     }
 252   if (DECL_POSTFIX_ALL (alias)
 253       || strcmp (IDENTIFIER_POINTER (DECL_POSTFIX (alias)), old_pointer) == 0)
 254     {
 255       if (DECL_NEW_PREFIX (alias))
 256         return get_identifier3 (IDENTIFIER_POINTER (DECL_NEW_PREFIX (alias)),
 257                                 "!", old_pointer);
 258       else if (old_pointer == IDENTIFIER_POINTER (old_name))
 259         return old_name;
 260       else
 261         return get_identifier (old_pointer);
 262     }
 263   else
 264     return NULL_TREE;
 265 }
 266
 267 /* 'EXIT foo' is treated like 'GOTO EXIT!foo'.
 268     This function converts LABEL into a labal name for EXIT. */
 269
 270 tree
 271 munge_exit_label (label)
 272      tree label;
 273 {
 274   return get_identifier3 ("EXIT", "!", IDENTIFIER_POINTER (label));
 275 }
 276
 277 /* Make SAVE_EXPRs as needed, but don't turn a location into a non-location. */
 278
 279 tree
 280 save_if_needed (exp)
 281 tree exp;
 282 {
 283   return CH_REFERABLE (exp) ? stabilize_reference (exp) : save_expr (exp);
 284 }
 285
 286 /* Return the number of elements in T, which must be a discrete type. */
 287 tree
 288 discrete_count (t)
 289      tree t;
 290 {
 291   tree hi = convert (sizetype, TYPE_MAX_VALUE (t));
 292   if (TYPE_MIN_VALUE (t))
 293     hi = size_binop (MINUS_EXPR, hi, convert (sizetype, TYPE_MIN_VALUE (t)));
 294   return size_binop (PLUS_EXPR, hi, integer_one_node);
 295 }