�

Migrate from devo/gcc/ch.

From-SVN: r22034

1 files changed, 293 insertions, 0 deletions

diff --git a/gcc/ch/tree.c b/gcc/ch/tree.c
new file mode 100644
index 0000000..b1d0168
--- /dev/null
+++ b/gcc/ch/tree.c
@@ -0,0 +1,293 @@
+/* Language-dependent node constructors for parse phase of GNU compiler.
+   Copyright (C) 1992, 93, 1994  Free Software Foundation, Inc.
+
+This file is part of GNU CC.
+
+GNU CC is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU CC is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU CC; see the file COPYING.  If not, write to
+the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+
+#include "config.h"
+#include "obstack.h"
+#include "tree.h"
+#include "ch-tree.h"
+
+/* Here is how primitive or already-canonicalized types' 
+   hash codes are made.  */
+#define TYPE_HASH(TYPE) ((HOST_WIDE_INT) (TYPE) & 0777777)
+
+extern void error PROTO((char *, ...));
+extern int  get_type_precision PROTO((tree, tree));
+
+extern struct obstack permanent_obstack;
+/* This is special sentinel used to communicate from build_string_type
+   to layout_chill_range_type for the index range of a string. */
+tree string_index_type_dummy;
+
+/* Build a chill string type.
+   For a character string, ELT_TYPE==char_type_node; 
+   for a bit-string, ELT_TYPE==boolean_type_node. */
+
+tree
+build_string_type (elt_type, length)
+     tree elt_type;
+     tree length;
+{
+  register tree t;
+
+  if (TREE_CODE (elt_type) == ERROR_MARK || TREE_CODE (length) == ERROR_MARK)
+    return error_mark_node;
+
+  /* Allocate the array after the pointer type,
+     in case we free it in type_hash_canon.  */
+
+  if (pass > 0 && TREE_CODE (length) == INTEGER_CST
+      && ! tree_int_cst_equal (length, integer_zero_node)
+      && compare_int_csts (LT_EXPR, TYPE_MAX_VALUE (chill_unsigned_type_node),
+			   length))
+    {
+      error ("string length > UPPER (UINT)");
+      length = integer_one_node;
+    }
+
+  /* Subtract 1 from length to get max index value.
+     Note we cannot use size_binop for pass 1 expressions. */
+  if (TREE_CODE (length) == INTEGER_CST || pass != 1)
+    length = size_binop (MINUS_EXPR, length, integer_one_node);
+  else
+    length = build (MINUS_EXPR, sizetype, length, integer_one_node);
+
+  t = make_node (elt_type == boolean_type_node ? SET_TYPE : ARRAY_TYPE);
+  TREE_TYPE (t) = elt_type;
+
+  MARK_AS_STRING_TYPE (t);
+
+  TYPE_DOMAIN (t) = build_chill_range_type (string_index_type_dummy,
+					    integer_zero_node, length);
+  if (pass == 1 && TREE_CODE (length) == INTEGER_CST)
+    TYPE_DOMAIN (t) = layout_chill_range_type (TYPE_DOMAIN (t), 0);
+
+  if (pass != 1
+      || (TREE_CODE (length) == INTEGER_CST && TYPE_SIZE (elt_type)))
+    {
+      if (TREE_CODE (t) == SET_TYPE)
+	t = layout_powerset_type (t);
+      else
+	t = layout_chill_array_type (t);
+    }
+  return t;
+}
+
+tree
+make_powerset_type (domain)
+     tree domain;
+{
+  tree t = make_node (SET_TYPE);
+
+  TREE_TYPE (t) = boolean_type_node;
+  TYPE_DOMAIN (t) = domain;
+  
+  return t;
+}
+
+/* Used to layout both bitstring and powerset types. */
+
+tree
+layout_powerset_type (type)
+     tree type;
+{
+  tree domain = TYPE_DOMAIN (type);
+
+  if (! discrete_type_p (domain))
+    {
+      error ("Can only build a powerset from a discrete mode");
+      return error_mark_node;
+    }
+
+  if (TREE_CODE (TYPE_MAX_VALUE (domain)) == ERROR_MARK ||
+      TREE_CODE (TYPE_MIN_VALUE (domain)) == ERROR_MARK)
+    return error_mark_node;
+
+  if (TREE_CODE (TYPE_MAX_VALUE (domain)) != INTEGER_CST
+      || TREE_CODE (TYPE_MIN_VALUE (domain)) != INTEGER_CST)
+    {
+      if (CH_BOOLS_TYPE_P (type))
+	error ("non-constant bitstring size invalid");
+      else
+	error ("non-constant powerset size invalid");
+      return error_mark_node;
+    }
+
+  if (TYPE_SIZE (type) == 0)
+    layout_type (type);
+  return type;
+}
+
+/* Build a SET_TYPE node whose elements are from the set of values
+   in TYPE.  TYPE must be a discrete mode; we check for that here. */
+tree
+build_powerset_type (type)
+     tree type;
+{
+  tree t = make_powerset_type (type);
+  if (pass != 1)
+    t = layout_powerset_type (t);
+  return t;
+}
+
+tree
+build_bitstring_type (size_in_bits)
+     tree size_in_bits;
+{
+  return build_string_type (boolean_type_node, size_in_bits);
+}
+
+/* Return get_identifier (the concatenations of part1, part2, and part3). */
+
+tree
+get_identifier3 (part1, part2, part3)
+     char *part1, *part2, *part3;
+{
+  char *buf = (char*)
+    alloca (strlen(part1) + strlen(part2) + strlen(part3) + 1);
+  sprintf (buf, "%s%s%s", part1, part2, part3);
+  return get_identifier (buf);
+}
+
+/* Build an ALIAS_DECL for the prefix renamed clause:
+   (OLD_PREFIX -> NEW_PREFIX) ! POSTFIX. */
+
+tree
+build_alias_decl (old_prefix, new_prefix, postfix)
+     tree old_prefix, new_prefix, postfix;
+{
+  tree decl = make_node (ALIAS_DECL);
+
+  char *postfix_pointer = IDENTIFIER_POINTER (postfix);
+  int postfix_length = IDENTIFIER_LENGTH (postfix);
+  int old_length = old_prefix ? IDENTIFIER_LENGTH(old_prefix) : 0;
+  int new_length = new_prefix ? IDENTIFIER_LENGTH(new_prefix) : 0;
+
+  char *buf = (char*) alloca (old_length + new_length + postfix_length + 3);
+
+  /* Convert (OP->NP)!P!ALL to (OP!P->NP!P)!ALL */
+  if (postfix_length > 1 && postfix_pointer[postfix_length-1] == '*')
+    {
+      int chopped_length = postfix_length - 2; /* Without final "!*" */
+      if (old_prefix)
+	sprintf (buf, "%s!%.*s", IDENTIFIER_POINTER (old_prefix),
+		 chopped_length, postfix_pointer);
+      else
+	sprintf (buf, "%.*s", chopped_length, postfix_pointer);
+      old_prefix = get_identifier (buf);
+      if (new_prefix)
+	sprintf (buf, "%s!%.*s", IDENTIFIER_POINTER (new_prefix),
+		 chopped_length, postfix_pointer);
+      else
+	sprintf (buf, "%.*s", chopped_length, postfix_pointer);
+      new_prefix = get_identifier (buf);
+      postfix = ALL_POSTFIX;
+    }
+
+  DECL_OLD_PREFIX (decl) = old_prefix;
+  DECL_NEW_PREFIX (decl) = new_prefix;
+  DECL_POSTFIX (decl) = postfix;
+
+  if (DECL_POSTFIX_ALL (decl))
+    DECL_NAME (decl) = NULL_TREE;
+  else if (new_prefix == NULL_TREE)
+    DECL_NAME (decl) = postfix;
+  else
+    DECL_NAME (decl) = get_identifier3 (IDENTIFIER_POINTER (new_prefix),
+					"!", IDENTIFIER_POINTER (postfix));
+
+  return decl;
+}
+
+/* Return the "old name string" of an ALIAS_DECL. */
+
+tree
+decl_old_name (decl)
+     tree decl;
+{
+  
+  if (DECL_OLD_PREFIX (decl) == NULL_TREE)
+    return DECL_POSTFIX (decl);
+  return get_identifier3 (IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl)),
+			  "!", IDENTIFIER_POINTER (DECL_POSTFIX (decl)));
+}
+
+/* See if OLD_NAME (an identifier) matches the OLD_PREFIX!POSTFIX
+   of ALIAS.  If so, return the corresponding NEW_NEW!POSTFIX. */
+
+tree
+decl_check_rename (alias, old_name)
+     tree alias, old_name;
+{
+  char *old_pointer = IDENTIFIER_POINTER (old_name);
+  int old_len = IDENTIFIER_LENGTH (old_name);
+  if (DECL_OLD_PREFIX (alias))
+    {
+      int old_prefix_len = IDENTIFIER_LENGTH (DECL_OLD_PREFIX (alias));
+      if (old_prefix_len >= old_len
+	  || old_pointer[old_prefix_len] != '!'
+	  || strncmp (old_pointer, IDENTIFIER_POINTER (DECL_OLD_PREFIX (alias)), old_prefix_len) != 0)
+	return NULL_TREE;
+
+      /* Skip the old prefix. */
+      old_pointer += old_prefix_len + 1; /* Also skip the '!', */
+    }
+  if (DECL_POSTFIX_ALL (alias)
+      || strcmp (IDENTIFIER_POINTER (DECL_POSTFIX (alias)), old_pointer) == 0)
+    {
+      if (DECL_NEW_PREFIX (alias))
+	return get_identifier3 (IDENTIFIER_POINTER (DECL_NEW_PREFIX (alias)),
+				"!", old_pointer);
+      else if (old_pointer == IDENTIFIER_POINTER (old_name))
+	return old_name;
+      else
+	return get_identifier (old_pointer);
+    }
+  else
+    return NULL_TREE;
+}
+
+/* 'EXIT foo' is treated like 'GOTO EXIT!foo'.
+    This function converts LABEL into a labal name for EXIT. */
+
+tree
+munge_exit_label (label)
+     tree label;
+{
+  return get_identifier3 ("EXIT", "!", IDENTIFIER_POINTER (label));
+}
+
+/* Make SAVE_EXPRs as needed, but don't turn a location into a non-location. */
+
+tree
+save_if_needed (exp)
+tree exp;
+{
+  return CH_REFERABLE (exp) ? stabilize_reference (exp) : save_expr (exp);
+}
+
+/* Return the number of elements in T, which must be a discrete type. */
+tree
+discrete_count (t)
+     tree t;
+{
+  tree hi = convert (sizetype, TYPE_MAX_VALUE (t));
+  if (TYPE_MIN_VALUE (t))
+    hi = size_binop (MINUS_EXPR, hi, convert (sizetype, TYPE_MIN_VALUE (t)));
+  return size_binop (PLUS_EXPR, hi, integer_one_node);
+}