�

Migrate from devo/gcc/ch.

From-SVN: r22038

1 files changed, 1231 insertions, 0 deletions

diff --git a/gcc/ch/convert.c b/gcc/ch/convert.c
new file mode 100644
index 0000000..d865336
--- /dev/null
+++ b/gcc/ch/convert.c
@@ -0,0 +1,1231 @@
+/* Language-level data type conversion for GNU CHILL.
+   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.  */
+
+
+/* This file contains the functions for converting CHILL expressions
+   to different data types.  The only entry point is `convert'.
+   Every language front end must have a `convert' function
+   but what kind of conversions it does will depend on the language.  */
+
+#include "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "convert.h"
+#include "lex.h"
+
+extern void error                              PROTO((char *, ...));
+extern tree initializer_constant_valid_p       PROTO((tree, tree));
+extern tree bit_one_node, bit_zero_node;
+extern tree string_one_type_node;
+extern tree bitstring_one_type_node;
+
+static tree
+convert_to_reference (reftype, expr)
+     tree reftype, expr;
+{
+  while (TREE_CODE (expr) == NOP_EXPR)  /* RETYPE_EXPR */
+    expr = TREE_OPERAND (expr, 0);
+
+  if (! CH_LOCATION_P (expr))
+    error("internal error: trying to make loc-identity with non-location");
+  else
+    {
+      mark_addressable (expr);
+      return fold (build1 (ADDR_EXPR, reftype, expr));
+    }
+
+  return error_mark_node;
+}
+
+tree
+convert_from_reference (expr)
+     tree expr;
+{
+  tree e = build1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (expr)), expr);
+  TREE_READONLY (e) = TREE_READONLY (expr);
+  return e;
+}
+
+/* Convert EXPR to a boolean type.  */
+
+static tree
+convert_to_boolean (type, expr)
+     tree type, expr;
+{
+  register tree intype = TREE_TYPE (expr);
+  
+  if (integer_zerop (expr))
+    return boolean_false_node;
+  if (integer_onep (expr))
+    return boolean_true_node;
+
+  /* Convert a singleton bitstring to a Boolean.
+     Needed if flag_old_strings. */
+  if (CH_BOOLS_ONE_P (intype))
+    {
+      if (TREE_CODE (expr) == CONSTRUCTOR)
+	{
+	  tree valuelist = TREE_OPERAND (expr, 1);
+	  if (valuelist == NULL_TREE)
+	    return boolean_false_node;
+	  if (TREE_CHAIN (valuelist) == NULL_TREE
+	      && TREE_PURPOSE (valuelist) == NULL_TREE
+	      && integer_zerop (TREE_VALUE (valuelist)))
+	    return boolean_true_node;
+	}
+      return build_chill_bitref (expr,
+				 build_tree_list (NULL_TREE,
+						  integer_zero_node));
+    }
+
+  if (INTEGRAL_TYPE_P (intype))
+    return build1 (CONVERT_EXPR, type, expr);
+
+  error ("cannot convert to a boolean mode");
+  return boolean_false_node;
+}
+
+/* Convert EXPR to a char type.  */
+
+static tree
+convert_to_char (type, expr)
+     tree type, expr;
+{
+  register tree intype = TREE_TYPE (expr);
+  register enum chill_tree_code form = TREE_CODE (intype);
+  
+  if (form == CHAR_TYPE)
+    return build1 (NOP_EXPR, type, expr);
+
+  /* Convert a singleton string to a char.
+     Needed if flag_old_strings. */
+  if (CH_CHARS_ONE_P (intype))
+    {
+      if (TREE_CODE (expr) == STRING_CST)
+	{
+	  expr = build_int_2 ((unsigned char)TREE_STRING_POINTER(expr)[0], 0);
+	  TREE_TYPE (expr) = char_type_node;
+	  return expr;
+	}
+      else
+	return build (ARRAY_REF, char_type_node, expr, integer_zero_node);
+
+    }
+
+  /* For now, assume it will always fit */
+  if (form == INTEGER_TYPE)
+    return build1 (CONVERT_EXPR, type, expr);
+
+  error ("cannot convert to a char mode");
+
+  {
+    register tree tem = build_int_2 (0, 0);
+    TREE_TYPE (tem) = type;
+    return tem;
+  }
+}
+
+tree
+base_type_size_in_bytes (type)
+     tree type;
+{
+  if (type == NULL_TREE
+      || TREE_CODE (type) == ERROR_MARK
+      || TREE_CODE (type) != ARRAY_TYPE)
+    return error_mark_node;
+  return size_in_bytes (TREE_TYPE (type));
+}
+
+/*
+ * build a singleton array type, of TYPE objects.
+ */
+tree
+build_array_type_for_scalar (type)
+     tree type;
+{
+  /* KLUDGE */
+  if (type == char_type_node)
+    return build_string_type (type, integer_one_node);
+
+  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+    return error_mark_node;
+
+  return build_chill_array_type
+    (type,
+     tree_cons (NULL_TREE,
+		build_chill_range_type (NULL_TREE,
+					integer_zero_node, integer_zero_node),
+		NULL_TREE),
+     0, NULL_TREE);
+
+}
+
+#if 0
+static tree
+unreferenced_type_of (type)
+     tree type;
+{
+  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+    return error_mark_node;
+  while (TREE_CODE (type) == REFERENCE_TYPE)
+    type = TREE_TYPE (type);
+  return type;
+}
+#endif
+
+
+/* Remove from *LISTP the first TREE_LIST node whose TREE_PURPOSE == KEY.
+   Return the TREE_LIST node, or NULL_TREE on failure. */
+
+static tree
+remove_tree_element (key, listp)
+     tree *listp;
+     tree key;
+{
+  tree node = *listp;
+  for ( ; node; listp = &TREE_CHAIN (node), node = *listp)
+    {
+      if (TREE_PURPOSE (node) == key)
+	{
+	  *listp = TREE_CHAIN (node);
+	  TREE_CHAIN (node) = NULL_TREE;
+	  return node;
+	}
+    }
+  return NULL_TREE;
+}
+
+/* This is quite the same as check_range in actions.c, but with
+   different error message. */
+
+static tree
+check_ps_range (value, lo_limit, hi_limit)
+     tree value;
+     tree lo_limit;
+     tree hi_limit;
+{
+  tree check = test_range (value, lo_limit, hi_limit);
+
+  if (!integer_zerop (check))
+    {
+      if (TREE_CODE (check) == INTEGER_CST)
+	{
+	  error ("powerset tuple element out of range");
+	  return error_mark_node;
+	}
+      else
+	value = check_expression (value, check,
+				  ridpointers[(int) RID_RANGEFAIL]);
+    }
+  return value;
+}
+
+static tree
+digest_powerset_tuple (type, inits)
+     tree type;
+     tree inits;
+{
+  tree list;
+  tree result;
+  tree domain = TYPE_DOMAIN (type);
+  int i = 0;
+  int is_erroneous = 0, is_constant = 1, is_simple = 1;
+  if (domain == NULL_TREE || TREE_CODE (domain) == ERROR_MARK)
+    return error_mark_node;
+  for (list = TREE_OPERAND (inits, 1);  list; list = TREE_CHAIN (list), i++)
+    {
+      tree val = TREE_VALUE (list);
+      if (TREE_CODE (val) == ERROR_MARK)
+	{
+	  is_erroneous = 1;
+	  continue;
+	}
+      if (!TREE_CONSTANT (val))
+	is_constant = 0;
+      else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
+	is_simple = 0;
+      if (! CH_COMPATIBLE (val, domain))
+	{
+	  error ("incompatible member of powerset tuple (at position #%d)", i);
+	  is_erroneous = 1;
+	  continue;
+	}
+      /* check range of value */
+      val = check_ps_range (val, TYPE_MIN_VALUE (domain),
+			    TYPE_MAX_VALUE (domain));
+      if (TREE_CODE (val) == ERROR_MARK)
+	{
+	  is_erroneous = 1;
+	  continue;
+	}
+
+      /* Updating the list in place is in principle questionable,
+	 but I can't think how it could hurt. */
+      TREE_VALUE (list) = convert (domain, val);
+
+      val = TREE_PURPOSE (list);
+      if (val == NULL_TREE)
+	continue;
+
+      if (TREE_CODE (val) == ERROR_MARK)
+	{
+	  is_erroneous = 1;
+	  continue;
+	}
+      if (! CH_COMPATIBLE (val, domain))
+	{
+	  error ("incompatible member of powerset tuple (at position #%d)", i);
+	  is_erroneous = 1;
+	  continue;
+	}
+      val = check_ps_range (val, TYPE_MIN_VALUE (domain),
+			    TYPE_MAX_VALUE (domain));
+      if (TREE_CODE (val) == ERROR_MARK)
+	{
+	  is_erroneous = 1;
+	  continue;
+	}
+      TREE_PURPOSE (list) = convert (domain, val);
+      if (!TREE_CONSTANT (val))
+	is_constant = 0;
+      else if (!initializer_constant_valid_p (val, TREE_TYPE (val)))
+	is_simple = 0;
+    }
+  result = build (CONSTRUCTOR, type, NULL_TREE, TREE_OPERAND (inits, 1));
+  if (is_erroneous)
+    return error_mark_node;
+  if (is_constant)
+    TREE_CONSTANT (result) = 1;
+  if (is_constant && is_simple)
+    TREE_STATIC (result) = 1;
+  return result;
+}
+
+static tree
+digest_structure_tuple (type, inits)
+     tree type;
+     tree inits;
+{
+  tree elements = CONSTRUCTOR_ELTS (inits);
+  tree values = NULL_TREE;
+  int is_constant = 1;
+  int is_simple = 1;
+  int is_erroneous = 0;
+  tree field;
+  int labelled_elements = 0;
+  int unlabelled_elements = 0;
+  for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
+    {
+      if (TREE_CODE (TREE_TYPE (field)) != UNION_TYPE)
+	{ /* Regular fixed field. */
+	  tree value = remove_tree_element (DECL_NAME (field), &elements);
+
+	  if (value)
+	    labelled_elements++;
+	  else if (elements && TREE_PURPOSE (elements) == NULL_TREE)
+	    {
+	      value = elements;
+	      elements = TREE_CHAIN (elements);
+	      unlabelled_elements++;
+	    }
+
+	  if (value)
+	    {
+	      tree val;
+	      char msg[120];
+	      sprintf (msg, "initializer for field `%.80s'",
+		       IDENTIFIER_POINTER (DECL_NAME (field)));
+	      val = chill_convert_for_assignment (TREE_TYPE (field),
+						  TREE_VALUE (value), msg);
+	      if (TREE_CODE (val) == ERROR_MARK)
+		  is_erroneous = 1;
+	      else
+		{
+		  TREE_VALUE (value) = val;
+		  TREE_CHAIN (value) = values;
+		  TREE_PURPOSE (value) = field;
+		  values = value;	
+		  if (TREE_CODE (val) == ERROR_MARK)
+		    is_erroneous = 1;
+		  else if (!TREE_CONSTANT (val))
+		    is_constant = 0;
+		  else if (!initializer_constant_valid_p (val,
+							  TREE_TYPE (val)))
+		    is_simple = 0;
+		}
+	    }
+	  else
+	    {
+	      pedwarn ("no initializer value for fixed field `%s'",
+		       IDENTIFIER_POINTER (DECL_NAME (field)));
+	    }
+	}
+      else
+	{
+	  tree variant;
+	  tree selected_variant = NULL_TREE;
+	  tree variant_values = NULL_TREE;
+
+	  /* In a tagged variant structure mode, try to figure out
+	     (from the fixed fields), which is the selected variant. */
+	  if (TYPE_TAGFIELDS (TREE_TYPE (field)))
+	    {
+	      for (variant = TYPE_FIELDS (TREE_TYPE (field));
+		   variant; variant = TREE_CHAIN (variant))
+		{
+		  tree tag_labels = TYPE_TAG_VALUES (TREE_TYPE (variant));
+		  tree tag_fields = TYPE_TAGFIELDS (TREE_TYPE (field));
+		  if (DECL_NAME (variant) == ELSE_VARIANT_NAME)
+		    {
+		      selected_variant = variant;
+		      break;
+		    }
+		  for (; tag_labels && tag_fields;
+		       tag_labels = TREE_CHAIN (tag_labels),
+		       tag_fields = TREE_CHAIN (tag_fields))
+		    {
+		      tree tag_value = values;
+		      int found = 0;
+		      tree tag_decl = TREE_VALUE (tag_fields);
+		      tree tag_value_set = TREE_VALUE (tag_labels);
+		      for ( ; tag_value; tag_value = TREE_CHAIN (tag_value))
+			{
+			  if (TREE_PURPOSE (tag_value) == tag_decl)
+			    {
+			      tag_value = TREE_VALUE (tag_value);
+			      break;
+			    }
+			}
+		      if (!tag_value || TREE_CODE (tag_value) != INTEGER_CST)
+			{
+			  pedwarn ("non-constant value for tag field `%s'",
+				   IDENTIFIER_POINTER (DECL_NAME (tag_decl)));
+			  goto get_values;
+			}
+
+		      /* Check if the value of the tag (as given in a
+			 previous field) matches the case label list. */
+		      for (; tag_value_set;
+			   tag_value_set = TREE_CHAIN (tag_value_set))
+			{
+			  if (tree_int_cst_equal (TREE_VALUE (tag_value_set),
+						  tag_value))
+			    {
+			      found = 1;
+			      break;
+			    }
+			}
+		      if (!found)
+			break;
+		    }
+		  if (!tag_fields)
+		    {
+		      selected_variant = variant;
+		      break;
+		    }
+		}
+	    }
+	get_values:
+	  for (variant = TYPE_FIELDS (TREE_TYPE (field));
+	       variant; variant = TREE_CHAIN (variant))
+	    {
+	      tree vfield0 = TYPE_FIELDS (TREE_TYPE (variant)); 
+	      tree vfield;
+	      for (vfield = vfield0; vfield;  vfield = TREE_CHAIN (vfield))
+		{
+		  tree value = remove_tree_element (DECL_NAME (vfield),
+						    &elements);
+
+		  if (value)
+		    labelled_elements++;
+		  else if (variant == selected_variant
+			   && elements && TREE_PURPOSE (elements) == NULL_TREE)
+		    {
+		      value = elements;
+		      elements = TREE_CHAIN (elements);
+		      unlabelled_elements++;
+		    }
+
+		  if (value)
+		    {
+		      if (selected_variant && selected_variant != variant)
+			{
+			  error ("field `%s' in wrong variant",
+				 IDENTIFIER_POINTER (DECL_NAME (vfield)));
+			  is_erroneous = 1;
+			}
+		      else
+			{
+			  if (!selected_variant && vfield != vfield0)
+			    pedwarn ("missing variant fields (at least `%s')",
+				     IDENTIFIER_POINTER (DECL_NAME (vfield0)));
+			  selected_variant = variant;
+			  if (CH_COMPATIBLE (TREE_VALUE (value),
+					     TREE_TYPE (vfield)))
+			    {
+			      tree val = convert (TREE_TYPE (vfield),
+						  TREE_VALUE (value));
+			      TREE_PURPOSE (value) = vfield;
+			      TREE_VALUE (value) = val;
+			      TREE_CHAIN (value) = variant_values;
+			      variant_values = value;
+			      if (TREE_CODE (val) == ERROR_MARK)
+				is_erroneous = 1;
+			      else if (!TREE_CONSTANT (val))
+				is_constant = 0;
+			      else if (!initializer_constant_valid_p
+				       (val, TREE_TYPE (val)))
+				is_simple = 0;
+			    }
+			  else
+			    {
+			      is_erroneous = 1;
+			      error ("bad initializer for field `%s'",
+				     IDENTIFIER_POINTER (DECL_NAME (vfield)));
+			    }
+			}
+		    }
+		  else if (variant == selected_variant)
+		    {
+		      pedwarn ("no initializer value for variant field `%s'",
+			       IDENTIFIER_POINTER (DECL_NAME (field)));
+		    }
+		}
+	    }
+	  if (selected_variant == NULL_TREE)
+	    pedwarn ("no selected variant");
+	  else
+	    {
+	      variant_values = build (CONSTRUCTOR,
+				      TREE_TYPE (selected_variant),
+				      NULL_TREE, nreverse (variant_values));
+	      variant_values
+		= build (CONSTRUCTOR, TREE_TYPE (field), NULL_TREE,
+			 build_tree_list (selected_variant, variant_values));
+	      values = tree_cons (field, variant_values, values);
+	    }
+	}
+    }
+
+  if (labelled_elements && unlabelled_elements)
+    pedwarn ("mixture of labelled and unlabelled tuple elements");
+
+  /* Check for unused initializer elements. */
+  unlabelled_elements = 0;
+  for ( ; elements != NULL_TREE; elements = TREE_CHAIN (elements))
+    {
+      if (TREE_PURPOSE (elements) == NULL_TREE)
+	unlabelled_elements++;
+      else
+	{
+	  if (IDENTIFIER_POINTER (TREE_PURPOSE (elements)) == 0)
+	    error ("probably not a structure tuple");
+	  else
+	    error ("excess initializer for field `%s'",
+		   IDENTIFIER_POINTER (TREE_PURPOSE (elements)));
+	  is_erroneous = 1;
+	}
+    }
+  if (unlabelled_elements)
+    {
+      error ("excess unnamed initializers");
+      is_erroneous = 1;
+    }
+
+  CONSTRUCTOR_ELTS (inits) = nreverse (values);
+  TREE_TYPE (inits) = type;
+  if (is_erroneous)
+    return error_mark_node;
+  if (is_constant)
+    TREE_CONSTANT (inits) = 1;
+  if (is_constant && is_simple)
+    TREE_STATIC (inits) = 1;
+  return inits;
+}
+
+/* Return a Chill representation of the INTEGER_CST VAL.
+   The result may be in a static buffer, */
+
+char *
+display_int_cst (val)
+     tree val;
+{
+  static char buffer[50];
+  HOST_WIDE_INT x;
+  tree fields;
+  if (TREE_CODE (val) != INTEGER_CST)
+    return "<not a constant>";
+
+  x = TREE_INT_CST_LOW (val);
+
+  switch (TREE_CODE (TREE_TYPE (val)))
+    {
+    case BOOLEAN_TYPE:
+      if (x == 0)
+	return "FALSE";
+      if (x == 1)
+	return "TRUE";
+      goto int_case;
+    case CHAR_TYPE:
+      if (x == '^')
+	strcpy (buffer, "'^^'");
+      else if (x == '\n')
+	strcpy (buffer, "'^J'");
+      else if (x < ' ' || x > '~')
+	sprintf (buffer, "'^(%u)'", x);
+      else
+	sprintf (buffer, "'%c'", x);
+      return buffer;
+    case ENUMERAL_TYPE:
+      for (fields = TYPE_VALUES (TREE_TYPE (val)); fields != NULL_TREE;
+	   fields = TREE_CHAIN (fields))
+	{
+	  if (tree_int_cst_equal (TREE_VALUE (fields), val))
+	    return IDENTIFIER_POINTER (TREE_PURPOSE (fields));
+	}
+      goto int_case;
+    case POINTER_TYPE:
+      if (x == 0)
+	return "NULL";
+      goto int_case;
+    int_case:
+    default:
+      /* This code is derived from print-tree.c:print_code_brief. */
+      if (TREE_INT_CST_HIGH (val) == 0)
+	sprintf (buffer,
+#if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
+		 "%1u",
+#else
+		 "%1lu",
+#endif
+		 x);
+      else if (TREE_INT_CST_HIGH (val) == -1 && TREE_INT_CST_LOW (val) != 0)
+	sprintf (buffer,
+#if HOST_BITS_PER_WIDE_INT == HOST_BITS_PER_INT
+		 "-%1u",
+#else
+		 "-%1lu",
+#endif
+		 -x);
+      else
+	sprintf (buffer,
+#if HOST_BITS_PER_WIDE_INT == 64
+#if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
+		 "H'%lx%016lx",
+#else
+		 "H'%x%016x",
+#endif
+#else
+#if HOST_BITS_PER_WIDE_INT != HOST_BITS_PER_INT
+		 "H'%lx%08lx",
+#else
+		 "H'%x%08x",
+#endif
+#endif
+		 TREE_INT_CST_HIGH (val), TREE_INT_CST_LOW (val));
+      return buffer;
+    }
+}
+
+static tree
+digest_array_tuple (type, init, allow_missing_elements)
+     tree type;
+     tree init;
+     int allow_missing_elements;
+{
+  tree element = CONSTRUCTOR_ELTS (init);
+  int is_constant = 1;
+  int is_simple = 1;
+  tree element_type = TREE_TYPE (type);
+  tree default_value = NULL_TREE;
+  tree element_list = NULL_TREE;
+  tree domain_min;
+  tree domain_max;
+  tree *ptr = &element_list;
+  int errors = 0;
+  int labelled_elements = 0;
+  int unlabelled_elements = 0;
+  tree first, last = NULL_TREE;
+
+  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+    return error_mark_node;
+
+  domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+  domain_max = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+
+  if (domain_min == NULL || TREE_CODE (domain_min) != INTEGER_CST)
+    {
+      error ("non-constant start index for tuple");
+      return error_mark_node;
+    }
+  if (TREE_CODE (domain_max) != INTEGER_CST)
+    is_constant = 0;
+
+  if (TREE_CODE (type) != ARRAY_TYPE)
+    abort ();  
+
+  for ( ; element != NULL_TREE; element = TREE_CHAIN (element))
+    {
+      tree purpose = TREE_PURPOSE (element);
+      tree value   = TREE_VALUE (element);
+
+      if (purpose == NULL_TREE)
+	{
+	  if (last == NULL_TREE)
+	    first = domain_min;
+	  else
+	    {
+	      HOST_WIDE_INT new_lo, new_hi;
+	      add_double (TREE_INT_CST_LOW (last), TREE_INT_CST_HIGH (last),
+			  1, 0,
+			  &new_lo, &new_hi);
+	      first = build_int_2 (new_lo, new_hi);
+	      TREE_TYPE (first) = TYPE_DOMAIN (type);
+	    }
+	  last = first;
+	  unlabelled_elements++;
+	}
+      else
+	{
+	  labelled_elements++;
+	  if (TREE_CODE (purpose) == INTEGER_CST)
+	    first = last = purpose;
+	  else if (TREE_CODE (purpose) == TYPE_DECL
+		   && discrete_type_p (TREE_TYPE (purpose)))
+	    {
+	      first = TYPE_MIN_VALUE (TREE_TYPE (purpose));
+	      last = TYPE_MAX_VALUE (TREE_TYPE (purpose));
+	    }
+	  else if (TREE_CODE (purpose) != RANGE_EXPR)
+	    {
+	      error ("invalid array tuple label");
+	      errors++;
+	      continue;
+	    }
+	  else if (TREE_OPERAND (purpose, 0) == NULL_TREE)
+	    first = last = NULL_TREE;  /* Default value. */
+	  else
+	    {
+	      first = TREE_OPERAND (purpose, 0);
+	      last = TREE_OPERAND (purpose, 1);
+	    }
+	  if ((first != NULL && TREE_CODE (first) != INTEGER_CST)
+	      || (last != NULL && TREE_CODE (last) != INTEGER_CST))
+	    {
+	      error ("non-constant array tuple index range");
+	      errors++;
+	    }
+	}
+
+      if (! CH_COMPATIBLE (value, element_type))
+	{
+	  char *err_val_name = first ? display_int_cst (first) : "(default)";
+	  error ("incompatible array tuple element %s", err_val_name);
+	  value = error_mark_node;
+	}
+      else
+	value = convert (element_type, value);
+      if (TREE_CODE (value) == ERROR_MARK)
+	errors++;
+      else if (!TREE_CONSTANT (value))
+	is_constant = 0;
+      else if (!initializer_constant_valid_p (value, TREE_TYPE (value)))
+	is_simple = 0;
+
+      if (first == NULL_TREE)
+	{
+	  if (default_value != NULL)
+	    {
+	      error ("multiple (*) or (ELSE) array tuple labels");
+	      errors++;
+	    }
+	  default_value = value;
+	  continue;
+	}
+
+      if (first != last && tree_int_cst_lt (last, first))
+	{
+	  error ("empty range in array tuple");
+	  errors++;
+	  continue;
+	}
+
+      ptr = &element_list;
+
+#define MAYBE_RANGE_OP(PURPOSE, OPNO) \
+  (TREE_CODE (PURPOSE) == RANGE_EXPR ? TREE_OPERAND (PURPOSE, OPNO): PURPOSE)
+#define CONSTRUCTOR_ELT_LO(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 0)
+#define CONSTRUCTOR_ELT_HI(ELT) MAYBE_RANGE_OP (TREE_PURPOSE (ELT), 1)
+      while (*ptr && tree_int_cst_lt (last,
+				      CONSTRUCTOR_ELT_LO (*ptr)))
+	ptr = &TREE_CHAIN (*ptr);
+      if (*ptr && ! tree_int_cst_lt (CONSTRUCTOR_ELT_HI (*ptr), first))
+	{
+	  char *err_val_name = display_int_cst (first);
+	  error ("array tuple has duplicate index %s", err_val_name);
+	  errors++;
+	  continue;
+	}
+      if ((ptr == &element_list && tree_int_cst_lt (domain_max, last))
+	|| (*ptr == NULL_TREE && tree_int_cst_lt (first, domain_min)))
+	{
+	  if (purpose)
+	    error ("array tuple index out of range");
+	  else if (errors == 0)
+	    error ("too many array tuple values");
+	  errors++;
+	  continue;
+	}
+      if (! tree_int_cst_lt (first, last))
+	purpose = first;
+      else if (purpose == NULL_TREE || TREE_CODE (purpose) != RANGE_EXPR)
+	purpose = build_nt (RANGE_EXPR, first, last);
+      *ptr = tree_cons (purpose, value, *ptr);
+    }
+
+  element_list = nreverse (element_list);
+
+  /* For each missing element, set it to the default value,
+     if there is one.  Otherwise, emit an error.  */
+
+  if (errors == 0
+      && (!allow_missing_elements || default_value != NULL_TREE))
+    {
+      /* Iterate over each *gap* between specified elements/ranges. */
+      tree prev_elt;
+      if (element_list &&
+	  tree_int_cst_equal (CONSTRUCTOR_ELT_LO (element_list), domain_min))
+	{
+	  ptr = &TREE_CHAIN (element_list);
+	  prev_elt = element_list;
+	}
+      else
+	{
+	  prev_elt = NULL_TREE;
+	  ptr = &element_list;
+	}
+      for (;;)
+	{
+	  tree first, last;
+	  /* Calculate the first element of the gap. */
+	  if (prev_elt == NULL_TREE)
+	    first = domain_min;
+	  else
+	    {
+	      first = CONSTRUCTOR_ELT_HI (prev_elt);
+	      if (tree_int_cst_equal (first, domain_max))
+		break; /* We're done.  Avoid overflow below. */
+	      first = copy_node (first);
+	      add_double (TREE_INT_CST_LOW (first), TREE_INT_CST_HIGH (first),
+			  1, 0,
+			  &TREE_INT_CST_LOW (first),
+			  &TREE_INT_CST_HIGH (first));
+	    }
+	  /* Calculate the last element of the gap. */
+	  if (*ptr)
+	    {
+	      /* Actually end up with correct type. */
+	      last = size_binop (MINUS_EXPR,
+				 CONSTRUCTOR_ELT_LO (*ptr),
+				 integer_one_node);
+	    }
+	  else
+	    last = domain_max;
+	  if (TREE_CODE (last) == INTEGER_CST && tree_int_cst_lt (last, first))
+	    ; /* Empty "gap" - no missing elements. */
+	  else if (default_value)
+	    {
+	      tree purpose;
+	      if (tree_int_cst_equal (first, last))
+		purpose = first;
+	      else
+		purpose = build_nt (RANGE_EXPR, first, last);
+	      *ptr = tree_cons (purpose, default_value, *ptr);
+	    }
+	  else
+	    {
+	      char *err_val_name = display_int_cst (first);
+	      if (TREE_CODE (last) != INTEGER_CST)
+		error ("dynamic array tuple without (*) or (ELSE)");
+	      else if (tree_int_cst_equal (first, last))
+		error ("missing array tuple element %s", err_val_name);
+	      else
+		{
+		  char *first_name = (char *)
+		    xmalloc (strlen (err_val_name) + 1);
+		  strcpy (first_name, err_val_name);
+		  err_val_name = display_int_cst (last);
+		  error ("missing array tuple elements %s : %s",
+			 first_name, err_val_name);
+		  free (first_name);
+		}
+	      errors++;
+	    }
+	  if (*ptr == NULL_TREE)
+	    break;
+	  prev_elt = *ptr;
+	  ptr = &TREE_CHAIN (*ptr);
+	}
+    }
+  if (errors)
+    return error_mark_node;
+
+  element = build (CONSTRUCTOR, type, NULL_TREE, element_list);
+  TREE_CONSTANT (element) = is_constant;
+  if (is_constant && is_simple)
+    TREE_STATIC (element) = 1;
+  if (labelled_elements && unlabelled_elements)
+    pedwarn ("mixture of labelled and unlabelled tuple elements");
+  return element;
+}
+
+/* This function is needed because no-op CHILL conversions are not fully
+   understood by the initialization machinery.  This function should only
+   be called when a conversion truly is a no-op.  */
+
+static tree
+convert1 (type, expr)
+     tree type, expr;
+{
+  int was_constant = TREE_CONSTANT (expr);
+  STRIP_NOPS (expr);
+  was_constant |= TREE_CONSTANT (expr);
+  expr = copy_node (expr);
+  TREE_TYPE (expr) = type;
+  if (TREE_CONSTANT (expr) != was_constant) abort ();
+  TREE_CONSTANT (expr) = was_constant;
+  return expr;
+}
+
+/* Create an expression whose value is that of EXPR,
+   converted to type TYPE.  The TREE_TYPE of the value
+   is always TYPE.  This function implements all reasonable
+   conversions; callers should filter out those that are
+   not permitted by the language being compiled.
+
+   In CHILL, we assume that the type is Compatible with the
+   Class of expr, and generally complain otherwise.
+   However, convert is more general (e.g. allows enum<->int
+   conversion), so there should probably be at least two routines.
+   Maybe add something like convert_for_assignment.  FIXME. */
+
+tree
+convert (type, expr)
+     tree type, expr;
+{
+  register tree e = expr;
+  register enum chill_tree_code code;
+  char *errstr;
+  int type_varying;
+
+  if (e == NULL_TREE || TREE_CODE (e) == ERROR_MARK)
+    return error_mark_node;
+
+  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+    return error_mark_node;
+
+  code = TREE_CODE (type);
+
+  if (type == TREE_TYPE (e))
+    return e;
+
+  if (TREE_TYPE (e) != NULL_TREE
+      && TREE_CODE (TREE_TYPE (e)) == REFERENCE_TYPE)
+    e = convert_from_reference (e);
+
+  /* Support for converting *to* a reference type is limited;
+     it is only here as a convenience for loc-identity declarations,
+     and loc parameters. */
+  if (code == REFERENCE_TYPE)
+    return convert_to_reference (type, e);
+
+  /* if expression was untyped because of its context (an if_expr or case_expr
+     in a tuple, perhaps) just apply the type */
+  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == ERROR_MARK)
+    {
+      TREE_TYPE (e) = type;
+      return e;
+    }
+
+  /* Turn a NULL keyword into [0, 0] for an instance */
+  if (CH_IS_INSTANCE_MODE (type) && expr == null_pointer_node)
+    {
+      tree field0 = TYPE_FIELDS (type);
+      tree field1 = TREE_CHAIN (field0);
+      e = build (CONSTRUCTOR, type, NULL_TREE,
+		 tree_cons (field0, integer_zero_node,
+			    tree_cons (field1, integer_zero_node,
+				       NULL_TREE)));
+      TREE_CONSTANT (e) = 1;
+      TREE_STATIC (e) = 1;
+      return e;
+    }
+
+  /* Turn a pointer into a function pointer for a procmode */
+  if (TREE_CODE (type) == POINTER_TYPE
+      && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE
+      && expr == null_pointer_node)
+    return convert1 (type, expr);
+
+  /* turn function_decl expression into a pointer to 
+     that function */
+  if (TREE_CODE (expr) == FUNCTION_DECL
+      && TREE_CODE (type) == POINTER_TYPE
+      && TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
+    {
+      e = build1 (ADDR_EXPR, type, expr);
+      TREE_CONSTANT (e) = 1;
+      return e;
+    }
+
+  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)
+    e = varying_to_slice (e);
+  type_varying   = chill_varying_type_p (type);
+
+  /* Convert a char to a singleton string.
+     Needed for compatibility with 1984 version of Z.200. */
+  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == CHAR_TYPE
+      && (CH_CHARS_ONE_P (type) || type_varying))
+    {
+      if (TREE_CODE (e) == INTEGER_CST)
+	{
+	  char ch = TREE_INT_CST_LOW (e);
+	  e = build_chill_string (1, &ch);
+	}
+      else
+	e = build (CONSTRUCTOR, string_one_type_node, NULL_TREE,
+		   tree_cons (NULL_TREE, e, NULL_TREE));
+    }
+
+  /* Convert a Boolean to a singleton bitstring.
+     Needed for compatibility with 1984 version of Z.200. */
+  if (TREE_TYPE (e) && TREE_CODE (TREE_TYPE (e)) == BOOLEAN_TYPE
+      && (CH_BOOLS_ONE_P (type) || type_varying))
+    {
+      if (TREE_CODE (e) == INTEGER_CST)
+	e = integer_zerop (e) ? bit_zero_node : bit_one_node;
+      else
+	e = build (COND_EXPR, bitstring_one_type_node,
+		   e, bit_one_node, bit_zero_node);
+    }
+
+  if (type_varying)
+    {
+      tree nentries;
+      tree field0 = TYPE_FIELDS (type);
+      tree field1 = TREE_CHAIN (field0);
+      tree orig_e = e;
+      tree target_array_type = TREE_TYPE (field1);
+      tree needed_padding;
+      tree padding_max_size = 0;
+      int orig_e_constant = TREE_CONSTANT (orig_e);
+      if (TREE_TYPE (e) != NULL_TREE
+	  && TREE_CODE (TREE_TYPE (e)) == ARRAY_TYPE)
+	{
+	  /* Note that array_type_nelts returns 1 less than the size. */
+	  nentries = array_type_nelts (TREE_TYPE (e));
+	  needed_padding = size_binop (MINUS_EXPR,
+				       array_type_nelts (target_array_type),
+				       nentries);
+	  if (TREE_CODE (needed_padding) != INTEGER_CST)
+	    {
+	      padding_max_size = size_in_bytes (TREE_TYPE (e));
+	      if (TREE_CODE (padding_max_size) != INTEGER_CST)
+		padding_max_size = TYPE_ARRAY_MAX_SIZE (TREE_TYPE (e));
+	    }
+	  nentries = size_binop (PLUS_EXPR, nentries, integer_one_node);
+	}
+      else if (TREE_CODE (e) == CONSTRUCTOR)
+	{
+	  HOST_WIDE_INT init_cnt = 0;
+	  tree chaser = CONSTRUCTOR_ELTS (e);
+	  for ( ; chaser; chaser = TREE_CHAIN (chaser))
+	    init_cnt++;               /* count initializer elements */
+	  nentries = build_int_2 (init_cnt, 0);
+	  needed_padding = integer_zero_node;
+	  if (TREE_TYPE (e) == NULL_TREE)
+	    e = digest_array_tuple (TREE_TYPE (field1), e, 1);
+	  orig_e_constant = TREE_CONSTANT (e);
+	}
+      else
+	{
+	  error ("initializer is not an array or string mode");
+	  return error_mark_node;
+	}
+#if 0
+      FIXME check that nentries will fit in type;
+#endif
+      if (!integer_zerop (needed_padding))
+	{
+	  tree padding, padding_type, padding_range;
+	  if (TREE_CODE (needed_padding) == INTEGER_CST
+	      && (long)TREE_INT_CST_LOW (needed_padding) < 0)
+	    {
+	      error ("destination is too small");
+	      return error_mark_node;
+	    }
+	  padding_range = build_chill_range_type (NULL_TREE, integer_one_node,
+						  needed_padding);
+	  padding_type
+	    = build_simple_array_type (TREE_TYPE (target_array_type),
+				       padding_range, NULL_TREE);
+	  TYPE_ARRAY_MAX_SIZE (padding_type) = padding_max_size;
+	  if (CH_CHARS_TYPE_P (target_array_type))
+	    MARK_AS_STRING_TYPE (padding_type);
+	  padding = build (UNDEFINED_EXPR, padding_type);
+	  if (TREE_CONSTANT (e))
+	    e = build_chill_binary_op (CONCAT_EXPR, e, padding);
+	  else
+	    e = build (CONCAT_EXPR, target_array_type, e, padding);
+	}
+      e = convert (TREE_TYPE (field1), e);
+      /* We build this constructor by hand (rather than going through
+	 digest_structure_tuple), to avoid some type-checking problem.
+	 E.g. type may have non-null novelty, but its field1 will
+	 have non-novelty. */
+      e = build (CONSTRUCTOR, type, NULL_TREE,
+		    tree_cons (field0, nentries,
+			       build_tree_list (field1, e)));
+      /* following was wrong, cause orig_e never will be TREE_CONSTANT. e
+	 may become constant after digest_array_tuple. */
+      if (TREE_CONSTANT (nentries) && orig_e_constant) /* TREE_CONSTANT (orig_e)) */
+	{
+	  TREE_CONSTANT (e) = 1;
+	  if (TREE_STATIC (nentries) && TREE_STATIC (orig_e))
+	    TREE_STATIC (e) = 1;
+	}
+    }
+  if (TREE_TYPE (e) == NULL_TREE)
+    {
+      if (TREE_CODE (e) == CONSTRUCTOR)
+	{
+	  if (TREE_CODE (type) == SET_TYPE)
+	    return digest_powerset_tuple (type, e);
+	  if (TREE_CODE (type) == RECORD_TYPE)
+	    return digest_structure_tuple (type, e);
+	  if (TREE_CODE (type) == ARRAY_TYPE)
+	    return digest_array_tuple (type, e, 0);
+	  fatal ("internal error - bad CONSTRUCTOR passed to convert");
+	}
+      else if (TREE_CODE (e) == COND_EXPR)
+	e = build (COND_EXPR, type,
+		   TREE_OPERAND (e, 0),
+		   convert (type, TREE_OPERAND (e, 1)),
+		   convert (type, TREE_OPERAND (e, 2)));
+      else if (TREE_CODE (e) == CASE_EXPR)
+	TREE_TYPE (e) = type;
+      else
+	{
+	  error ("internal error:  unknown type of expression");
+	  return error_mark_node;
+	}
+    }
+
+  if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))
+      || (CH_NOVELTY (type) != NULL_TREE
+	  && CH_NOVELTY (type) == CH_NOVELTY (TREE_TYPE (e))))
+    return convert1 (type, e);
+
+  if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
+    {
+      error ("void value not ignored as it ought to be");
+      return error_mark_node;
+    }
+  if (code == VOID_TYPE)
+    return build1 (CONVERT_EXPR, type, e);
+
+  if (code == SET_TYPE)
+    return convert1 (type, e);
+
+  if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
+    {
+      if (flag_old_strings)
+	{
+	  if (CH_CHARS_ONE_P (TREE_TYPE (e)))
+	    e = convert_to_char (char_type_node, e);
+	  else if (CH_BOOLS_ONE_P (TREE_TYPE (e)))
+	    e = convert_to_boolean (boolean_type_node, e);
+	}
+      return fold (convert_to_integer (type, e));
+    }
+  if (code == POINTER_TYPE)
+    return fold (convert_to_pointer (type, e));
+  if (code == REAL_TYPE)
+    return fold (convert_to_real (type, e));
+  if (code == BOOLEAN_TYPE)
+    return fold (convert_to_boolean (type, e));
+  if (code == CHAR_TYPE)
+    return fold (convert_to_char (type, e));
+
+  if (code == ARRAY_TYPE && TYPE_MODE (type) != TYPE_MODE (TREE_TYPE (e)))
+    {
+      /* The mode of the expression is different from that of the type.
+	 Earlier checks should have tested against different lengths.
+	 But even if the lengths are the same, it is possible that one
+	 type is a static type (and hence could be say SImode), while the
+	 other type is dynamic type (and hence is BLKmode).
+	 This causes problems when emitting instructions.  */
+      tree ee = build1 (INDIRECT_REF, type,
+			build1 (NOP_EXPR, build_pointer_type (type),
+				build1 (ADDR_EXPR,
+					build_pointer_type (TREE_TYPE (e)),
+					e)));
+      TREE_READONLY (ee) = TYPE_READONLY (type);
+      return ee;
+    }
+
+  /* The default! */
+  return convert1 (type, e);
+}
+
+/* Return an expression whose value is EXPR, but whose class is CLASS. */
+
+tree
+convert_to_class (class, expr)
+     struct ch_class class;
+     tree expr;
+{
+  switch (class.kind)
+    {
+    case CH_NULL_CLASS:
+    case CH_ALL_CLASS:
+      return expr;
+    case CH_DERIVED_CLASS:
+      if (TREE_TYPE (expr) != class.mode)
+	expr = convert (class.mode, expr);
+      if (!CH_DERIVED_FLAG (expr))
+	{
+	  expr = copy_node (expr);
+	  CH_DERIVED_FLAG (expr) = 1;
+	}
+      return expr;
+    case CH_VALUE_CLASS:
+    case CH_REFERENCE_CLASS:
+      if (TREE_TYPE (expr) != class.mode)
+	expr = convert (class.mode, expr);
+      if (CH_DERIVED_FLAG (expr))
+	{
+	  expr = copy_node (expr);
+	  CH_DERIVED_FLAG (expr) = 0;
+	}
+      return expr;
+    }
+  return expr;
+}