�

Migrate from devo/gcc/ch.

From-SVN: r22038

gcc/ch/README

+This directory contains the GNU front-end for the Chill language,
+contributed by Cygnus Solutions.
+
+Chill is the "CCITT High-Level Language", where CCITT is the old
+name for what is now ITU, the International Telecommunications Union.
+It is is language in the Modula2 family, and targets many of the
+same applications as Ada (especially large embedded systems).
+Chill was never used much in the United States, but is still
+being used in Europe, Brazil, Korea, and other places.
+
+Chill has been standardized by a series of reports/standards.
+The GNU implementation mostly follows the 1988 version of
+the language, with some backwards compatibility options for
+the 1984 version, and some other extensions.  However, it
+does not implement all of the features of any standard.
+The most recent standard is ?, available from ?.
+
+The GNU Chill implementation is not being actively developed.
+Cygnus has one customer we are maintaining Chill for,
+but we are not planning on putting major work into Chill.
+This Net release is for educational purposes (as an example
+of a different Gcc front-end), and for those who find it useful.
+It is an unsupported hacker release.  Bug reports without
+patches are likely to get ignored.  Questions may get answered or
+ignored depending on our mood!  If you want to try your luck,
+you can send a note to David Brolley <brolley@cygnus.com> or
+Per Bothner <bothner@cygnus.com>.
+
+One known problem is that we only support native builds of GNU Chill.
+If you need a cross-compiler, you will find various problems,
+including the directory structure, and the setjmp-based exception
+handling mechanism.
+
+The Chill run-time system is in the runtime sub-directory.
+Notice rts.c contains a poor main's implementation of Chill
+"processes" (threads).  It is not added to libchill.a.
+We only use it for testing.  (Our customer uses a different
+implementation for product work.)
+
+The GNU Chill implementation was primarily written by
+Per Bothner, along with Bill Cox, Wilfried Moser, Michael
+Tiemann, and David Brolley.

gcc/ch/actions.c

+/* Implement actions for CHILL.
+   Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+   Authors: Per Bothner, Bill Cox, Michael Tiemann, Michael North
+
+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 <stdio.h>
+#include <limits.h>
+#include "config.h"
+#include "tree.h"
+#include "rtl.h"
+#include "expr.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include "flags.h"
+#include "actions.h"
+#include "obstack.h"
+#include "assert.h"
+
+#define obstack_chunk_alloc xmalloc
+#define obstack_chunk_free free
+
+/* reserved tag definitions */
+
+#define TYPE_ID                 "id"
+#define TAG_OBJECT              "chill_object"
+#define TAG_CLASS               "chill_class"
+
+extern int flag_short_enums;
+extern int current_nesting_level;
+
+extern tree build_chill_compound_expr PROTO((tree));
+extern tree build_chill_exception_decl PROTO((char *));
+extern tree convert                   PROTO((tree, tree));
+extern rtx  emit_line_note_force      PROTO((char *, int));
+extern void error                     PROTO((char *, ...));
+extern void error_with_decl           PROTO((tree, char *, ...));
+extern rtx  gen_nop                   PROTO((void));
+extern tree get_identifier            PROTO((char *));
+extern void pedwarn                   PROTO((char *, ...));
+extern void sorry                     PROTO((char *, ...));
+extern void warning                   PROTO((char *, ...));
+
+extern struct obstack *expression_obstack, permanent_obstack;
+extern struct obstack *current_obstack, *saveable_obstack;
+
+/* This flag is checked throughout the non-CHILL-specific
+   in the front end. */
+tree chill_integer_type_node;
+tree chill_unsigned_type_node;
+
+/* Never used.  Referenced from c-typeck.c, which we use. */
+int current_function_returns_value = 0;
+int current_function_returns_null = 0;
+
+/* data imported from toplev.c  */
+
+extern char *dump_base_name;
+
+/* set from command line parameter, to exit after 
+   grant file written, generating no code. */
+int grant_only_flag = 0;
+
+char *
+lang_identify ()
+{
+  return "chill";
+}
+
+
+void
+init_chill ()
+{
+}
+
+void
+print_lang_statistics ()
+{
+}
+
+
+void
+lang_finish ()
+{
+#if 0
+    extern int errorcount, sorrycount;
+
+    /* this should be the last action in compiling a module.
+       If there are other actions to be performed at lang_finish
+       please insert before this */
+
+    /* FIXME: in case of a syntax error, this leaves the grant file incomplete */
+    /* for the moment we print a warning in case of errors and 
+       continue granting */
+    if ((errorcount || sorrycount) && grant_count)
+      {
+	warning ("%d errors, %d sorries, do granting", errorcount, sorrycount);
+	errorcount = sorrycount = 0;
+      }
+#endif
+}
+
+void
+chill_check_decl (decl)
+     tree decl;
+{
+  tree type = TREE_TYPE (decl);
+  static int alreadyWarned = 0;
+
+  if (TREE_CODE (type) == RECORD_TYPE) /* && TREE_STATIC_TEMPLATE (type)) */
+    {
+      if (!alreadyWarned)
+        {
+          error ("GNU compiler does not support statically allocated objects");          
+          alreadyWarned = 1;
+        }
+      error_with_decl (decl, "`%s' cannot be statically allocated");
+    }
+}
+
+/* Comparison function for sorting identifiers in RAISES lists.
+   Note that because IDENTIFIER_NODEs are unique, we can sort
+   them by address, saving an indirection.  */
+static int
+id_cmp (p1, p2)
+     tree *p1, *p2;
+{
+  return (int)TREE_VALUE (*p1) - (int)TREE_VALUE (*p2);
+}
+
+/* Build the FUNCTION_TYPE or METHOD_TYPE which may raise exceptions
+   listed in RAISES.  */
+tree
+build_exception_variant (type, raises)
+     tree type, raises;
+{
+  int i;
+  tree v = TYPE_MAIN_VARIANT (type);
+  tree t, t2;
+  int constp    = TYPE_READONLY (type);
+  int volatilep = TYPE_VOLATILE (type);
+
+  if (!raises)
+    return build_type_variant (v, constp, volatilep);
+
+  if (TREE_CHAIN (raises))
+    { /* Sort the list */
+      tree *a = (tree *)alloca ((list_length (raises)+1) * sizeof (tree));
+      for (i = 0, t = raises; t; t = TREE_CHAIN (t), i++)
+	a[i] = t;
+      /* NULL terminator for list.  */
+      a[i] = NULL_TREE;
+      qsort (a, i, sizeof (tree), id_cmp);
+      while (i--)
+	TREE_CHAIN (a[i]) = a[i+1];
+      raises = a[0];
+    }
+
+  for (v = TYPE_NEXT_VARIANT (v); v; v = TYPE_NEXT_VARIANT (v))
+    {
+      if (TYPE_READONLY (v) != constp
+	  || TYPE_VOLATILE (v) != volatilep)
+	continue;
+
+      t = raises;
+      t2 = TYPE_RAISES_EXCEPTIONS (v);
+      while (t && t2)
+	{
+	  if (TREE_TYPE (t) == TREE_TYPE (t2))
+	    {
+	      t = TREE_CHAIN (t);
+	      t2 = TREE_CHAIN (t2);
+	    }
+	  else break;
+	}
+      if (t || t2)
+	continue;
+      /* List of exceptions raised matches previously found list.
+
+         @@ Nice to free up storage used in consing up the
+	 @@ list of exceptions raised.  */
+      return v;
+    }
+
+  /* Need to build a new variant.  */
+  if (TREE_PERMANENT (type))
+    {
+      push_obstacks_nochange ();
+      end_temporary_allocation ();
+      v = copy_node (type);
+      pop_obstacks ();
+    }
+  else
+    v = copy_node (type);
+
+  TYPE_NEXT_VARIANT (v) = TYPE_NEXT_VARIANT (type);
+  TYPE_NEXT_VARIANT (type) = v;
+  if (raises && ! TREE_PERMANENT (raises))
+    {
+      push_obstacks_nochange ();
+      end_temporary_allocation ();
+      raises = copy_list (raises);
+      pop_obstacks ();
+    }
+  TYPE_RAISES_EXCEPTIONS (v) = raises;
+  return v;
+}
+#if 0
+
+tree
+build_rts_call (name, type, args)
+     char *name;
+     tree type, args;
+{
+  tree decl = lookup_name (get_identifier (name));
+  tree converted_args = NULL_TREE;
+  tree result, length = NULL_TREE;
+
+  assert (decl != NULL_TREE);
+  while (args)
+    {
+      tree arg = TREE_VALUE (args);
+      if (TREE_CODE (TREE_TYPE (arg)) == SET_TYPE
+	  || TREE_CODE (TREE_TYPE (arg)) == ARRAY_TYPE)
+	{
+	  length = size_in_bytes (TREE_TYPE (arg));
+	  arg = build_chill_addr_expr (arg, (char *)0);
+	}
+      converted_args = tree_cons (NULL_TREE, arg, converted_args);
+      args = TREE_CHAIN (args);
+    }
+  if (length != NULL_TREE)
+    converted_args = tree_cons (NULL_TREE, length, converted_args);
+  converted_args = nreverse (converted_args);
+  result = build_chill_function_call (decl, converted_args);
+  if (TREE_CODE (type) == SET_TYPE || TREE_CODE (type) == ARRAY_TYPE)
+    result = build1 (INDIRECT_REF, type, result);
+  else
+    result = convert (type, result);
+  return result;
+}
+#endif
+
+/*
+ * queue name of unhandled exception
+ * to avoid multiple unhandled warnings
+ * in one compilation module
+ */
+
+struct already_type
+{
+  struct already_type *next;
+  char *name;
+};
+
+static struct already_type *already_warned = 0;
+
+static void
+warn_unhandled (ex)
+     char *ex;
+{
+  struct already_type *p = already_warned;
+
+  while (p)
+    {
+      if (!strcmp (p->name, ex))
+	return;
+      p = p->next;
+    }
+  
+  /* not yet warned */
+  p = (struct already_type *)xmalloc (sizeof (struct already_type));
+  p->next = already_warned;
+  p->name = (char *)xmalloc (strlen (ex) + 1);
+  strcpy (p->name, ex);
+  already_warned = p;
+  pedwarn ("causing unhandled exception `%s' (this is flaged only once)", ex);
+}
+
+/*
+ * build a call to the following function:
+ *   void   __cause_ex1 (char* ex, const char *file, 
+ *                       const unsigned lineno);
+ * if the exception is handled or
+ *   void __unhandled_ex (char *ex, char *file, unsigned lineno)
+ * if the exception is not handled.
+ */
+tree
+build_cause_exception (exp_name, warn_if_unhandled)
+     tree exp_name;
+     int warn_if_unhandled;
+{
+  /* We don't use build_rts_call() here, because the string (array of char)
+     would be followed by its length in the parameter list built by
+     build_rts_call, and the runtime routine doesn't want a length parameter.*/
+  tree exp_decl = build_chill_exception_decl (IDENTIFIER_POINTER (exp_name));
+  tree function, fname, lineno, result;
+  int handled = is_handled (exp_name);
+
+  switch (handled)
+    {
+    case 0:
+      /* no handler */
+      if (warn_if_unhandled)
+	warn_unhandled (IDENTIFIER_POINTER (exp_name));
+      function = lookup_name (get_identifier ("__unhandled_ex"));
+      fname = force_addr_of (get_chill_filename ());
+      lineno = get_chill_linenumber ();
+      break;
+    case 1:
+      /* local handler */
+      function = lookup_name (get_identifier ("__cause_ex1"));
+      fname = force_addr_of (get_chill_filename ());
+      lineno = get_chill_linenumber ();
+      break;
+    case 2:
+      /* function may propagate this exception */
+      function = lookup_name (get_identifier ("__cause_ex1"));
+      fname = lookup_name (get_identifier (CALLER_FILE));
+      if (fname == NULL_TREE)
+	fname = error_mark_node;
+      lineno = lookup_name (get_identifier (CALLER_LINE));
+      if (lineno == NULL_TREE)
+	lineno = error_mark_node;
+      break;
+    }
+  result =
+    build_chill_function_call (function,
+      tree_cons (NULL_TREE, build_chill_addr_expr (exp_decl, (char *)0),
+	tree_cons (NULL_TREE,  fname,
+	  tree_cons (NULL_TREE, lineno, NULL_TREE))));
+  return result;
+}
+
+void
+expand_cause_exception (exp_name)
+     tree exp_name;
+{
+  expand_expr_stmt (build_cause_exception (exp_name, 1));
+}
+
+/* If CONDITION is true, raise EXCEPTION (an IDENTIFIER_NODE);
+   otherwise return EXPR. */
+
+tree
+check_expression (expr, condition, exception)
+     tree expr, condition, exception;
+{
+  if (integer_zerop (condition))
+    return expr;
+  else
+    return build (COMPOUND_EXPR, TREE_TYPE (expr),
+		  fold (build (TRUTH_ANDIF_EXPR, boolean_type_node,
+			       condition, build_cause_exception (exception, 0))),
+		  expr);
+}
+
+/* Return an expression for VALUE < LO_LIMIT || VALUE > HI_LIMIT,
+   somewhat optimized and with some warnings suppressed.
+   If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that (sub-)test passes.  */
+
+tree
+test_range (value, lo_limit, hi_limit)
+     tree value, lo_limit, hi_limit;
+{
+  if (lo_limit || hi_limit)
+    {
+      int old_inhibit_warnings = inhibit_warnings;
+      tree lo_check, hi_check, check;
+
+      /* This is a hack so that `shorten_compare' doesn't warn the
+	 user about useless range checks that are too much work to
+	 optimize away here.  */
+      inhibit_warnings = 1;
+
+      lo_check = lo_limit ? 
+	fold (build_compare_discrete_expr (LT_EXPR, value, lo_limit)) :
+	  boolean_false_node;   /* fake passing the check */
+
+      hi_check = hi_limit ? 
+	fold (build_compare_discrete_expr (GT_EXPR, value, hi_limit)) :
+	  boolean_false_node;   /* fake passing the check */
+
+      if (lo_check == boolean_false_node)
+	check = hi_check;
+      else if (hi_check == boolean_false_node)
+	check = lo_check;
+      else
+	check = fold (build (TRUTH_ORIF_EXPR, boolean_type_node,
+			     lo_check, hi_check));
+
+      inhibit_warnings = old_inhibit_warnings;
+      return check;
+    }
+  else
+    return boolean_false_node;
+}
+
+/* Return EXPR, except if range_checking is on, return an expression
+   that also checks that value >= low_limit && value <= hi_limit.
+   If LO_LIMIT or HI_LIMIT is NULL_TREE, assume that test passes.  */
+
+tree
+check_range (expr, value, lo_limit, hi_limit)
+     tree expr, value, lo_limit, hi_limit;
+{
+  tree check = test_range (value, lo_limit, hi_limit);
+  if (!integer_zerop (check))
+    {
+      if (current_function_decl == NULL_TREE)
+	{
+	  if (TREE_CODE (check) == INTEGER_CST)
+	    error ("range failure (not inside function)");
+	  else
+	    warning ("possible range failure (not inside function)");
+	}
+      else
+	{
+	  if (TREE_CODE (check) == INTEGER_CST)
+	    warning ("expression will always cause RANGEFAIL");
+	  if (range_checking)
+	    expr = check_expression (expr, check,
+				     ridpointers[(int) RID_RANGEFAIL]);
+	}
+    }
+  return expr;
+}
+
+/* Same as EXPR, except raise EMPTY if EXPR is NULL. */
+
+tree
+check_non_null (expr)
+     tree expr;
+{
+  if (empty_checking)
+    {
+      expr = save_if_needed (expr);
+      return check_expression (expr,
+			       build_compare_expr (EQ_EXPR,
+						   expr, null_pointer_node),
+			       ridpointers[(int) RID_EMPTY]);
+    }
+  return expr;
+}
+
+/*
+ * There are four conditions to generate a runtime check:
+ *    1) assigning a longer INT to a shorter (signs irrelevant)
+ *    2) assigning a signed to an unsigned
+ *    3) assigning an unsigned to a signed of the same size.
+ *    4) TYPE is a discrete subrange
+ */
+tree
+chill_convert_for_assignment (type, expr, place)
+     tree type, expr;
+     char *place; /* location description for error messages */
+{
+  tree ttype = type;
+  tree etype = TREE_TYPE (expr);
+  tree result;
+
+  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+    return error_mark_node;
+  if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+    return expr;
+  if (TREE_CODE (expr) == TYPE_DECL)
+    {
+      error ("right hand side of assignment is a mode");
+      return error_mark_node;
+    }
+
+  if (! CH_COMPATIBLE (expr, type))
+    {
+      error ("incompatible modes in %s", place);
+      return error_mark_node;
+    }
+
+  if (TREE_CODE (type) == REFERENCE_TYPE)
+    ttype = TREE_TYPE (ttype);
+  if (etype && TREE_CODE (etype) == REFERENCE_TYPE)
+    etype = TREE_TYPE (etype);
+
+  if (etype
+      && (CH_STRING_TYPE_P (ttype)
+	  || (chill_varying_type_p (ttype)
+	      && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (ttype))))
+      && (CH_STRING_TYPE_P (etype)
+	  || (chill_varying_type_p (etype)
+	      && CH_STRING_TYPE_P (CH_VARYING_ARRAY_TYPE (etype)))))
+    {
+      tree cond;
+      if (range_checking)
+	expr = save_if_needed (expr);
+      cond = string_assignment_condition (ttype, expr);
+      if (TREE_CODE (cond) == INTEGER_CST)
+	{
+	  if (integer_zerop (cond))
+	    {
+	      error ("bad string length in %s", place);
+	      return error_mark_node;
+	    }
+	  /* Otherwise, the condition is always true, so no runtime test. */
+	}
+      else if (range_checking)
+	expr = check_expression (expr,
+				 invert_truthvalue (cond),
+				 ridpointers[(int) RID_RANGEFAIL]);
+    }
+
+  if (range_checking 
+      && discrete_type_p (ttype) 
+      && etype != NULL_TREE
+      && discrete_type_p (etype))
+    {
+      int cond1 = tree_int_cst_lt (TYPE_SIZE (ttype),
+				   TYPE_SIZE (etype));
+      int cond2 = TREE_UNSIGNED (ttype) 
+	          && (! TREE_UNSIGNED (etype));
+      int cond3 = (! TREE_UNSIGNED (type))
+	          && TREE_UNSIGNED (etype) 
+		  && tree_int_cst_equal (TYPE_SIZE (ttype),
+					 TYPE_SIZE (etype));
+      int cond4 = TREE_TYPE (ttype) 
+	          && discrete_type_p (TREE_TYPE (ttype));
+
+      if (cond1 || cond2 || cond3 || cond4)
+	{
+	  tree type_min = TYPE_MIN_VALUE (ttype);
+	  tree type_max = TYPE_MAX_VALUE (ttype);
+
+	  expr = save_if_needed (expr);
+	  if (expr && type_min && type_max)
+	    expr = check_range (expr, expr, type_min, type_max);
+	}
+    }
+  result = convert (type, expr);
+
+  /* If the type is a array of PACK bits and the expression is an array constructor,
+     then build a CONSTRUCTOR for a bitstring.  Bitstrings are zero based, so
+     decrement the value of each CONSTRUCTOR element by the amount of the lower
+     bound of the array.  */
+  if (TREE_CODE (type) == ARRAY_TYPE && TYPE_PACKED (type)
+      && TREE_CODE (result) == CONSTRUCTOR)
+    {
+      tree domain_min = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+      tree new_list = NULL_TREE;
+      long index;
+      tree element;
+      for (element = TREE_OPERAND (result, 1);
+	   element != NULL_TREE;
+	   element = TREE_CHAIN (element))
+	{
+	  if (!tree_int_cst_equal (TREE_VALUE (element), integer_zero_node))
+	    {
+	      tree purpose = TREE_PURPOSE (element);
+	      switch (TREE_CODE (purpose))
+		{
+		case INTEGER_CST:
+		  new_list = tree_cons (NULL_TREE,
+					size_binop (MINUS_EXPR, purpose, domain_min),
+					new_list);
+		  break;
+		case RANGE_EXPR:
+		  for (index  = TREE_INT_CST_LOW (TREE_OPERAND (purpose, 0));
+		       index <= TREE_INT_CST_LOW (TREE_OPERAND (purpose, 1));
+		       index++)
+		    new_list = tree_cons (NULL_TREE,
+					  size_binop (MINUS_EXPR,
+						      build_int_2 (index, 0),
+						      domain_min),
+					  new_list);
+		  break;
+		default:
+		  abort ();
+		}
+	    }
+	}
+      TREE_OPERAND (result, 1) = nreverse (new_list);
+      TREE_TYPE (result) = build_bitstring_type (TYPE_SIZE (type));
+    }
+
+  return result;
+}
+
+/* Check that EXPR has valid type for a RETURN or RESULT expression,
+   converting to the right type.  ACTION is "RESULT" or "RETURN". */
+
+static tree
+adjust_return_value (expr, action)
+     tree expr;
+     char *action;
+{
+  tree type = TREE_TYPE (TREE_TYPE (current_function_decl));
+
+  if (TREE_CODE (type) == REFERENCE_TYPE)
+    {
+      if (CH_LOCATION_P (expr))
+	{
+	  if (! CH_READ_COMPATIBLE (TREE_TYPE (type), 
+				    TREE_TYPE (expr)))
+	    {
+	      error ("mode mismatch in %s expression", action);
+	      return error_mark_node;
+	    }
+	  return convert (type, expr);
+	}
+      else
+	{
+	  error ("%s expression must be referable", action);
+	  return error_mark_node;
+	}
+    }
+  else if (! CH_COMPATIBLE (expr, type))
+    {
+      error ("mode mismatch in %s expression", action);
+      return error_mark_node;
+    }
+  return convert (type, expr);
+}
+
+void
+chill_expand_result (expr, result_or_return)
+     tree expr;
+     int result_or_return;
+{
+  tree type;
+  char *action_name = result_or_return ? "RESULT" : "RETURN";
+  
+  if (pass == 1)
+    return;
+
+  if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
+    return;
+
+  CH_FUNCTION_SETS_RESULT (current_function_decl) = 1;
+
+  if (chill_at_module_level || global_bindings_p ())
+    error ("%s not allowed outside a PROC", action_name);
+
+  result_never_set = 0;
+
+  if (chill_result_decl == NULL_TREE)
+    {
+      error ("%s action in PROC with no declared RESULTS", action_name);
+      return;
+    }
+  type = TREE_TYPE (chill_result_decl);
+
+  if (TREE_CODE (type) == ERROR_MARK)
+    return;
+
+  expr = adjust_return_value (expr, action_name);
+
+  expand_expr_stmt (build_chill_modify_expr (chill_result_decl, expr));
+}
+
+/*
+ * error if EXPR not NULL and procedure doesn't
+ * have a return type; 
+ * warning if EXPR NULL,
+ * procedure *has* a return type, and a previous
+ * RESULT actions hasn't saved a return value.
+ */
+void
+chill_expand_return (expr, implicit)
+     tree expr;
+     int implicit; /* 1 if an implicit return at end of function. */
+{
+  tree valtype;
+
+  if (expr != NULL_TREE && TREE_CODE (expr) == ERROR_MARK)
+    return;
+  if (chill_at_module_level || global_bindings_p ())
+    {
+      error ("RETURN not allowed outside PROC");
+      return;
+    }
+
+  if (pass == 1)
+    return;
+
+  result_never_set = 0;
+
+  valtype = TREE_TYPE (TREE_TYPE (current_function_decl));
+  if (TREE_CODE (valtype) == VOID_TYPE)
+    {
+      if (expr != NULL_TREE)
+	error ("RETURN with a value, in PROC returning void");
+      expand_null_return ();
+    }
+  else if (TREE_CODE (valtype) != ERROR_MARK)
+    {
+      if (expr == NULL_TREE)
+	{
+	  if (!CH_FUNCTION_SETS_RESULT (current_function_decl)
+	      && !implicit)
+	    warning ("RETURN with no value and no RESULT action in procedure");
+	  expr = chill_result_decl;
+	}
+      else
+	expr = adjust_return_value (expr, "RETURN");
+      expr = build (MODIFY_EXPR, valtype,
+		    DECL_RESULT (current_function_decl),
+		    expr);
+      TREE_SIDE_EFFECTS (expr) = 1;
+      expand_return (expr);
+    }
+}
+
+void
+lookup_and_expand_goto (name)
+     tree name;
+{
+  if (name == NULL_TREE ||  TREE_CODE (name) == ERROR_MARK)
+    return;
+  if (!ignoring)
+    {
+      tree decl = lookup_name (name);
+      if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
+	error ("no label named `%s'", IDENTIFIER_POINTER (name));
+      else if (DECL_CONTEXT (decl) != current_function_decl)
+	error ("cannot GOTO label `%s' outside current function",
+	       IDENTIFIER_POINTER (name));
+      else
+	{
+	  TREE_USED (decl) = 1;
+	  expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
+	  expand_goto (decl);
+	}
+    }
+}
+
+void
+lookup_and_handle_exit (name)
+     tree name;
+{
+  if (name == NULL_TREE ||  TREE_CODE (name) == ERROR_MARK)
+    return;
+  if (!ignoring)
+    {
+      tree label = munge_exit_label (name);
+      tree decl = lookup_name (label);
+      if (decl == NULL || TREE_CODE (decl) != LABEL_DECL)
+	error ("no EXITable label named `%s'", IDENTIFIER_POINTER (name));
+      else if (DECL_CONTEXT (decl) != current_function_decl)
+	error ("cannot EXIT label `%s' outside current function",
+	       IDENTIFIER_POINTER (name));
+      else
+	{
+	  TREE_USED (decl) = 1;
+	  expand_goto_except_cleanup (DECL_ACTION_NESTING_LEVEL (decl));
+	  expand_goto (decl);
+	}
+    }
+}
+
+/* ELSE-range handling: The else-range is a chain of trees which collectively
+   represent the ranges to be tested for the (ELSE) case label. Each element in
+   the chain represents a range to be tested. The boundaries of the range are
+   represented by INTEGER_CST trees in the PURPOSE and VALUE fields. */
+
+/* This function updates the else-range by removing the given integer constant. */
+static tree
+update_else_range_for_int_const (else_range, label)
+     tree else_range, label;
+{
+  int  lowval, highval;
+  int  label_value = TREE_INT_CST_LOW (label);
+  tree this_range, prev_range, new_range;
+
+  /* First, find the range element containing the integer, if it exists. */
+  prev_range = NULL_TREE;
+  for (this_range = else_range ;
+       this_range != NULL_TREE;
+       this_range = TREE_CHAIN (this_range))
+    {
+      lowval  = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
+      highval = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+      if (label_value >= lowval && label_value <= highval)
+	break;
+      prev_range = this_range;
+    }
+
+  /* If a range element containing the integer was found, then update the range. */
+  if (this_range != NULL_TREE)
+    {
+      tree next = TREE_CHAIN (this_range);
+      if (label_value == lowval)
+	{
+	  /* The integer is the lower bound of the range element. If it is also the
+	     upper bound, then remove this range element, otherwise update it. */
+	  if (label_value == highval)
+	    {
+	      if (prev_range == NULL_TREE)
+		else_range = next;
+	      else
+		TREE_CHAIN (prev_range) = next;
+	    }
+	  else
+	    TREE_PURPOSE (this_range) = build_int_2 (label_value + 1, 0);
+	}
+      else if (label_value == highval)
+	{
+	  /* The integer is the upper bound of the range element, so ajust it. */
+	  TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
+	}
+      else
+	{
+	  /* The integer is in the middle of the range element, so split it. */
+	  new_range = tree_cons (
+            build_int_2 (label_value + 1, 0), TREE_VALUE (this_range), next);
+	  TREE_VALUE (this_range) = build_int_2 (label_value - 1, 0);
+	  TREE_CHAIN (this_range) = new_range;
+	}
+    }
+  return else_range;
+}
+
+/* Update the else-range to remove a range of values/ */
+static tree
+update_else_range_for_range (else_range, low_target, high_target)
+     tree else_range, low_target, high_target;
+{
+  tree this_range, prev_range, new_range, next_range;
+  int  low_range_val, high_range_val;
+  int  low_target_val  = TREE_INT_CST_LOW (low_target);
+  int  high_target_val = TREE_INT_CST_LOW (high_target);
+
+  /* find the first else-range element which overlaps the target range. */
+  prev_range = NULL_TREE;
+  for (this_range = else_range ;
+       this_range != NULL_TREE;
+       this_range = TREE_CHAIN (this_range))
+    {
+      low_range_val  = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
+      high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+      if (low_target_val >= low_range_val && low_target_val <= high_range_val
+	  || high_target_val >= low_range_val && high_target_val <= high_range_val)
+	break;
+      prev_range = this_range;
+    }
+  if (this_range == NULL_TREE)
+    return else_range;
+
+  /* This first else-range element might be truncated at the top or completely
+     contain the target range. */
+  if (low_range_val < low_target_val)
+    {
+      next_range = TREE_CHAIN (this_range);
+      if (high_range_val > high_target_val)
+	{
+	  new_range = tree_cons (
+            build_int_2 (high_target_val + 1, 0), TREE_VALUE (this_range), next_range);
+	  TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
+	  TREE_CHAIN (this_range) = new_range;
+	  return else_range;
+	}
+
+      TREE_VALUE (this_range) = build_int_2 (low_target_val - 1, 0);
+      if (next_range == NULL_TREE)
+	return else_range;
+
+      prev_range = this_range;
+      this_range = next_range;
+      high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+    }
+
+  /* There may then follow zero or more else-range elements which are completely
+     contained in the target range. */
+  while (high_range_val <= high_target_val)
+    {
+      this_range = TREE_CHAIN (this_range);
+      if (prev_range == NULL_TREE)
+	else_range = this_range;
+      else
+	TREE_CHAIN (prev_range) = this_range;
+
+      if (this_range == NULL_TREE)
+	return else_range;
+      high_range_val = TREE_INT_CST_LOW (TREE_VALUE (this_range));
+    }
+
+  /* Finally, there may be a else-range element which is truncated at the bottom. */
+  low_range_val = TREE_INT_CST_LOW (TREE_PURPOSE (this_range));
+  if (low_range_val <= high_target_val)
+    TREE_PURPOSE (this_range) = build_int_2 (high_target_val + 1, 0);
+
+  return else_range;
+}
+
+static tree
+update_else_range_for_range_expr (else_range, label)
+     tree else_range, label;
+{
+  if (TREE_OPERAND (label, 0) == NULL_TREE)
+    {
+      if (TREE_OPERAND (label, 1) == NULL_TREE)
+	else_range = NULL_TREE; /* (*) -- matches everything */
+    }
+  else
+    else_range = update_else_range_for_range (
+      else_range, TREE_OPERAND (label, 0), TREE_OPERAND (label, 1));
+
+  return else_range;
+}
+
+static tree
+update_else_range_for_type (else_range, label)
+     tree else_range, label;
+{
+  tree type = TREE_TYPE (label);
+  else_range = update_else_range_for_range (
+    else_range, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
+  return else_range;
+}
+
+static tree
+compute_else_range (selector, alternatives, selector_no)
+     tree selector, alternatives;
+     int selector_no;
+{
+  /* Start with an else-range that spans the entire range of the selector type. */
+  tree type = TREE_TYPE (TREE_VALUE (selector));
+  tree range = tree_cons (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), NULL_TREE);
+
+  /* Now remove the values represented by each case lebel specified for that
+     selector. The remaining range is the else-range. */
+  for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
+    {
+      tree label;
+      tree label_list = TREE_PURPOSE (alternatives);
+      int  this_selector;
+      for (this_selector = 0; this_selector < selector_no ; ++this_selector)
+	label_list = TREE_CHAIN (label_list);
+
+      for (label = TREE_VALUE (label_list);
+	   label != NULL_TREE;
+	   label = TREE_CHAIN (label))
+	{
+	  tree label_value = TREE_VALUE (label);
+	  if (TREE_CODE (label_value) == INTEGER_CST)
+	    range = update_else_range_for_int_const (range, label_value);
+	  else if (TREE_CODE (label_value) == RANGE_EXPR)
+	    range = update_else_range_for_range_expr (range, label_value);
+	  else if (TREE_CODE (label_value) == TYPE_DECL)
+	    range = update_else_range_for_type (range, label_value);
+
+	  if (range == NULL_TREE)
+	    break;
+	}
+    }
+
+  return range;
+}
+
+void
+compute_else_ranges (selectors, alternatives)
+     tree selectors, alternatives;
+{
+  tree selector;
+  int selector_no = 0;
+
+  for (selector = selectors; selector != NULL_TREE; selector = TREE_CHAIN (selector))
+    {
+      if (ELSE_LABEL_SPECIFIED (selector))
+	TREE_PURPOSE (selector) =
+	  compute_else_range (selector, alternatives, selector_no);
+      selector_no++;
+    }
+}
+
+static tree
+check_case_value (label_value, selector)
+     tree label_value, selector;
+{
+  if (TREE_CODE (label_value) == ERROR_MARK)
+    return label_value;
+  if (TREE_CODE (selector) == ERROR_MARK)
+    return selector;    
+
+  /* Z.200 (6.4 Case action) says:  "The class of any discrete expression
+     in the case selector list must be compatible with the corresponding
+     (by position) class of the resulting list of classes of the case label
+     list occurrences ...".  We don't actually construct the resulting
+     list of classes, but this test should be more-or-less equivalent.
+     I think... */
+  if (!CH_COMPATIBLE_CLASSES (selector, label_value))
+    {
+      error ("case selector not compatible with label");
+      return error_mark_node;
+    }
+
+  /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue.  */
+  STRIP_TYPE_NOPS (label_value);
+
+  if (TREE_CODE (label_value) != INTEGER_CST)
+    {
+      error ("case label does not reduce to an integer constant");
+      return error_mark_node;
+    }
+
+  constant_expression_warning (label_value);
+  return label_value;
+}
+
+void
+chill_handle_case_default ()
+{
+  tree duplicate;
+  register tree label = build_decl (LABEL_DECL, NULL_TREE, 
+				    NULL_TREE);
+  int success = pushcase (NULL_TREE, 0, label, &duplicate);
+
+  if (success == 1)
+    error ("ELSE label not within a CASE statement");
+#if 0
+  else if (success == 2)
+    {
+      error ("multiple default labels found in a CASE statement"); 
+      error_with_decl (duplicate, "this is the first ELSE label");
+    }
+#endif
+}
+
+/* Handle cases label such as (I:J):  or (modename): */
+
+static void
+chill_handle_case_label_range (min_value, max_value, selector)
+     tree min_value, max_value, selector;
+{
+  register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+  min_value = check_case_value (min_value, selector);
+  max_value = check_case_value (max_value, selector);
+  if (TREE_CODE (min_value) != ERROR_MARK
+      && TREE_CODE (max_value) != ERROR_MARK)
+    {
+      tree duplicate;
+      int success = pushcase_range (min_value, max_value,
+				    convert, label, &duplicate);
+      if (success == 1)
+	error ("label found outside of CASE statement");
+      else if (success == 2)
+	{
+	  error ("duplicate CASE value");
+	  error_with_decl (duplicate, "this is the first entry for that value");
+	}
+      else if (success == 3)
+	error ("CASE value out of range");
+      else if (success == 4)
+	error ("empty range");
+      else if (success == 5)
+	error ("label within scope of cleanup or variable array");
+    }
+}
+
+void
+chill_handle_case_label (label_value, selector)
+     tree label_value, selector;
+{
+  if (label_value == NULL_TREE 
+      || TREE_CODE (label_value) == ERROR_MARK)
+    return;
+  if (TREE_CODE (label_value) == RANGE_EXPR)
+    {
+      if (TREE_OPERAND (label_value, 0) == NULL_TREE)
+	chill_handle_case_default ();  /* i.e. (ELSE): or (*): */
+      else
+	chill_handle_case_label_range (TREE_OPERAND (label_value, 0),
+				       TREE_OPERAND (label_value, 1),
+				       selector);
+    }
+  else if (TREE_CODE (label_value) == TYPE_DECL)
+    {
+      tree type = TREE_TYPE (label_value);
+      if (! discrete_type_p (type))
+	error ("mode in label is not discrete");
+      else
+	chill_handle_case_label_range (TYPE_MIN_VALUE (type),
+				       TYPE_MAX_VALUE (type),
+				       selector);
+    }
+  else
+    {
+      register tree label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+
+      label_value = check_case_value (label_value, selector);
+
+      if (TREE_CODE (label_value) != ERROR_MARK)
+	{
+	  tree duplicate;
+	  int success = pushcase (label_value, convert, label, &duplicate);
+	  if (success == 1)
+	    error ("label not within a CASE statement");
+	  else if (success == 2)
+	    {
+	      error ("duplicate case value");
+	      error_with_decl (duplicate, 
+			       "this is the first entry for that value");
+	    }
+	  else if (success == 3)
+	    error ("CASE value out of range");
+	  else if (success == 4)
+	    error ("empty range");
+	  else if (success == 5)
+	    error ("label within scope of cleanup or variable array");
+        }
+    }
+}
+
+int
+chill_handle_single_dimension_case_label (
+  selector, label_spec, expand_exit_needed, caseaction_flag
+)
+  tree selector, label_spec;
+  int *expand_exit_needed, *caseaction_flag;
+{
+  tree labels, one_label;
+  int  no_completeness_check = 0;
+
+  if (*expand_exit_needed || *caseaction_flag == 1)
+    {
+      expand_exit_something ();
+      *expand_exit_needed = 0;
+    }
+
+  for (labels = label_spec; labels != NULL_TREE; labels = TREE_CHAIN (labels))
+    for (one_label = TREE_VALUE (labels); one_label != NULL_TREE;
+         one_label = TREE_CHAIN (one_label))
+      {
+        if (TREE_VALUE (one_label) == case_else_node)
+          no_completeness_check = 1;
+
+        chill_handle_case_label (TREE_VALUE (one_label), selector);
+      }
+
+  *caseaction_flag = 1;
+
+  return no_completeness_check;
+}
+
+static tree
+chill_handle_multi_case_label_range (low, high, selector)
+  tree low, high, selector;
+{
+  tree low_expr, high_expr, and_expr;
+  tree selector_type;
+  int  low_target_val, high_target_val;
+  int  low_type_val, high_type_val;
+
+  /* we can eliminate some tests is the low and/or high value in the given range
+     are outside the range of the selector type. */
+  low_target_val  = TREE_INT_CST_LOW (low);
+  high_target_val = TREE_INT_CST_LOW (high);
+  selector_type   = TREE_TYPE (selector);
+  low_type_val    = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
+  high_type_val   = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
+
+  if (low_target_val > high_type_val || high_target_val < low_type_val)
+    return boolean_false_node; /* selector never in range */
+
+  if (low_type_val >= low_target_val)
+    {
+      if (high_type_val <= high_target_val)
+	return boolean_true_node; /* always in the range */
+      return build_compare_expr (LE_EXPR, selector, high);
+    }
+
+  if (high_type_val <= high_target_val)
+    return build_compare_expr (GE_EXPR, selector, low);
+
+  /* The target range in completely within the range of the selector, but we
+     might be able to save a test if the upper bound is the same as the lower
+     bound. */
+  if (low_target_val == high_target_val)
+    return build_compare_expr (EQ_EXPR, selector, low);
+
+  /* No optimizations possible. Just generate tests against the upper and lower
+     bound of the target */
+  low_expr  = build_compare_expr (GE_EXPR, selector, low);
+  high_expr = build_compare_expr (LE_EXPR, selector, high);
+  and_expr  = build_chill_binary_op (TRUTH_ANDIF_EXPR, low_expr, high_expr);
+
+  return and_expr;
+}
+
+static tree
+chill_handle_multi_case_else_label (selector)
+     tree selector;
+{
+  tree else_range, selector_value, selector_type;
+  tree low, high, larg;
+
+  else_range = TREE_PURPOSE (selector);
+  if (else_range == NULL_TREE)
+    return boolean_false_node; /* no values in ELSE range */
+
+  /* Test each of the ranges in the else-range chain */
+  selector_value = TREE_VALUE (selector);
+  selector_type  = TREE_TYPE (selector_value);
+  low  = convert (selector_type, TREE_PURPOSE (else_range));
+  high = convert (selector_type, TREE_VALUE (else_range));
+  larg = chill_handle_multi_case_label_range (low, high, selector_value);
+
+  for (else_range = TREE_CHAIN (else_range);
+       else_range != NULL_TREE;
+       else_range = TREE_CHAIN (else_range))
+    {
+      tree rarg;
+      low  = convert (selector_type, TREE_PURPOSE (else_range));
+      high = convert (selector_type, TREE_VALUE (else_range));
+      rarg = chill_handle_multi_case_label_range (low, high, selector_value);
+      larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
+    }
+
+  return larg;
+}
+
+static tree
+chill_handle_multi_case_label (selector, label)
+  tree selector, label;
+{
+  tree expr;
+
+  if (label == NULL_TREE || TREE_CODE (label) == ERROR_MARK)
+    return;
+
+  if (TREE_CODE (label) == INTEGER_CST)
+    {
+      int  target_val = TREE_INT_CST_LOW (label);
+      tree selector_type = TREE_TYPE (TREE_VALUE (selector));
+      int  low_type_val  = TREE_INT_CST_LOW (TYPE_MIN_VALUE (selector_type));
+      int  high_type_val = TREE_INT_CST_LOW (TYPE_MAX_VALUE (selector_type));
+      if (target_val < low_type_val || target_val > high_type_val)
+	expr = boolean_false_node;
+      else
+	expr = build_compare_expr (EQ_EXPR, TREE_VALUE (selector), label);
+    }
+  else if (TREE_CODE (label) == RANGE_EXPR)
+    {
+      if (TREE_OPERAND (label, 0) == NULL_TREE)
+	{
+	  if (TREE_OPERAND (label, 1) == NULL_TREE)
+	    expr = boolean_true_node; /* (*) -- matches everything */
+	  else
+	    expr = chill_handle_multi_case_else_label (selector);
+	}
+      else
+	{
+	  tree low = TREE_OPERAND (label, 0);
+	  tree high = TREE_OPERAND (label, 1);
+	  if (TREE_CODE (low) != INTEGER_CST)
+	    {
+	      error ("Lower bound of range must be a discrete literal expression");
+	      expr = error_mark_node;
+	    }
+	  if (TREE_CODE (high) != INTEGER_CST)
+	    {
+	      error ("Upper bound of range must be a discrete literal expression");
+	      expr = error_mark_node;
+	    }
+	  if (expr != error_mark_node)
+	    {
+	      expr = chill_handle_multi_case_label_range (
+                       low, high, TREE_VALUE (selector));
+	    }
+	}
+    }
+  else if (TREE_CODE (label) == TYPE_DECL)
+    {
+      tree type = TREE_TYPE (label);
+      if (! discrete_type_p (type))
+	{
+	  error ("mode in label is not discrete");
+	  expr = error_mark_node;
+	}
+      else
+	expr = chill_handle_multi_case_label_range (
+		 TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type), TREE_VALUE (selector));
+    }
+  else
+    {
+      error ("The CASE label is not valid");
+      expr = error_mark_node;
+    }
+
+  return expr;
+}
+
+static tree
+chill_handle_multi_case_label_list (selector, labels)
+  tree selector, labels;
+{
+  tree one_label, selector_value, larg, rarg;
+
+  one_label = TREE_VALUE (labels);
+  larg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
+
+  for (one_label = TREE_CHAIN (one_label);
+       one_label != NULL_TREE;
+       one_label = TREE_CHAIN (one_label))
+    {
+      rarg = chill_handle_multi_case_label (selector, TREE_VALUE (one_label));
+      larg = build_chill_binary_op (TRUTH_ORIF_EXPR, larg, rarg);
+    }
+
+  return larg;
+}
+
+tree
+build_multi_case_selector_expression (selector_list, label_spec)
+  tree selector_list, label_spec;
+{
+  tree labels, selector, larg, rarg;
+
+  labels   = label_spec;
+  selector = selector_list;
+  larg = chill_handle_multi_case_label_list(selector, labels);
+
+  for (labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector);
+       labels != NULL_TREE && selector != NULL_TREE;
+       labels = TREE_CHAIN (labels), selector = TREE_CHAIN (selector))
+    {
+      rarg = chill_handle_multi_case_label_list(selector, labels);
+      larg = build_chill_binary_op (TRUTH_ANDIF_EXPR, larg, rarg);
+    }
+
+  if (labels != NULL_TREE || selector != NULL_TREE)
+    error ("The number of CASE selectors does not match the number of CASE label lists");
+
+  return larg;
+}
+
+#define BITARRAY_TEST(ARRAY, INDEX) \
+  ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
+			  & (1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR)))
+#define BITARRAY_SET(ARRAY, INDEX) \
+  ((ARRAY)[(unsigned)(INDEX) / HOST_BITS_PER_CHAR]\
+			  |= 1 << ((unsigned)(INDEX) % HOST_BITS_PER_CHAR))
+
+extern HOST_WIDE_INT all_cases_count PROTO((tree, int*));
+extern void mark_seen_cases PROTO((tree, unsigned char*, long, int));
+
+/* CASES_SEEN is a set (bitarray) of length COUNT.
+   For each element that is zero, print an error message,
+   assume the element have the given TYPE. */
+
+static void
+print_missing_cases (type, cases_seen, count)
+     tree type;
+     unsigned char *cases_seen;
+     long count;
+{
+  long i;
+  for (i = 0;  i < count; i++)
+    {
+      if (BITARRAY_TEST(cases_seen, i) == 0)
+	{
+	  char buf[20];
+	  long x = i;
+	  long j;
+	  tree t = type;
+	  char *err_val_name = "???";
+	  if (TYPE_MIN_VALUE (t)
+	      && TREE_CODE (TYPE_MIN_VALUE (t)) == INTEGER_CST)
+	    x += TREE_INT_CST_LOW (TYPE_MIN_VALUE (t));
+	  while (TREE_TYPE (t) != NULL_TREE)
+	    t = TREE_TYPE (t);
+	  switch (TREE_CODE (t))
+	    {
+	      tree v;
+	    case BOOLEAN_TYPE:
+	      err_val_name = x ? "TRUE" : "FALSE";
+	      break;
+	    case CHAR_TYPE:
+	      if ((x >= ' ' && x < 127) && x != '\'' && x != '^')
+		sprintf (buf, "'%c'", x);
+	      else
+		sprintf (buf, "'^(%d)'", x);
+	      err_val_name = buf;
+	      j = i;
+	      while (j < count && !BITARRAY_TEST(cases_seen, j))
+		j++;
+	      if (j > i + 1)
+		{
+		  long y = x+j-i-1;
+		  err_val_name += strlen (err_val_name);
+		  if ((y >= ' ' && y < 127) && y != '\'' && y != '^')
+		    sprintf (err_val_name, "%s:'%c'", buf, y);
+		  else
+		    sprintf (err_val_name, "%s:'^(%d)'", buf, y);
+		  i = j - 1;      
+		}
+	      break;
+	    case ENUMERAL_TYPE:
+	      for (v = TYPE_VALUES (t);  v && x;  v = TREE_CHAIN (v))
+		x--;
+	      if (v)
+		err_val_name = IDENTIFIER_POINTER (TREE_PURPOSE (v));
+	      break;
+	    default:
+	      j = i;
+	      while (j < count && !BITARRAY_TEST(cases_seen, j))
+		j++;
+	      if (j == i + 1)
+		sprintf (buf, "%d", x);
+	      else
+		sprintf (buf, "%d:%d", x, x+j-i-1);
+	      i = j - 1;      
+	      err_val_name = buf;
+	      break;
+	    }
+	  error ("incomplete CASE - %s not handled", err_val_name);
+	}
+    }
+}
+
+void
+check_missing_cases (type)
+     tree type;
+{
+  int is_sparse;
+  /* For each possible selector value. a one iff it has been matched
+     by a case value alternative. */
+  unsigned char *cases_seen;
+  /* The number of possible selector values. */
+  HOST_WIDE_INT size = all_cases_count (type, &is_sparse);
+  long bytes_needed = (size+HOST_BITS_PER_CHAR)/HOST_BITS_PER_CHAR;
+
+  if (size == -1)
+    warning ("CASE selector with variable range");
+  else if (size < 0 || size > 600000
+	   /* We deliberately use malloc here - not xmalloc. */
+	   || (cases_seen = (char*) malloc (bytes_needed)) == NULL)
+    warning ("too many cases to do CASE completeness testing");
+  else
+    {
+      bzero (cases_seen, bytes_needed);
+      mark_seen_cases (type, cases_seen, size, is_sparse);
+      print_missing_cases (type, cases_seen, size);
+      free (cases_seen);
+    }
+}
+
+/*
+ * We build an expression tree here because, in many contexts,
+ * we don't know the type of result that's desired.  By the
+ * time we get to expanding the tree, we do know.
+ */
+tree
+build_chill_case_expr (exprlist, casealtlist_expr,
+		       optelsecase_expr)
+     tree exprlist, casealtlist_expr, optelsecase_expr;
+{
+  return build (CASE_EXPR, NULL_TREE, exprlist,
+		optelsecase_expr ?
+		  tree_cons (NULL_TREE,
+			     optelsecase_expr,
+			     casealtlist_expr) :
+		  casealtlist_expr);
+}
+
+/* This function transforms the selector_list and alternatives into a COND_EXPR. */
+tree
+build_chill_multi_dimension_case_expr (selector_list, alternatives, else_expr)
+  tree selector_list, alternatives, else_expr;
+{
+  tree expr;
+
+  selector_list = check_case_selector_list (selector_list);
+
+  if (alternatives == NULL_TREE)
+    return NULL_TREE;
+
+  alternatives = nreverse (alternatives);
+  /* alternatives represents the CASE label specifications and resulting values in
+     the reverse order in which they appeared.
+     If there is an ELSE expression, then use it. If there is no
+     ELSE expression, make the last alternative (which is the first in the list)
+     into the ELSE expression. This is safe because, if the CASE is complete
+     (as required), then the last condition need not be checked anyway. */
+  if (else_expr != NULL_TREE)
+    expr = else_expr;
+  else
+    {
+      expr = TREE_VALUE (alternatives);
+      alternatives = TREE_CHAIN (alternatives);
+    }
+
+  for ( ; alternatives != NULL_TREE; alternatives = TREE_CHAIN (alternatives))
+    { 
+      tree value  = TREE_VALUE (alternatives);
+      tree labels = TREE_PURPOSE (alternatives);
+      tree cond   = build_multi_case_selector_expression(selector_list, labels);
+      expr = build_nt (COND_EXPR, cond, value, expr);
+    }
+
+  return expr;
+}
+
+
+/* This is called with the assumption that RHS has been stabilized.  
+   It has one purpose:  to iterate through the CHILL list of LHS's */
+void
+expand_assignment_action (loclist, modifycode, rhs)
+     tree loclist;
+     enum chill_tree_code modifycode;
+     tree rhs;
+{
+  if (loclist == NULL_TREE || TREE_CODE (loclist) == ERROR_MARK
+      || rhs == NULL_TREE  || TREE_CODE (rhs) == ERROR_MARK)
+    return;
+
+  if (TREE_CHAIN (loclist) != NULL_TREE)
+    { /* Multiple assignment */
+      tree target;
+      if (TREE_TYPE (rhs) != NULL_TREE)
+	rhs = save_expr (rhs);
+      else if (TREE_CODE (rhs) == CONSTRUCTOR)
+	error ("type of tuple cannot be implicit in multiple assignent");
+      else if (TREE_CODE (rhs) == CASE_EXPR || TREE_CODE (rhs) == COND_EXPR)
+	error ("conditional expression cannot be used in multiple assignent");
+      else
+	error ("internal error - unknown type in multiple assignment");
+
+      if (modifycode != NOP_EXPR)
+	{
+	  error ("no operator allowed in multiple assignment,");
+	  modifycode = NOP_EXPR;
+	}
+
+      for (target = TREE_CHAIN (loclist); target; target = TREE_CHAIN (target))
+	{
+	  if (!CH_EQUIVALENT (TREE_TYPE (TREE_VALUE (target)),
+			      TREE_TYPE (TREE_VALUE (loclist))))
+	    {
+	      error
+		("location modes in multiple assignment are not equivalent");
+	      break;
+	    }
+	}
+    }
+  for ( ; loclist != NULL_TREE; loclist = TREE_CHAIN (loclist))
+    chill_expand_assignment (TREE_VALUE (loclist), modifycode, rhs);
+}
+
+void
+chill_expand_assignment (lhs, modifycode, rhs)
+     tree lhs;
+     enum chill_tree_code modifycode;
+     tree rhs;
+{
+  tree loc;
+
+  while (TREE_CODE (lhs) == COMPOUND_EXPR)
+    {
+      expand_expr (TREE_OPERAND (lhs, 0), const0_rtx, VOIDmode, 0);
+      emit_queue ();
+      lhs = TREE_OPERAND (lhs, 1);
+    }
+
+  if (TREE_CODE (lhs) == ERROR_MARK)
+    return;
+
+  /* errors for assignment to BUFFER, EVENT locations.
+     what about SIGNALs? FIXME: Need similar test in
+     build_chill_function_call. */
+  if (TREE_CODE (lhs) == IDENTIFIER_NODE)
+    {
+      tree decl = lookup_name (lhs);
+      if (decl)
+	{
+	  tree type = TREE_TYPE (decl);
+	  if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
+	    {
+	      error ("You may not assign a value to a BUFFER or EVENT location");
+	      return;
+	    }
+	}
+    }
+
+  if (TYPE_READONLY_PROPERTY (TREE_TYPE (lhs)) || TREE_READONLY (lhs))
+    {
+      error ("can't assign value to READonly location");
+      return;
+    }
+  if (CH_TYPE_NONVALUE_P (TREE_TYPE (lhs)))
+    {
+      error ("cannot assign to location with non-value property");
+      return;
+    }
+
+  if (TREE_CODE (TREE_TYPE (lhs)) == REFERENCE_TYPE)
+    lhs = convert_from_reference (lhs);
+
+  /* check for lhs is a location */
+  loc = lhs;
+  while (1)
+    {
+      if (TREE_CODE (loc) == SLICE_EXPR)
+	loc = TREE_OPERAND (loc, 0);
+      else if (TREE_CODE (loc) == SET_IN_EXPR)
+	loc = TREE_OPERAND (loc, 1);
+      else
+	break;
+    }
+  if (! CH_LOCATION_P (loc))
+    {
+      error ("lefthand side of assignment is not a location");
+      return;
+    }
+
+  /* If a binary op has been requested, combine the old LHS value with
+     the RHS producing the value we should actually store into the LHS. */
+
+  if (modifycode != NOP_EXPR)
+    {
+      lhs = stabilize_reference (lhs);
+      /* This is to handle border-line cases such
+	 as: LHS OR := [I].  This seems to be permitted
+	 by the letter of Z.200, though it violates
+	 its spirit, since LHS:=LHS OR [I] is
+	 *not* legal. */
+      if (TREE_TYPE (rhs) == NULL_TREE)
+	rhs = convert (TREE_TYPE (lhs), rhs);
+      rhs = build_chill_binary_op (modifycode, lhs, rhs);
+    }
+
+  rhs = chill_convert_for_assignment (TREE_TYPE (lhs), rhs, "assignment");
+
+  /* handle the LENGTH (vary_array) := expr action */
+  loc = lhs;
+  if (TREE_CODE (loc) == NOP_EXPR)
+    loc = TREE_OPERAND (loc, 0);
+  if (TREE_CODE (loc) == COMPONENT_REF
+      && chill_varying_type_p (TREE_TYPE (TREE_OPERAND (loc, 0)))
+      && DECL_NAME (TREE_OPERAND (loc, 1)) == var_length_id)
+    {
+      expand_varying_length_assignment (TREE_OPERAND (loc, 0), rhs);
+    }
+  else if (TREE_CODE (lhs) == SLICE_EXPR)
+    {
+      tree func = lookup_name (get_identifier ("__pscpy"));
+      tree dst = TREE_OPERAND (lhs, 0);
+      tree dst_offset = TREE_OPERAND (lhs, 1);
+      tree length = TREE_OPERAND (lhs, 2);
+      tree src, src_offset;
+      if (TREE_CODE (rhs) == SLICE_EXPR)
+	{
+	  src = TREE_OPERAND (rhs, 0);
+	  /* Should check that the TREE_OPERAND (src, 0) is
+	     the same as length and powerserlen (src).  FIXME */
+	  src_offset = TREE_OPERAND (rhs, 1);
+	}
+      else
+	{
+	  src = rhs;
+	  src_offset = integer_zero_node;
+	}
+      expand_expr_stmt (build_chill_function_call (func,
+	tree_cons (NULL_TREE, force_addr_of (dst),
+	  tree_cons (NULL_TREE, powersetlen (dst),
+	    tree_cons (NULL_TREE, convert (long_unsigned_type_node, dst_offset),
+	      tree_cons (NULL_TREE, force_addr_of (src),
+		tree_cons (NULL_TREE, powersetlen (src),
+		  tree_cons (NULL_TREE, convert (long_unsigned_type_node, src_offset),
+		    tree_cons (NULL_TREE, convert (long_unsigned_type_node, length),
+		       NULL_TREE)))))))));
+    }
+
+  else if (TREE_CODE (lhs) == SET_IN_EXPR)
+    {
+      tree from_pos = save_expr (TREE_OPERAND (lhs, 0));
+      tree set = TREE_OPERAND (lhs, 1);
+      tree domain = TYPE_DOMAIN (TREE_TYPE (set));
+      tree set_length = size_binop (PLUS_EXPR,
+				    size_binop (MINUS_EXPR,
+						TYPE_MAX_VALUE (domain),
+						TYPE_MIN_VALUE (domain)),
+				    integer_one_node);
+      tree filename = force_addr_of (get_chill_filename());
+      
+      if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
+	sorry("bitstring slice");
+      expand_expr_stmt (
+	build_chill_function_call (lookup_name (
+	  get_identifier ("__setbitpowerset")),
+	      tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
+		  tree_cons (NULL_TREE, set_length,
+		    tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
+		      tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
+			tree_cons (NULL_TREE, rhs,
+			  tree_cons (NULL_TREE, filename,
+			    tree_cons (NULL_TREE, get_chill_linenumber(),
+  			      NULL_TREE)))))))));
+    }
+
+  /* Handle arrays of packed bitfields. Currently, this is limited to bitfields
+     which are 1 bit wide, so use the powerset runtime function. */
+  else if (TREE_CODE (lhs) == PACKED_ARRAY_REF)
+    {
+      tree from_pos = save_expr (TREE_OPERAND (lhs, 1));
+      tree array = TREE_OPERAND (lhs, 0);
+      tree domain = TYPE_DOMAIN (TREE_TYPE (array));
+      tree array_length = size_binop (PLUS_EXPR,
+				    size_binop (MINUS_EXPR,
+						TYPE_MAX_VALUE (domain),
+						TYPE_MIN_VALUE (domain)),
+				    integer_one_node);
+      tree filename = force_addr_of (get_chill_filename());
+      expand_expr_stmt (
+	build_chill_function_call (lookup_name (
+	  get_identifier ("__setbitpowerset")),
+            tree_cons (NULL_TREE, build_chill_addr_expr (array, "packed bitfield array"),
+		tree_cons (NULL_TREE, convert (long_unsigned_type_node, array_length),
+		  tree_cons (NULL_TREE, convert (long_integer_type_node,
+						 TYPE_MIN_VALUE (domain)),
+		    tree_cons (NULL_TREE, convert (long_integer_type_node, from_pos),
+		      tree_cons (NULL_TREE, build1 (CONVERT_EXPR, boolean_type_node, rhs),
+			tree_cons (NULL_TREE, filename,
+			  tree_cons (NULL_TREE, get_chill_linenumber(),
+  			    NULL_TREE)))))))));
+    }
+
+  /* The following is probably superceded by the
+     above code for SET_IN_EXPR. FIXME! */
+  else if (TREE_CODE (lhs) == BIT_FIELD_REF)
+    {
+      tree set = TREE_OPERAND (lhs, 0);
+      tree numbits = TREE_OPERAND (lhs, 1);
+      tree from_pos = save_expr (TREE_OPERAND (lhs, 2));
+      tree domain = TYPE_DOMAIN (TREE_TYPE (set));
+      tree set_length = size_binop (PLUS_EXPR,
+				    size_binop (MINUS_EXPR,
+						TYPE_MAX_VALUE (domain),
+						TYPE_MIN_VALUE (domain)),
+				    integer_one_node);
+      tree filename = force_addr_of (get_chill_filename());
+      tree to_pos;
+      switch (TREE_CODE (TREE_TYPE (rhs)))
+	{
+	case SET_TYPE:
+	  to_pos = size_binop (MINUS_EXPR,
+			       size_binop (PLUS_EXPR, from_pos, numbits),
+			       integer_one_node);
+	  break;
+	case BOOLEAN_TYPE:
+	  to_pos = from_pos;
+	  break;
+	default:
+	  abort ();
+	}
+      
+      if (TREE_CODE (TREE_TYPE (lhs)) != BOOLEAN_TYPE)
+	sorry("bitstring slice");
+      expand_expr_stmt (
+	  build_chill_function_call( lookup_name (
+	      get_identifier ("__setbitpowerset")),
+		tree_cons (NULL_TREE, build_chill_addr_expr (set, "powerset"),
+		  tree_cons (NULL_TREE, set_length,
+		    tree_cons (NULL_TREE, TYPE_MIN_VALUE (domain),
+		      tree_cons (NULL_TREE, from_pos,
+			tree_cons (NULL_TREE, rhs,
+			  tree_cons (NULL_TREE, filename,
+			    tree_cons (NULL_TREE, get_chill_linenumber(),
+	  		      NULL_TREE)))))))));
+    }
+
+  else
+    expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
+}
+
+/* Also assumes that rhs has been stabilized */
+void
+expand_varying_length_assignment (lhs, rhs)
+     tree lhs, rhs;
+{
+  tree base_array, min_domain_val;
+
+  pedwarn ("LENGTH on left-hand-side is non-portable");
+      
+  if (! CH_LOCATION_P (lhs))
+    {
+      error ("Can only set LENGTH of array location");
+      return;
+    }
+
+  /* cause a RANGE exception if rhs would cause a 'hole' in the array. */
+  rhs = valid_array_index_p (lhs, rhs, "new array length too large", 1);
+
+  base_array     = CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs));
+  min_domain_val = TYPE_MIN_VALUE (TYPE_DOMAIN (base_array));
+
+  lhs = build_component_ref (lhs, var_length_id);
+  rhs = size_binop (MINUS_EXPR, rhs, min_domain_val);
+
+  expand_expr_stmt (build_chill_modify_expr (lhs, rhs));
+}
+
+void
+push_action ()
+{
+  push_handler ();
+  if (ignoring)
+    return;
+  emit_line_note (input_filename, lineno);
+}

gcc/ch/chill.in

+#!/bin/sh
+# Compile GNU Chill programs.
+: || exec /bin/sh -f $0 $argv:q
+
+# The compiler name might be different when doing cross-compilation
+# (this should be configured)
+gcc_name=gcc
+whatgcc=gcc
+speclang=-xnone
+startfile=chillrt0
+gnuchill_script_flags=
+gnuchill_version=unknown
+extraflags=
+
+# replace the command name by the name of the new command
+progname=`basename $0`
+case "$0" in
+  */*)
+    gcc=`echo $0 | sed -e "s;/[^/]*$;;"`/$gcc_name
+    ;;
+  *)
+    gcc=$gcc_name
+    ;;
+esac
+
+# $first is yes for first arg, no afterwards.
+first=yes
+# If next arg is the argument of an option, $quote is non-empty.
+# More precisely, it is the option that wants an argument.
+quote=
+# $library is made empty to disable use of libchill.
+library="-lchill"
+libpath=chillrt
+numargs=$#
+
+for arg
+do
+  if [ $first = yes ]
+  then
+    # Need some 1st arg to `set' which does not begin with `-'.
+    # We get rid of it after the loop ends.
+    set gcc
+    first=no
+  fi
+  # If you have to ask what this does, you should not edit this file. :-)
+  # The ``S'' at the start is so that echo -nostdinc does not eat the
+  # -nostdinc.
+  arg=`echo "S$arg" | sed "s/^S//; s/'/'\\\\\\\\''/g"`
+  if [ x$quote != x ]
+  then
+    quote=
+  else
+    quote=
+    case $arg in
+      -nostdlib)
+	# Inhibit linking with -lchill.
+	library=
+	libpath=
+	startfile=
+	;;
+      -B*)
+	gcc=`echo $arg | sed -e "s/^-B//"`$gcc_name
+	;;
+      -[bBVDUoeTuIYmLiA] | -Tdata | -Xlinker)
+	# these switches take following word as argument,
+	# so don't treat it as a file name.
+	quote=$arg
+	;;
+      -[cSEM] | -MM)
+	# Don't specify libraries if we won't link,
+	# since that would cause a warning.
+	library=
+	libpath=
+	startfile=
+	;;
+      -x*)
+	speclang=$arg
+	;;
+      -v)
+	# catch `chill -v'
+	if [ $numargs = 1 ] ; then
+	  library=
+	  libpath=
+	  startfile=
+	fi
+	echo "GNUCHILL version $gnuchill_version"
+	;;
+      -fgrant-only | -fchill-grant-only)
+        #inhibit production of an object file
+        extraflags="-S -o /dev/null"
+	library=
+	libpath=
+	startfile=
+        ;;
+      -*)
+	# Pass other options through; they don't need -x and aren't inputs.
+	;;
+      *)
+	# If file ends in .i, put options around it.
+	# But not if a specified -x option is currently active.
+	case "$speclang $arg" in -xnone\ *.[i])
+	  set "$@" -xchill "'$arg'" -xnone
+	  continue
+	esac
+	;;
+    esac
+  fi
+  set "$@" "'$arg'"
+done
+
+# Get rid of that initial 1st arg
+if [ $first = no ]; then
+  shift
+else
+  echo "$0: No input files specified."
+  exit 1
+fi
+
+if [ x$quote != x ]
+then
+  echo "$0: argument to \`$quote' missing"
+  exit 1
+fi
+
+# The '-ansi' flag prevents cpp from changing this:
+#  NEWMODE x = SET (sun, mon, thu, wed, thu, fri, sat);
+#to this:
+#  NEWMODE x = SET (1, mon, thu, wed, thu, fri, sat);
+#which is a CHILL syntax error.
+eval $whatgcc -ansi $gnuchill_script_flags $startfile "$@" $libpath $library $extraflags

gcc/ch/config-lang.in

+# Top level configure fragment for GNU CHILL.
+#   Copyright (C) 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.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language	- name of language as it would appear in $(LANGUAGES)
+# compilers	- value to add to $(COMPILERS)
+# stagestuff	- files to add to $(STAGESTUFF)
+# diff_excludes	- files to ignore when building diffs between two versions.
+
+language="CHILL"
+
+compilers="cc1chill"
+
+stagestuff="chill chill-cross cc1chill"
+
+diff_excludes="-x -x ch/chill.info*"

gcc/ch/configure

+#!/bin/sh
+# Configuration script for GNU CHILL
+#   Copyright (C) 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.
+
+#
+# Shell script to create proper links to machine-dependent files in
+# preparation for compiling gcc.
+#
+# Options: --srcdir=DIR		specifies directory where sources are.
+# 	   --host=HOST		specifies host configuration.
+#	   --target=TARGET	specifies target configuration.
+#	   --build=TARGET	specifies configuration of machine you are
+#				using to compile GCC.
+#	   --prefix=DIR		specifies directory to install in.
+#	   --local-prefix=DIR	specifies directory to put local ./include in.
+#	   --exec-prefix=DIR	specifies directory to install executables in.
+#	   --with-gnu-ld	arrange to work with GNU ld.
+#	   --with-gnu-as	arrange to work with GAS.
+#	   --with-stabs		arrange to use stabs instead of host debug format.
+#	   --with-elf		arrange to use elf instead of host debug format.
+#	   --nfp		assume system has no FPU.
+#
+# If configure succeeds, it leaves its status in config.status.
+# If configure fails after disturbing the status quo, 
+# 	config.status is removed.
+#
+
+progname=$0
+# Configure the runtime and regression-test directories
+SUBDIRS="runtime utils"
+SUBDIRS="$SUBDIRS testsuite/compile"
+SUBDIRS="$SUBDIRS testsuite/execute"
+SUBDIRS="$SUBDIRS testsuite/execute/telebras"
+SUBDIRS="$SUBDIRS testsuite/noncompile"
+SUBDIRS="$SUBDIRS testsuite/examples"
+SUBDIRS="$SUBDIRS testsuite/execute/oe"
+SUBDIRS="$SUBDIRS testsuite/compile/elektra"
+SUBDIRS="$SUBDIRS testsuite/compile/votrics"
+
+# Default --srcdir to the directory where the script is found, 
+# if a directory was specified.
+# The second sed call is to convert `.//configure' to `./configure'.
+srcdir=`echo $0 | sed 's|//|/|' | sed 's|/[^/]*$||'`
+if [ x$srcdir = x$0 ]
+then
+srcdir=
+fi
+
+host=
+
+# Default prefix to /usr/local.
+prefix=/usr/local
+
+# local_prefix specifies where to find the directory /usr/local/include
+# We don't use $(prefix) for this
+# because we always want GCC to search /usr/local/include
+# even if GCC is installed somewhere other than /usr/local.
+# Think THREE TIMES before specifying any other value for this!
+# DO NOT make this use $prefix!
+local_prefix=/usr/local
+# CYGNUS LOCAL: for our purposes, this must be prefix.  This is apparently
+# only done for the benefit of glibc, and we don't use glibc.
+local_prefix='$(prefix)'
+# Default is to let the Makefile set exec_prefix from $(prefix)
+exec_prefix='$(prefix)'
+
+# CYGNUS LOCAL.  Default to nothing.
+program_transform_name=
+program_transform_set=
+site=
+
+remove=rm
+hard_link=ln
+symbolic_link='ln -s'
+copy=cp
+
+# Record all the arguments, to write them in config.status.
+arguments=$*
+
+#for Test
+#remove="echo rm"
+#hard_link="echo ln"
+#symbolic_link="echo ln -s"
+
+target=
+host=
+build=
+
+for arg in $*;
+do
+  case $next_arg in
+  --srcdir)
+    srcdir=$arg
+    next_arg=
+    ;;
+  --host)
+    host=$arg
+    next_arg=
+    ;;
+  --target)
+    target=$arg
+    next_arg=
+    ;;
+  --build)
+    build=$arg
+    next_arg=
+    ;;
+  --prefix)
+    prefix=$arg
+    next_arg=
+    ;;
+  --local-prefix)
+    local_prefix=$arg
+    next_arg=
+    ;;
+  --exec-prefix)
+    exec_prefix=$arg
+    next_arg=
+    ;;
+  --program-transform-name) # CYGNUS LOCAL
+    # Double any backslashes or dollar signs in the argument.
+    if [ -n "${arg}" ] ; then
+      program_transform_name="${program_transform_name} -e `echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`"
+    fi
+    program_transform_set=yes
+    next_arg=
+    ;;    
+  --program-prefix) # CYGNUS LOCAL
+    if [ -n "${arg}" ]; then
+      program_transform_name="${program_transform_name} -e s,^,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+    fi
+    program_transform_set=yes
+    next_arg=
+    ;;
+  --program-suffix) # CYGNUS LOCAL
+    if [ -n "${arg}" ]; then
+      program_transform_name="${program_transform_name} -e s,\$\$,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+    fi
+    program_transform_set=yes
+    next_arg=
+    ;;
+  --site) # CYGNUS LOCAL
+    site=${arg}
+    next_arg=
+    ;;
+  --x-*)
+    next_arg=
+    ;;
+  *)
+    case $arg in
+     -srcdir | --srcdir | --srcdi | --srcd | --src | --sr | --s)
+	next_arg=--srcdir
+	;;
+     -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=* | --s=*)
+	srcdir=`echo $arg | sed 's/-*s[a-z]*=//'`
+	;;
+     -host | --host | --hos | --ho | --h)
+	next_arg=--host
+	;;
+     -host=* | --host=* | --hos=* | --ho=* | --h=*)
+	host=`echo $arg | sed 's/-*h[a-z]*=//'`
+	;; 
+     -target | --target | --targe | --targ | --tar | --ta | --t)
+	next_arg=--target
+	;;
+     -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+	target=`echo $arg | sed 's/-*t[a-z]*=//'`
+	;; 
+     -build | --build | --buil | --bui | --bu | --b)
+	next_arg=--build
+	;;
+     -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*)
+	build=`echo $arg | sed 's/-*b[a-z]*=//'`
+	;; 
+     -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+	next_arg=--prefix
+	;;
+     -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+	prefix=`echo $arg | sed 's/-*p[a-z]*=//'`
+	;;
+     -local-prefix | --local-prefix | --local-prefi | --local-pref | --local-pre \
+	| --local-pr | --local-p | --local- | --local | --loc | --lo | --l)
+	next_arg=--local-prefix
+	;;
+     -local-prefix=* | --local-prefix=* | --local-prefi=* | --local-pref=* \
+	| --local-pre=* | --local-pr=* | --local-p=* | --local-=* | --local=* \
+	| --loc=* | --lo=* | --l=*)
+	local_prefix=`echo $arg | sed 's/-*l[-a-z]*=//'`
+	;;
+     -exec-prefix | --exec-prefix | --exec-prefi | --exec-pref | --exec-pre \
+	| --exec-pr | --exec-p | --exec- | --exec | --exe | --ex | --e)
+	next_arg=--exec-prefix
+	;;
+     -exec-prefix=* | --exec-prefix=* | --exec-prefi=* | --exec-pref=* \
+	| --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* | --exec=* \
+	| --exe=* | --ex=* | --e=*)
+	exec_prefix=`echo $arg | sed 's/-*e[-a-z]*=//'`
+	;;
+     -program-transform-name | --program-transform-name \
+	| --program-transform-nam | --program-transform-na \
+	| --program-transform-n | --program-transform- | --program-transform \
+	| --program-transfor | --program-transfo | --program-transf \
+	| --program-trans | --program-tran | --program-tra \
+	| --program-tr | --program-t)
+	next_arg=--program-transform-name
+	# CYGNUS LOCAL
+	;;
+     -program-transform-name=* | --program-transform-name=* \
+	| --program-transform-nam=* | --program-transform-na=* \
+	| --program-transform-n=* | --program-transform-=* \
+	| --program-transform=* | --program-transfor=* | --program-transfo=* \
+	| --program-transf=* | --program-trans=* | --program-tran=* \
+	| --program-tra=* | --program-tr=* | --program-t=*)
+	# CYGNUS LOCAL
+	arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'`
+	# Double any \ or $ in the argument.
+	if [ -n "${arg}" ] ; then
+	  program_transform_name="${program_transform_name} -e `echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`"
+	fi
+	program_transform_set=yes
+	;;
+     -program-prefix | --program-prefix | --program-prefi \
+	| --program-pref | --program-pre | --program-pr \
+	| --program-p)
+	next_arg=--program-prefix
+	# CYGNUS LOCAL
+	;;
+     -program-prefix=* | --program-prefix=* | --program-prefi=* \
+	| --program-pref=* | --program-pre=* | --program-pr=* \
+	| --program-p=*)
+	# CYGNUS LOCAL
+	arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'`
+	if [ -n "${arg}" ]; then
+	  program_transform_name="${program_transform_name} -e s,^,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+	fi
+	program_transform_set=yes
+	;;
+     -program-suffix | --program-suffix | --program-suffi \
+	| --program-suff | --program-suf | --program-su \
+	| --program-s)
+	next_arg=--program-suffix
+	# CYGNUS LOCAL
+	;;
+     -program-suffix=* | --program-suffix=* | --program-suffi=* \
+	| --program-suff=* | --program-suf=* | --program-su=* \
+	| --program-s=*)
+	# CYGNUS LOCAL
+	arg=`echo ${arg} | sed -e 's/^[-a-z_]*=//'`
+	if [ -n "${arg}" ]; then
+	  program_transform_name="${program_transform_name} -e s,\$\$,`echo ${arg} | sed -e 's/\\\\/\\\\\\\\/g' -e 's/\\\$/$$/g'`,"
+	fi
+	program_transform_set=yes
+	;;
+     -site | --site | --sit) # CYGNUS LOCAL
+	next_arg=--site
+	;;
+     -site=* | --site=* | --sit=* | --si=*) # CYGNUS LOCAL
+	site=`echo ${arg} | sed 's/^[-a-z]*=//'`
+	;;
+     -with-gnu-ld | --with-gnu-ld | --with-gnu-l)
+	gnu_ld=yes
+	;;
+     -gas | --gas | --ga | --g | -with-gnu-as | --with-gnu-as | -with-gnu-a)
+        gas=yes
+	;;
+     -nfp | --nfp | --nf | --n)
+	nfp=yes
+	;;
+     -with-stabs | -with-stab | -with-sta | -with-st | -with-s \
+	| --with-stabs | --with-stab | --with-sta | --with-st | --with-s \
+	| -stabs | -stab | -sta | -st  \
+	| --stabs | --stab | --sta | --st)
+	stabs=yes
+	;;
+     -with-elf | -with-el | -with-se \
+	| --with-elf | --with-el | --with-e \
+	| -elf | -el | -e \
+	|--elf | --el | --e)
+	elf=yes
+	;;
+     -with-* | --with-*) ;; #ignored
+     -without-* | --without-*) ;; #ignored
+     -enable-* | --enable-*) ;; #ignored
+     -x | --x) ;; # ignored
+     -x-*=* | --x-*=*) ;; # ignored
+     -x-* | --x-*)
+	next_arg=--x-ignored # ignored
+	;;
+     --he*) ;; # ignored for now (--help)
+     --vers*) ;; # ignored for now (--version)
+     -v | -verb* | --verb*) ;; # ignored for now (--verbose)
+     --program-*) ;; #ignored (--program-prefix, --program-suffix)
+     --c*) ;; #ignored (--cache-file)
+     --q*) ;; #ignored (--quiet)
+     --si*) ;; #ignored (--silent)
+     -*)
+	echo "Invalid option \`$arg'" 1>&2
+	exit 1
+	;;
+     *)
+# Allow configure HOST TARGET
+	if [ x$host = x ]
+	then
+		host=$target
+	fi
+	target=$arg
+	;;
+    esac
+  esac
+done
+
+# Find the source files, if location was not specified.
+if [ x$srcdir = x ]
+then
+	srcdirdefaulted=1
+	srcdir=.
+	if [ ! -r tree.c ]
+	then
+		srcdir=..
+	fi
+fi
+
+if [ ! -r ${srcdir}/grant.c ]
+then
+	if [ x$srcdirdefaulted = x ]
+	then
+	  echo "$progname: Can't find CHILL frontend sources in \`${srcdir}'" 1>&2
+	else
+	  echo "$progname: Can't find CHILL frontend sources in \`.' or \`..'" 1>&2
+	fi
+	exit 1
+fi
+
+# Make sure that scripts are executable
+[ -w ${srcdir} -a -f ${srcdir}/regression.sh   ] && \
+  chmod +x ${srcdir}/regression.sh 
+[ -w ${srcdir} -a -f ${srcdir}/regression.prpt ] && \
+  chmod +x ${srcdir}/regression.prpt
+[ -w ${srcdir} -a -f ${srcdir}/regression.awk3 ] && \
+  chmod +x ${srcdir}/regression.awk3
+
+if [ -r ${srcdir}/config.status ] && [ x$srcdir != x. ]
+then
+	echo "$progname: \`configure' has been run in \`${srcdir}'" 1>&2
+	exit 1
+fi
+
+host_xmake_file=
+host_truncate_target=
+
+# Complain if an arg is missing
+if [ x$build = x ]
+then
+	# If host was specified, always use it for build also to avoid
+	# confusion.  If someone wants a cross compiler where build != host,
+	# then they must specify build explicitly.  Since this case is
+	# extremely rare, it does not matter that it is slightly inconvenient.
+	if [ x$host != x ]
+	then
+		build=$host
+	
+	# This way of testing the result of a command substitution is
+	# defined by Posix.2 (section 3.9.1) as well as traditional shells.
+	elif build=`${srcdir}/../config.guess`
+	then
+		echo "This appears to be a ${build} system." 1>&2
+
+	elif [ x$target != x ]
+	then
+		echo 'Config.guess failed to determine the host type.  Defaulting to target.'
+		build=$target
+	else
+		echo 'Config.guess failed to determine the host type.  You need to specify one.' 1>&2
+		echo "\
+Usage: `basename $progname` [--host=HOST] [--build=BUILD]
+       [--prefix=DIR] [--gxx-include-dir=DIR] [--local-pref=DIR] [--exec-pref=DIR]
+       [--with-gnu-as] [--with-gnu-ld] [--with-stabs] [--with-elf] [--nfp] TARGET" 1>&2
+	echo "Where HOST, TARGET and BUILD are three-part configuration names " 1>&2
+		if [ -r config.status ]
+		then
+			tail +2 config.status 1>&2
+		fi
+		exit 1
+	fi
+fi
+
+# If $host was not specified, use $build.
+if [ x$host = x ]
+then
+	host=$build
+fi
+
+# If $target was not specified, use $host.
+if [ x$target = x ]
+then
+	target=$host
+fi
+
+# Validate the specs, and canonicalize them.
+canon_build=`/bin/sh $srcdir/../config.sub $build` || exit 1
+canon_host=`/bin/sh $srcdir/../config.sub $host` || exit 1
+canon_target=`/bin/sh $srcdir/../config.sub $target` || exit 1
+
+rm -f config.bak
+if [ -f config.status ]; then mv -f config.status config.bak; fi
+
+#
+# For the current directory and all of the designated SUBDIRS,
+# do the rest of the script...
+#
+if [ ! -d testsuite ] ; then mkdir testsuite; fi
+_SUBDIRS=
+for d in $SUBDIRS; do
+	[ -d $srcdir/$d ] && _SUBDIRS="$_SUBDIRS $d"
+done
+
+savesrcdir=$srcdir
+STARTDIR=`pwd`
+
+for subdir in $_SUBDIRS
+do
+	tmake_file=
+	host_xmake_file=
+	oldsrcdir=$savesrcdir
+
+	# ${invsubdir} is inverse of ${subdir), *with* trailing /, if needed.
+	invsubdir=`echo ${subdir}/ | sed -e 's|\./||g' -e 's|[^/]*/|../|g'`
+
+	# Re-adjust the path
+	# Also create a .gdbinit file which runs the one in srcdir
+	# and tells GDB to look there for source files.
+
+	case $oldsrcdir in
+	".") srcdir=. ;;
+	/*) # absolute path
+               	srcdir=${oldsrcdir}/${subdir}  ;;
+        *) # otherwise relative
+		srcdir=${invsubdir}${oldsrcdir}/${subdir} ;;
+	esac
+
+        if [ -r ${oldsrcdir}/${subdir}/.gdbinit -a ${oldsrcdir} != "." ] ; then
+		cat > ${subdir}/.gdbinit <<EOF
+dir .
+dir ${srcdir}
+source ${srcdir}/.gdbinit
+EOF
+	fi
+
+	case $oldsrcdir in
+	/*)	;;
+	*)	oldsrcdir=${invsubdir}${oldsrcdir} ;;
+	esac
+	mainsrcdir=${oldsrcdir}/..
+	test -d $subdir || mkdir $subdir
+	cd $subdir
+	#
+	# Create Makefile.tem from Makefile.in.
+	# Make it set VPATH if necessary so that the sources are found.
+	# Also change its value of srcdir.
+	rm -f Makefile.tem
+	echo "VPATH = ${srcdir}" \
+	  | cat - ${srcdir}/Makefile.in \
+	  | sed "s@^srcdir = \.@srcdir = ${srcdir}@" > Makefile.tem
+
+	# Conditionalize the makefile for this host machine.
+	if [ -f ${mainsrcdir}/config/${host_xmake_file} ]
+	then
+		rm -f Makefile.xx
+		sed -e "/####host/  r ${mainsrcdir}/config/${host_xmake_file}" Makefile.tem > Makefile.xx
+		echo "Merged ${host_xmake_file}."
+		rm -f Makefile.tem
+		mv Makefile.xx Makefile.tem
+	else
+	# Say in the makefile that there is no host_xmake_file,
+	# by using a name which (when interpreted relative to $srcdir/config)
+	# will duplicate another dependency: $srcdir/Makefile.in.
+		host_xmake_file=../Makefile.in
+	fi
+	
+	# Define variables host_canonical, build_canonical, and target_canonical
+	# because some Cygnus local changes in the Makefile depend on them.
+	echo host_canonical = ${canon_host} > Makefile.xx
+	echo target_canonical = ${canon_target} >> Makefile.xx
+	echo build_canonical = ${canon_build} >> Makefile.xx
+	cat Makefile.tem >> Makefile.xx
+	mv Makefile.xx Makefile.tem
+	
+	# Conditionalize the makefile for this target machine.
+	if [ -f ${mainsrcdir}/config/${tmake_file} ]
+	then
+		rm -f Makefile.xx
+		sed -e "/####target/  r ${mainsrcdir}/config/${tmake_file}" Makefile.tem > Makefile.xx
+		echo "Merged ${tmake_file}."
+		rm -f Makefile.tem
+		mv Makefile.xx Makefile.tem
+	else
+	# Say in the makefile that there is no tmake_file,
+	# by using a name which (when interpreted relative to $srcdir/config)
+	# will duplicate another dependency: $srcdir/Makefile.in.
+		tmake_file=../Makefile.in
+	fi
+	
+	# CYGNUS LOCAL
+	# Conditionalize the makefile for this site.
+	if [ -f ${mainsrcdir}/config/ms-${site} ]
+	then
+		rm -f Makefile.xx
+		sed -e "/####site/  r ${mainsrcdir}/config/ms-${site}" Makefile.tem > Makefile.xx
+		echo "Merged ms-${site}."
+		rm -f Makefile.tem
+		mv Makefile.xx Makefile.tem
+	fi
+	
+	# CYGNUS LOCAL
+	# If this is a cross compilation, and we have newlib in the build
+	# tree, then define inhibit_libc in LIBGCC2_CFLAGS.  This will cause
+	# __eprintf to be left out of libgcc.a, but that's OK because newlib
+	# has its own version of assert.h.
+	if [ x$host != x$target ]; then
+	  sed -e 's/^\(LIBGCC2_CFLAGS[ 	]*=[ 	]*\)/\1-Dinhibit_libc /' Makefile.tem > Makefile.tem2
+	  rm -f Makefile.tem
+	  mv Makefile.tem2 Makefile.tem
+	fi
+	
+	# Remove all formfeeds, since some Makes get confused by them.
+	# Also arrange to give the variables `target', `host_xmake_file',
+	# `tmake_file', `prefix', `local_prefix', `exec_prefix', `FIXINCLUDES'
+	# and `INSTALL_HEADERS_DIR' values in the Makefile from the values
+	# they have in this script.
+	# CYGNUS LOCAL: FLOAT_H, CROSS_FLOAT_H, objdir
+	rm -f Makefile.xx
+	sed -e "s///" -e "s/^target=.*$/target=${target}/" \
+	    -e "s|^xmake_file=.*$|xmake_file=${host_xmake_file}|" \
+	    -e "s|^tmake_file=.*$|tmake_file=${tmake_file}|" \
+	    -e "s|^version=.*$|version=${version}|" \
+	    -e "s|^prefix[ 	]*=.*|prefix = $prefix|" \
+	    -e "s|^local_prefix[ 	]*=.*|local_prefix = $local_prefix|" \
+	    -e "s|^exec_prefix[ 	]*=.*|exec_prefix = $exec_prefix|" \
+	    -e "s|^objdir[ 	]*=.*|objdir=`pwd`|" \
+	    Makefile.tem > Makefile.xx
+	rm -f Makefile.tem
+	mv Makefile.xx Makefile.tem
+	
+	# Install Makefile for real, after making final changes.
+	# Define macro CROSS_COMPILE in compilation if this is a cross-compiler.
+	# Also use all.cross instead of all.internal, and add cross-make to Makefile.
+	if [ x$canon_host = x$canon_target ]
+	then
+		rm -f Makefile
+	  	if [ x$canon_host = x$canon_build ]
+		then
+			mv Makefile.tem Makefile
+		else
+	#		When building gcc with a cross-compiler, we need to fix a
+	#		few things.
+			echo "build= $build" > Makefile
+			sed -e "/####build/  r ${mainsrcdir}/build-make" Makefile.tem >> Makefile
+			rm -f Makefile.tem Makefile.xx
+		fi
+	else
+		rm -f Makefile
+		echo "CROSS=-DCROSS_COMPILE" > Makefile
+		sed -e "/####cross/  r ${mainsrcdir}/cross-make" Makefile.tem >> Makefile
+		rm -f Makefile.tem Makefile.xx
+	fi
+	
+	echo "Created \`$subdir/Makefile'."
+	
+	if [ xx${vint} != xx ]
+	then
+		vintmsg=" (vint)"
+	fi
+	
+	# Describe the chosen configuration in config.status.
+	# Make that file a shellscript which will reestablish the same configuration.
+
+	rm -f config.bak
+	if [ -f config.status ]; then mv -f config.status config.bak; fi
+
+	echo "#!/bin/sh
+	# This directory was configured as follows:
+cd $invsubdir; ${progname}" $arguments > config.new
+	echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new
+	chmod a+x config.new
+
+	# If we aren't executing the configure script in .
+	if [ x$subdir != x. ]
+	then
+		if [ -f $srcdir/configure ]
+		then
+			echo "Running \`${CONFIG_SHELL-sh} $srcdir/configure $arguments\'"
+			${CONFIG_SHELL-sh} $srcdir/configure $arguments
+			echo "${srcdir}/configure" $arguments >> config.new
+			echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new
+		fi
+	fi
+
+	if [ -f config.bak ] && cmp config.bak config.new >/dev/null 2>/dev/null;
+	then
+		mv -f config.bak config.status
+		rm -f config.new
+	else
+		mv -f config.new config.status
+		rm -f config.bak
+	fi
+
+	cd $STARTDIR
+done   # end of current-dir SUBDIRS loop
+	
+srcdir=$savesrcdir
+
+# Describe the chosen configuration in config.status.
+# Make that file a shellscript which will reestablish the same configuration.
+echo "#!/bin/sh
+# This directory was configured as follows:
+${progname}" $arguments > config.new
+echo echo host=$canon_host target=$canon_target build=$canon_build >> config.new
+chmod a+x config.new
+if [ -f config.bak ] && cmp config.bak config.new >/dev/null 2>/dev/null;
+then
+	mv -f config.bak config.status
+	rm -f config.new
+else
+	mv -f config.new config.status
+	rm -f config.bak
+fi
+
+exit 0

gcc/ch/convert.c

+/* 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;
+}

gcc/ch/lang-specs.h

+/* Definitions for specs for GNU CHILL.
+   Copyright (C) 1995 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 is the contribution to the `default_compilers' array in gcc.c for
+   CHILL.  */
+
+  {".ch",   "@chill" },
+  {".chi",  "@chill" },
+  {"@chill",
+   "cpp -lang-chill %{nostdinc*} %{C} %{v} %{A*} %{I*} %{P} %I\
+	%{C:%{!E:%eGNU CHILL does not support -C without using -E}}\
+        -undef -D__GNUCHILL__=%v1 -D__GNUC_MINOR__=%v2\
+        %c %{Os:-D__OPTIMIZE_SIZE__} %{O*:-D__OPTIMIZE__} %{traditional} %{ftraditional:-traditional}\
+        %{traditional-cpp:-traditional} %{!undef:%{!ansi:%p} %P} %{trigraphs}\
+	%{g*} %{W*} %{w} %{pedantic*} %{H} %{d*} %C %{D*} %{U*} %{i*} %Z\
+        %i %{!E:%g.i}%{E:%W{o*}} \n",
+   "%{!E:cc1chill %g.i %1 \
+		   %{!Q:-quiet} -dumpbase %b.ch %{d*} %{m*} %{a}\
+		   %{g*} %{O*} %{W*} %{w} %{pedantic*} %{itu} \
+		   %{v:-version} %{pg:-p} %{p} %{f*} %{I*} \
+		   %{aux-info*} %X \
+		   %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\
+		   %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\
+              %{!S:as %a %Y \
+		      %{c:%W{o*}%{!o*:-o %w%b%O}}%{!c:-o %d%w%u%O}\
+                      %{!pipe:%g.s} %A\n }}"},

gcc/ch/lang.c

+/* Language-specific hook definitions for CHILL front end.
+   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 "tree.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include <stdio.h>
+#include "input.h"
+
+/* Type node for boolean types.  */
+
+tree boolean_type_node;
+
+/* True if STRING(INDEX) yields a CHARS(1) (or BOOLS(1)) rather than
+   a CHAR (or BOOL).  Also, makes CHARS(1) similar for CHAR,
+   and BOOLS(1) similar to BOOL.  This is for compatibility
+   for the 1984 version of Z.200.*/
+int flag_old_strings = 0;
+
+/* This is set non-zero to force user input tokens to lower case.
+   This is non-standard.  See Z.200, page 8. */
+int ignore_case = 1;
+
+/* True if reserved and predefined words ('special' words in the Z.200
+   terminology) are in uppercase.  Obviously, this had better not be 
+   true if we're ignoring input case. */
+int special_UC = 0;
+
+/* The actual name of the input file, regardless of any #line directives */
+char* chill_real_input_filename;
+extern FILE* finput;
+
+extern int maximum_field_alignment;
+
+extern void error             PROTO((char *, ...));
+extern void error_with_decl   PROTO((tree, char *, ...));
+extern void fatal             PROTO((char *, ...));
+extern int  floor_log2_wide   PROTO((unsigned HOST_WIDE_INT));
+extern void pedwarn_with_decl PROTO((tree, char *, ...));
+extern void sorry             PROTO((char *, ...));
+extern int  type_hash_list    PROTO((tree));
+
+/* return 1 if the expression tree given has all
+   constant nodes as its leaves; return 0 otherwise. */
+int
+deep_const_expr (exp)
+     tree exp;
+{
+  enum chill_tree_code code;
+  int length;
+  int i;
+
+  if (exp == NULL_TREE)
+    return 0;
+
+  code = TREE_CODE (exp);
+  length = tree_code_length[(int) code];
+
+  /* constant leaf?  return TRUE */
+  if (TREE_CODE_CLASS (code) == 'c')
+    return 1;
+
+  /* recursively check next level down */
+  for (i = 0; i < length; i++)
+    if (! deep_const_expr (TREE_OPERAND (exp, i)))
+      return 0;
+  return 1;      
+}
+
+
+tree
+const_expr (exp)
+     tree exp;
+{
+  if (TREE_CODE (exp) == INTEGER_CST)
+    return exp;
+  if (TREE_CODE (exp) == CONST_DECL)
+    return const_expr (DECL_INITIAL (exp));
+  if (TREE_CODE_CLASS (TREE_CODE (exp)) == 'd'
+      && DECL_INITIAL (exp) != NULL_TREE
+      && TREE_READONLY (exp))
+    return DECL_INITIAL (exp);
+  if (deep_const_expr (exp))
+    return exp;
+  if (TREE_CODE (exp) != ERROR_MARK)
+    error ("non-constant expression");
+  return error_mark_node;
+}
+
+/* Each of the functions defined here
+   is an alternative to a function in objc-actions.c.  */
+   
+/* Used by c-lex.c, but only for objc.  */
+tree
+lookup_interface (arg)
+     tree arg;
+{
+  return 0;
+}
+
+int
+maybe_objc_comptypes (lhs, rhs)
+     tree lhs, rhs;
+{
+  return -1;
+}
+
+tree
+maybe_building_objc_message_expr ()
+{
+  return 0;
+}
+
+int
+recognize_objc_keyword ()
+{
+  return 0;
+}
+
+void
+lang_init_options ()
+{
+}
+
+/* used by print-tree.c */
+
+void
+lang_print_xnode (file, node, indent)
+     FILE *file;
+     tree node;
+     int indent;
+{
+}
+
+void
+GNU_xref_begin ()
+{
+  fatal ("GCC does not yet support XREF");
+}
+
+void
+GNU_xref_end ()
+{
+  fatal ("GCC does not yet support XREF");
+}
+
+/*
+ * process chill-specific compiler command-line options
+ */
+int
+lang_decode_option (argc, argv)
+     int argc;
+     char **argv;
+{
+  char *p = argv[0];
+  static explicit_ignore_case = 0;
+  if (!strcmp(p, "-lang-chill"))
+    ; /* do nothing */
+  else if (!strcmp (p, "-fruntime-checking"))
+    {
+      range_checking = 1;
+      empty_checking = 1;
+    }
+  else if (!strcmp (p, "-fno-runtime-checking"))
+    {
+      range_checking = 0;
+      empty_checking = 0;
+      runtime_checking_flag = 0;
+    }
+  else if (!strcmp (p, "-flocal-loop-counter"))
+    flag_local_loop_counter = 1;
+  else if (!strcmp (p, "-fno-local-loop-counter"))
+    flag_local_loop_counter = 0;
+  else if (!strcmp (p, "-fold-strings"))
+    flag_old_strings = 1;
+  else if (!strcmp (p, "-fno-old-strings"))
+    flag_old_strings = 0;
+  else if (!strcmp (p, "-fignore-case"))
+    {
+      explicit_ignore_case = 1;
+      if (special_UC)
+	{
+	  error ("Ignoring case upon input and");
+	  error ("making special words uppercase wouldn't work.");
+	}
+      else
+	ignore_case = 1;
+    }
+  else if (!strcmp (p, "-fno-ignore-case"))
+    ignore_case = 0;
+  else if (!strcmp (p, "-fspecial_UC"))
+    {
+      if (explicit_ignore_case)
+	{
+	  error ("Making special words uppercase and");
+	  error (" ignoring case upon input wouldn't work.");
+	}
+      else
+	special_UC = 1, ignore_case = 0;
+    }
+  else if (!strcmp (p, "-fspecial_LC"))
+    special_UC = 0;
+  else if (!strcmp (p, "-fpack"))
+    maximum_field_alignment = BITS_PER_UNIT;
+  else if (!strcmp (p, "-fno-pack"))
+    maximum_field_alignment = 0;
+  else if (!strcmp (p, "-fchill-grant-only"))
+    grant_only_flag = 1;
+  else if (!strcmp (p, "-fgrant-only"))
+    grant_only_flag = 1;
+  /* user has specified a seize-file path */
+  else if (p[0] == '-' && p[1] == 'I')
+    register_seize_path (&p[2]);
+  if (!strcmp(p, "-itu"))        /* Force Z.200 semantics */
+    {
+      pedantic = 1;   /* FIXME: new flag name? */
+      flag_local_loop_counter = 1;      
+    }
+  else
+    return c_decode_option (argc, argv);
+
+  return 1;
+}
+
+void
+chill_print_error_function (file)
+     char *file;
+{
+  static tree last_error_function = NULL_TREE;
+  static struct module *last_error_module = NULL;
+
+  if (last_error_function == current_function_decl
+      && last_error_module == current_module)
+    return;
+
+  last_error_function = current_function_decl;
+  last_error_module = current_module;
+
+  if (file)
+    fprintf (stderr, "%s: ", file);
+
+  if (current_function_decl == global_function_decl
+      || current_function_decl == NULL_TREE)
+    {
+      if (current_module == NULL)
+	fprintf (stderr, "At top level:\n");
+      else
+	fprintf (stderr, "In module %s:\n",
+		 IDENTIFIER_POINTER (current_module->name));
+    }
+  else
+    {
+      char *kind = "function";
+      char *name = (*decl_printable_name) (current_function_decl, 2);
+      fprintf (stderr, "In %s `%s':\n", kind, name);
+    }
+}
+
+/* Print an error message for invalid use of an incomplete type.
+   VALUE is the expression that was used (or 0 if that isn't known)
+   and TYPE is the type that was invalid.  */
+
+void
+incomplete_type_error (value, type)
+     tree value;
+     tree type;
+{
+  error ("internal error - use of undefined type");
+}
+
+void
+lang_init ()
+{
+  extern void (*print_error_function) PROTO((char*));
+
+  chill_real_input_filename = input_filename;
+
+  /* the beginning of the file is a new line; check for # */
+  /* With luck, we discover the real source file's name from that
+     and put it in input_filename.  */
+
+  ungetc (check_newline (), finput);
+
+  /* set default grant file */
+  set_default_grant_file ();
+
+  print_error_function = chill_print_error_function;
+}

gcc/ch/runtime/allmem.c

+/* Implement runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include <stdlib.h>
+#include "config.h"
+#include "rtltypes.h"
+
+extern void __cause_ex1 (char *exname, char *file, int lineno);
+
+/* define needed exceptions */
+EXCEPTION (protectionfail);
+EXCEPTION (rangefail);
+EXCEPTION (spacefail);
+
+/*
+ * function _allocate_memory
+ *
+ * parameters:
+ *  ptr			pointer to location where pointer should be written
+ *  size		number of bytes to allocate
+ *  filename            source file which issued the call
+ *  linenumber          line number within that source file
+ *
+ * returns:
+ *  void
+ *
+ * exceptions:
+ *  spacefail
+ *  protectionfail
+ *  rangefail
+ *
+ * abstract:
+ *  allocate memory from heap
+ *
+*/
+
+void
+_allocate_memory (ptr, size, filename, linenumber)
+     void **ptr;
+     int size;
+     char *filename;
+     int   linenumber;
+{
+  void	*tmp;
+    
+  if (!ptr)
+    __cause_ex1 ("protectionfail", filename, linenumber);
+  if (size < 0)
+    __cause_ex1 ("rangefail", filename, linenumber);
+  tmp = malloc (size);
+  if (!tmp)
+    __cause_ex1 ("spacefail", filename, linenumber);
+  *ptr = tmp;
+}

gcc/ch/runtime/andps.c

+/* Implement POWERSET runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __andpowerset
+ *
+ * parameters:
+ *	out		return from __andpowerset
+ *	left		left powerset
+ *	right		right powerset
+ *	bitlength	length of powerset in bits
+ *
+ * returns:
+ *	void
+ *
+ * exceptions:
+ *  none
+ *
+ * abstract:
+ *  and's two powersets
+ *
+ */
+
+void
+__andpowerset (out, left, right, bitlength)
+     SET_WORD      *out;
+     SET_WORD      *left;
+     SET_WORD      *right;
+     unsigned long  bitlength;
+{
+  if (bitlength <= SET_CHAR_SIZE)
+    {
+      *((SET_CHAR *)out) = *((SET_CHAR *)left) &
+                           *((SET_CHAR *)right);
+      MASK_UNUSED_CHAR_BITS((SET_CHAR *)out, bitlength);
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      *((SET_SHORT *)out) = *((SET_SHORT *)left) &
+                            *((SET_SHORT *)right);
+      MASK_UNUSED_SHORT_BITS((SET_SHORT *)out, bitlength);
+    }
+  else
+    {
+      unsigned long len = BITS_TO_WORDS (bitlength);
+      register unsigned long i;
+    
+      for (i = 0; i < len; i++)
+	out[i] = left[i] & right[i];
+      MASK_UNUSED_WORD_BITS ((out + len - 1), 
+			     bitlength % SET_WORD_SIZE);
+    }
+}

gcc/ch/runtime/auxtypes.h

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#ifndef _auxtypes_h_
+#define _auxtypes_h_
+
+
+typedef enum { False, True } Boolean;
+
+#define VARYING_STRING(strlen) \
+  struct { unsigned short len; char body[strlen]; }
+
+typedef struct {
+  unsigned short len;
+  char           body[1];
+} VarString; 
+
+/* Macros for moving an (U)INT and (U)LONG without alignment worries */
+#define MOV2(tgt,src) \
+  *((char*)(tgt)  ) = *((char*)(src)  ), \
+  *((char*)(tgt)+1) = *((char*)(src)+1)
+#define MOV4(tgt,src) \
+  *((char*)(tgt)  ) = *((char*)(src)  ), \
+  *((char*)(tgt)+1) = *((char*)(src)+1), \
+  *((char*)(tgt)+2) = *((char*)(src)+2), \
+  *((char*)(tgt)+3) = *((char*)(src)+3)
+
+#endif

gcc/ch/runtime/basicio.c

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+   
+   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 <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <errno.h>
+
+#include <string.h>
+#include <stdlib.h>
+
+#include "fileio.h"
+
+#ifndef PATH_MAX
+#define PATH_MAX _POSIX_PATH_MAX
+#endif
+
+static
+void
+GetSetAttributes( Association_Mode* the_assoc )
+{
+  struct stat statbuf;
+  int retco;
+
+  if( (retco = stat( the_assoc->pathname, &statbuf )) )
+    return;
+
+  if( S_ISREG(statbuf.st_mode) )
+    {
+      SET_FLAG( the_assoc, IO_EXISTING );
+      if( !TEST_FLAG( the_assoc, IO_VARIABLE ) )
+        SET_FLAG( the_assoc, IO_INDEXABLE );
+    }
+  else
+    if( S_ISCHR(statbuf.st_mode) || S_ISFIFO(statbuf.st_mode) )
+      {
+	SET_FLAG( the_assoc, IO_EXISTING );
+	CLR_FLAG( the_assoc, IO_INDEXABLE );
+      }
+  SET_FLAG( the_assoc, IO_SEQUENCIBLE );
+
+  /* FIXME: File size and computation of number of records for outoffile ? */
+
+  if( !access( the_assoc->pathname, R_OK ) )
+    SET_FLAG( the_assoc, IO_READABLE );
+  if( !access( the_assoc->pathname, W_OK ) )
+    SET_FLAG( the_assoc, IO_WRITEABLE );
+}
+
+static
+void 
+makeName( Association_Mode* the_assoc, char* the_path, int the_path_len,
+	 char* file, int line)
+{
+  int namlen;
+  if( ! the_assoc->pathname && 
+      ! (the_assoc->pathname = (char*)malloc( PATH_MAX )) )
+    CHILLEXCEPTION( file, line, SPACEFAIL, PATHNAME_ALLOC );
+
+  if( the_path[0] != DIRSEP )
+    {
+      if( !getcwd( the_assoc->pathname, PATH_MAX ) )
+	{
+	  the_assoc->syserrno = errno;
+	  CHILLEXCEPTION( file, line, ASSOCIATEFAIL, GETCWD_FAILS );
+	}
+      namlen = strlen( the_assoc->pathname );
+      the_assoc->pathname[namlen++] = DIRSEP;  
+    }
+  else
+    namlen = 0;
+
+  strncpy( the_assoc->pathname + namlen, the_path, the_path_len );
+  the_assoc->pathname[namlen+the_path_len] = '\0';
+}
+
+/*
+ * ASSOCIATE
+ */
+/* Caution: returns an Association mode location (!) */
+Association_Mode*
+__associate( Association_Mode* the_assoc,
+	     char*             the_path,
+	     int               the_path_len,
+	     char*             the_mode,
+	     int               the_mode_len,
+	     char*             file,
+	     int               line )
+{
+  if( !the_assoc )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+  if( TEST_FLAG(the_assoc, IO_ISASSOCIATED) )
+    CHILLEXCEPTION( file, line, ASSOCIATEFAIL, IS_ASSOCIATED );
+
+  /* clear all flags */
+  the_assoc->flags = 0;
+
+  if( ! the_path_len )
+    CHILLEXCEPTION( file, line, ASSOCIATEFAIL, NO_PATH_NAME );
+
+  makeName( the_assoc, the_path, the_path_len, file, line );
+  GetSetAttributes( the_assoc );
+
+  CLR_FLAG( the_assoc, IO_VARIABLE );
+  if ( the_mode )
+    {
+      if( !strncmp( the_mode, "VARIABLE", 8 ) )
+	{
+	  SET_FLAG( the_assoc, IO_VARIABLE );
+	  CLR_FLAG( the_assoc, IO_INDEXABLE );
+	}
+      else
+	if( strlen( the_mode ) )
+	  CHILLEXCEPTION( file, line, ASSOCIATEFAIL, INVALID_ASSOCIATION_MODE );
+    }
+
+  SET_FLAG( the_assoc, IO_ISASSOCIATED );
+  return the_assoc;
+}
+
+/*
+ *  DISSOCIATE
+ */
+void
+__dissociate( Association_Mode* the_assoc, char* file, int line )
+{
+  if( !the_assoc )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+  if( !TEST_FLAG( the_assoc, IO_ISASSOCIATED ) )
+    CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+  if( the_assoc->access )
+    __disconnect( the_assoc->access, file, line );
+
+  the_assoc->access = NULL;
+  CLR_FLAG( the_assoc, IO_ISASSOCIATED );
+
+  /* free allocated memory */
+  if (the_assoc->pathname)
+    {
+      free (the_assoc->pathname);
+      the_assoc->pathname = 0;
+    }
+  if (the_assoc->bufptr)
+    {
+      free (the_assoc->bufptr);
+      the_assoc->bufptr = 0;
+    }
+}
+
+/*
+ * CREATE
+ */
+void __create( Association_Mode* the_assoc, char* file, int line )
+{
+  if( !the_assoc )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+  if( !TEST_FLAG( the_assoc, IO_ISASSOCIATED ) )
+    CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+  if( TEST_FLAG( the_assoc, IO_EXISTING ) )
+    CHILLEXCEPTION( file, line, CREATEFAIL, FILE_EXISTING );
+
+  if( (the_assoc->handle = open( the_assoc->pathname, O_CREAT+O_TRUNC+O_WRONLY, 0666 ))
+      == -1 )
+      CHILLEXCEPTION( file, line, CREATEFAIL, CREATE_FAILS );
+
+  the_assoc->usage = ReadWrite;
+  GetSetAttributes( the_assoc );
+
+  close( the_assoc->handle );
+}
+
+/*
+ * MODIFY
+ */
+void
+__modify( Association_Mode* the_assoc,
+	  char*             the_path,
+	  int               the_path_len,
+	  char*             the_mode,
+	  int               the_mode_len,
+	  char*             file,
+	  int               line )
+{
+  if( !the_assoc )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+  if( !TEST_FLAG( the_assoc, IO_ISASSOCIATED ) )
+    CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+  if( the_path_len )
+    {
+      char* oldname;
+
+      if( ! (oldname = (char*)malloc( PATH_MAX )) )
+	CHILLEXCEPTION( file, line, SPACEFAIL, PATHNAME_ALLOC );
+      strcpy( oldname, the_assoc->pathname );
+
+      makeName( the_assoc, the_path, the_path_len, file, line );
+
+      if( rename( oldname, the_assoc->pathname ) )
+	{
+	  free( oldname );
+	  CHILLEXCEPTION( file, line, MODIFYFAIL, RENAME_FAILS );
+	}
+      free( oldname );
+    }
+  else
+    {
+      /* FIXME: other options? */
+    }
+}
+
+static
+/*** char* DirMode[] = { "rb", "r+b", "r+b" }; ***/
+int DirMode[] = { O_RDONLY, O_RDWR, O_RDWR };
+
+static
+/*** char* SeqMode [] = { "rb", "r+b", "r+b" }; ***/
+int SeqMode[] = { O_RDONLY, O_RDWR, O_RDWR };
+
+/*
+ * CONNECT
+ */
+void
+__connect( void*             the_transfer,
+	   Association_Mode* the_assoc,
+	   Usage_Mode        the_usage,
+	   Where_Mode        the_where,
+	   Boolean           with_index,
+	   signed long       the_index,
+	   char*             file,
+	   int               line )
+{
+  Access_Mode*  the_access;
+  off_t         filepos;
+  off_t         savepos;
+  char          dummy;
+  unsigned long nbytes;
+  int           oflag;
+
+  if( !the_transfer )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+  if( !the_assoc )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ASSOCIATION );
+
+  if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+    {
+      if( ! ((Text_Mode*)the_transfer)->access_sub )
+	CHILLEXCEPTION( file, line, EMPTY, NO_ACCESS_SUBLOCATION );
+      the_access = ((Text_Mode*)the_transfer)->access_sub;
+      SET_FLAG( the_access, IO_TEXTIO );
+    }
+  else
+    {
+      the_access = (Access_Mode*)the_transfer;
+      CLR_FLAG( the_access, IO_TEXTIO );
+    }
+
+  /* FIXME: This should be an (implementation-dependent) static check
+     if( with_index && the_access->rectype > Fixed )
+     CHILLEXCEPTION( file, line, CONNECTFAIL, IMPL_RESTRICTION );
+     */
+
+  if( ! TEST_FLAG(the_assoc, IO_ISASSOCIATED) )
+    CHILLEXCEPTION( file, line, NOTASSOCIATED, IS_NOT_ASSOCIATED );
+
+  if( ! TEST_FLAG( the_assoc, IO_EXISTING ) )
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_EXISTING );
+
+  if( ! TEST_FLAG( the_assoc, IO_READABLE ) &&
+      ( the_usage = ReadOnly || the_usage == ReadWrite ) )    
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_READABLE );
+
+  if( ! TEST_FLAG( the_assoc, IO_WRITEABLE ) &&
+      ( the_usage = WriteOnly || the_usage == ReadWrite ) )    
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_WRITEABLE );
+
+  if( ! TEST_FLAG( the_assoc, IO_INDEXABLE ) 
+      && TEST_FLAG( the_access, IO_INDEXED ) )
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_INDEXABLE );
+
+  if( ! TEST_FLAG( the_assoc, IO_SEQUENCIBLE ) 
+      && ! TEST_FLAG( the_access, IO_INDEXED ) )
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_SEQUENCIBLE );
+
+  if( the_where == Same && the_assoc->access == NULL )
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NO_CURRENT_POS );
+
+  /* This dynamic condition is not checked for text connections. */
+  if( ! TEST_FLAG( the_access, IO_TEXTIO ) )
+    if( ! TEST_FLAG( the_assoc, IO_VARIABLE ) 
+	&& the_access->rectype > Fixed 
+	&& ( the_usage == WriteOnly || the_usage == ReadWrite ) )
+      CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_VARIABLE );
+ 
+  if( TEST_FLAG( the_assoc, IO_VARIABLE )
+      && the_access->rectype == Fixed 
+      && ( the_usage == ReadOnly || the_usage == ReadWrite ) )
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_FIXED );
+ 
+  if( ! TEST_FLAG( the_access, IO_INDEXED ) && the_usage == ReadWrite )
+    CHILLEXCEPTION( file, line, CONNECTFAIL, NOT_INDEXED );
+
+  /* Access location may be connected to a different association. */
+  if( the_access->association && the_access->association != the_assoc )
+    __disconnect( the_access, file, line );
+
+  /* Is the association location already connected? */
+  if( the_assoc->access )
+    {
+      /* save position just in case we need it for the_where == Same */
+      if( (savepos = lseek( the_assoc->handle, 0L, SEEK_CUR )) == -1L )
+	CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+
+      /* text: read correction, flush buffer */
+      if( the_assoc->bufptr ){
+	savepos -= the_assoc->bufptr->len - the_assoc->bufptr->cur;
+	the_assoc->bufptr->len = the_assoc->bufptr->cur = 0;
+      }
+
+      /* implicit disconnect */
+      __disconnect( the_assoc->access, file, line );
+    }
+
+  the_assoc->usage = the_usage;
+  CLR_FLAG( the_access, IO_OUTOFFILE );
+ 
+  if( TEST_FLAG( the_access, IO_INDEXED ) )
+    {
+      if( (the_assoc->handle = open( the_assoc->pathname, DirMode[the_usage] )) == -1 )
+	CHILLEXCEPTION( file, line, CONNECTFAIL, OPEN_FAILS );
+
+      /* Set base index. */
+      switch( the_where )
+	{
+	case First: 
+	  filepos = 0;
+	  break;
+	case Same: 
+	  filepos = savepos;
+	  break;
+	case Last: 
+	  if( lseek( the_assoc->handle, 0L, SEEK_END ) == -1L )
+	    CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+	  filepos = lseek( the_assoc->handle, 0L, SEEK_CUR );
+	  break;
+	}
+
+      /* Set current index */
+      if( with_index )
+	{
+	  if( the_index < the_access->lowindex
+	      || the_access->highindex < the_index )
+	    CHILLEXCEPTION( file, line, RANGEFAIL, BAD_INDEX );
+	  filepos += (the_index - the_access->lowindex) * the_access->reclength;
+	}
+      if( lseek( the_assoc->handle, filepos, SEEK_SET ) == -1L )
+	CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+      the_access->base = filepos;
+    }
+  else
+    {
+      /* for association to text for reading: allocate buffer */
+      if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ) &&
+	  the_usage == ReadOnly &&
+	  !the_assoc->bufptr )
+	{
+	  if( ! (the_assoc->bufptr = (readbuf_t*)malloc( sizeof(readbuf_t) )) )
+	    CHILLEXCEPTION( file, line, CONNECTFAIL, BUFFER_ALLOC ); 
+	  memset (the_assoc->bufptr, 0, sizeof (readbuf_t));
+	}
+      if( (the_assoc->handle = open( the_assoc->pathname, SeqMode[the_usage] )) == -1 )
+	CHILLEXCEPTION( file, line, CONNECTFAIL, OPEN_FAILS );
+
+      /* Set base index. */
+      switch( the_where )
+	{
+	case First: 
+	  filepos = 0;
+	  break;
+	case Same: 
+	  filepos = savepos;
+	  break;
+	case Last:
+	  if( lseek( the_assoc->handle, 0L, SEEK_END ) == -1L )
+	    CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+	  filepos = lseek( the_assoc->handle, 0L, SEEK_CUR );
+	  break;
+	}
+
+      /* file truncation for sequential, Write Only */
+      /***************************** FIXME: cannot truncate at Same
+	if( the_usage == WriteOnly )
+	{
+	if( fseek( the_assoc->file_ptr, filepos, SEEK_SET ) == -1L )
+        CHILLEXCEPTION( file, line, CONNECTFAIL, FSEEK_FAILS );
+	fclose( the_assoc->file_ptr );
+	if( !(the_assoc->file_ptr = fopen( the_assoc->pathname, "ab" )) )
+        CHILLEXCEPTION( file, line, CONNECTFAIL, OPEN_FAILS );
+	}
+	else
+	***************************/
+      if( (filepos = lseek( the_assoc->handle, filepos, SEEK_SET )) == -1L )
+	CHILLEXCEPTION( file, line, CONNECTFAIL, LSEEK_FAILS );
+    }
+
+  the_access->association = the_assoc;
+  the_assoc->access = the_access;
+  /* for text: set carriage control default */
+  if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ) ){
+    the_assoc->ctl_pre  = '\0';
+    the_assoc->ctl_post = '\n';
+  }
+}
+
+void
+__disconnect( void* the_transfer, char* file, int line )
+{
+  Access_Mode* the_access;
+
+  if( !the_transfer )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+  if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+    {
+      the_access = ((Text_Mode*)the_transfer)->access_sub;
+      CLR_FLAG( the_access, IO_TEXTIO );
+    }
+  else
+    the_access = (Access_Mode*)the_transfer;
+
+  if( !the_access->association )
+    CHILLEXCEPTION( file, line, NOTCONNECTED, IS_NOT_CONNECTED );
+
+  close( the_access->association->handle );
+  /* FIXME: check result */
+
+  if( the_access->store_loc )
+    free( the_access->store_loc );
+  the_access->store_loc           = NULL;
+  the_access->association->access = NULL;
+  the_access->association         = NULL;
+}

gcc/ch/runtime/bitstring.h

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#ifndef _bitstring_h_
+#define _bitstring_h_
+
+int __inpowerset( int i, char* string, int strlen, int dummy );
+void __setbitpowerset (char *powerset, unsigned long bitlength,
+		       long minval, long bitno, char newval,
+		       char *filename, int lineno);
+		       
+#endif

gcc/ch/runtime/cause.c

+/* Implement runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+
+/*
+ * function cause_exception
+ *
+ * parameters:
+ *  exname		exception name
+ *  file		file name
+ *  lineno		line number
+ *   user_arg		user specified argument
+ *
+ * returns:
+ *  void
+ *
+ * abstract:
+ *  dummy for ChillLib but may be overwritten by the user
+ *
+ */
+void
+cause_exception (exname, file, lineno, user_arg)
+     char *exname;
+     char *file;
+     int lineno;
+     int user_arg;
+{
+}

gcc/ch/runtime/concatps.c

+/* Implement powerset-related runtime actions for CHILL.
+   Copyright (C) 1992, 93, 1994 Free Software Foundation, Inc.
+   Author: Bill Cox
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "powerset.h"
+
+extern void cause_exception (char *exname, char *file, int lineno);
+
+/*
+ * function __concatps
+ *
+ * parameters:
+ *     OUT      - pointer to output PS
+ *     LEFT     - pointer to left PS
+ *     LEFTLEN  - length of left PS in bits
+ *     RIGHT    - pointer to right PS
+ *     RIGHTLEN - length of right PS in bits
+ *
+ * returns:
+ *     void
+ *
+ * exceptions:
+ *     none
+ *
+ * abstract:
+ *     concatenates two powersets into the output powerset.
+ *
+ */
+
+extern void
+__pscpy (SET_WORD      *dps,
+	 unsigned long  dbl,
+	 unsigned long  doffset,
+	 SET_WORD      *sps,
+	 unsigned long  sbl,
+	 unsigned long  start,
+	 unsigned long  length);
+
+void
+__concatps (out, left, leftlen, right, rightlen)
+     SET_WORD      *out;
+     SET_WORD      *left;
+     unsigned long  leftlen;
+     SET_WORD      *right;
+     unsigned long  rightlen;
+{
+  /* allocated sizes for each set involved */
+  unsigned long outall, leftall, rightall;
+
+  if (!out)
+    {
+      /* FIXME: cause an exception */
+    }
+  else if (leftlen == 0 || !left)
+    {
+      if (rightlen == 0 || !right)
+	return;               /* no work to do */
+      __pscpy (out, rightlen, (unsigned long)0,
+	       right, rightlen, (unsigned long)0, rightlen);
+    }
+  else if (rightlen == 0 || !right)
+    {
+      if (leftlen == 0 || !left)
+	return;               /* no work to do */
+      __pscpy (out, leftlen, (unsigned long)0,
+	       left, leftlen, (unsigned long)0, leftlen);
+    }
+  /* copy the left powerset into bits 0..leftlen - 1 */
+  __pscpy (out, leftlen + rightlen, (unsigned long)0,
+	   left, leftlen, (unsigned long)0, leftlen);
+
+  /* copy the right powerset into bits leftlen..leftlen+rightlen-1 */
+  __pscpy (out, leftlen + rightlen, leftlen,
+	   right, rightlen, (unsigned long)0, rightlen);
+}

gcc/ch/runtime/copyps.c

+/* Implement POWERSET runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __powerset_copy
+ *    This is more general than __psslice, since it
+ *    can be told where in the destination powerset (DOFFSET
+ *    parameter) to start storing the slice.
+ *
+ * parameters:
+ *      dps             dest powerset
+ *      dbl             destination bit length
+ *      doffset         offset bit number (zero origin)
+ *	sps		sourcepowerset
+ *	sbl     	source powerset length in bits
+ *      start           starting bit number
+ *      end             ending bit number
+ *
+ * exceptions:
+ *  none
+ *
+ * abstract:
+ *  Extract into a powerset a slice of another powerset.
+ *
+ */
+void
+__pscpy (dps, dbl, doffset, sps, sbl, start, length)
+     SET_WORD      *dps;
+     unsigned long  dbl;
+     unsigned long  doffset;
+     const SET_WORD*sps;
+     unsigned long  sbl;
+     unsigned long  start;
+     unsigned long  length;
+{
+  unsigned long end = start + length - 1;
+  unsigned long src, dst;
+
+  /* assert end >= start;
+     assert end - start + 1 <= dbl;
+     assert "the sets don't overlap in memory" */
+
+  /* assert doffset >= 0 and < dbl */
+
+  for (src = start, dst = doffset; src <= end; src++, dst++)
+    {
+      char tmp;
+
+      if (sbl <= SET_CHAR_SIZE)                /* fetch a bit */
+	tmp = GET_BIT_IN_CHAR (*((SET_CHAR *)sps), src);
+      else if (sbl <= SET_SHORT_SIZE)
+	tmp = GET_BIT_IN_SHORT (*((SET_SHORT *)sps), src);
+      else
+	tmp = GET_BIT_IN_WORD (sps[src / SET_WORD_SIZE], src % SET_WORD_SIZE);
+
+      if (tmp & 1)
+	{
+	  if (dbl <= SET_CHAR_SIZE)            /* store a 1-bit */
+	    SET_BIT_IN_CHAR (*((SET_CHAR *)dps), dst);
+	  else if (dbl <= SET_SHORT_SIZE)
+	    SET_BIT_IN_SHORT (*((SET_SHORT *)dps), dst);
+	  else
+	    SET_BIT_IN_WORD (dps[dst / SET_WORD_SIZE], dst % SET_WORD_SIZE);
+	}
+      else
+	{
+	  if (dbl <= SET_CHAR_SIZE)            /* store a 0-bit */
+	    CLEAR_BIT_IN_CHAR (*((SET_CHAR *)dps), dst);
+	  else if (dbl <= SET_SHORT_SIZE)
+	    CLEAR_BIT_IN_SHORT (*((SET_SHORT *)dps), dst);
+	  else
+	    CLEAR_BIT_IN_WORD (dps[dst / SET_WORD_SIZE], dst % SET_WORD_SIZE);
+	}
+    }
+  if (dbl <= SET_CHAR_SIZE)         /* clear unused bits in output bitstring */
+    {
+      MASK_UNUSED_CHAR_BITS ((SET_CHAR *)dps, dbl);
+    }
+  else if (dbl <= SET_SHORT_SIZE)
+    {
+      MASK_UNUSED_SHORT_BITS ((SET_SHORT *)dps, dbl);
+    }
+  else
+    {
+      MASK_UNUSED_WORD_BITS ((SET_WORD *)(dps + (dbl/SET_WORD_SIZE)), 
+			     dbl % SET_WORD_SIZE);
+    }
+}

gcc/ch/runtime/eqps.c

+/* Implement POWERSET runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __eqpowerset
+ *
+ * parameters:
+ *	left		left powerset
+ *	right		right powerset
+ *	bitlength	length of powerset in bits
+ *
+ * returns:
+ *    1 if powersets are equal, bit for bit
+ *
+ * exceptions:
+ *  none
+ *
+ * abstract:
+ *  compares two powersets for equality
+ *
+ */
+int
+__eqpowerset (left, right, bitlength)
+     SET_WORD *left;
+     SET_WORD *right;
+     unsigned long bitlength;
+{
+#ifndef USE_CHARS
+  if (bitlength <= SET_CHAR_SIZE)
+    {
+      SET_CHAR c = *(SET_CHAR *)left ^ *(SET_CHAR *)right;
+      MASK_UNUSED_CHAR_BITS (&c, bitlength);
+      return (c == 0) ? 1 : 0;
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      SET_SHORT c = *(SET_SHORT *)left ^ *(SET_SHORT *)right;
+      MASK_UNUSED_SHORT_BITS (&c, bitlength);
+      return (c == 0) ? 1 : 0;
+    }
+  else if (bitlength <= SET_WORD_SIZE)
+    {
+      SET_WORD c = *(SET_WORD *)left ^ *(SET_WORD *)right;
+      MASK_UNUSED_WORD_BITS (&c, bitlength % SET_WORD_SIZE);
+      return (c == 0) ? 1 : 0;
+    }
+  else
+#endif
+    {
+      SET_WORD c;
+      register unsigned long i;
+      unsigned long len = bitlength / SET_WORD_SIZE;
+
+      for (i = 0; i < len; i++) /* a word-oriented memcmp */
+	if (left[i] != right[i])
+	  return 0;
+      /* do the last (possibly partial) word */
+      bitlength %= SET_WORD_SIZE;
+      if (bitlength == 0)
+	return 1;
+      c = left[i] ^ right[i];
+      MASK_UNUSED_WORD_BITS (&c, bitlength);
+      return (c == 0) ? 1 : 0;
+    }
+}

gcc/ch/runtime/fileio.h

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#ifndef _fileio_h_
+#define _fileio_h_
+
+#include <stdio.h>
+
+#include "auxtypes.h"
+#include "ioerror.h"
+#include "iomodes.h"
+
+#define DIRSEP '/'
+
+#define TEST_FLAG(Xloc,Flag) (((Xloc)->flags) & (Flag))
+#define SET_FLAG(Xloc,Flag)  (Xloc)->flags |= (Flag)
+#define CLR_FLAG(Xloc,Flag)  (Xloc)->flags = ((Xloc)->flags & ~(Flag))
+
+Boolean
+__isassociated( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__existing( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__readable( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__writeable( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__indexable( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__sequencible( Association_Mode* the_assoc, char* file, int line );
+
+Boolean
+__variable( Association_Mode* the_assoc, char* file, int line );
+
+typedef signed long int Index_t;
+
+Association_Mode*
+__associate( Association_Mode* the_assoc,
+             char*             the_path,
+             int               the_path_len,
+             char*             the_mode,
+             int               the_mode_len,
+             char*             file,
+             int               line );
+
+void
+__dissociate( Association_Mode* the_assoc, char* file, int line );
+
+void
+__create( Association_Mode* the_assoc, char* file, int line );
+
+void
+__delete( Association_Mode* the_assoc, char* file, int line );
+
+void
+__modify( Association_Mode* the_assoc,
+          char*             the_path,
+          int               the_path_len,
+          char*             the_mode,
+          int               the_mode_len,
+          char*             file,
+          int               line );
+
+void
+__connect( void*             the_transfer, 
+           Association_Mode* the_assoc,
+           Usage_Mode        the_usage,
+           Where_Mode        the_where,
+           Boolean           with_index,
+           signed long       the_index,
+           char*             file,
+           int               line );
+
+void
+__disconnect( void* the_transfer, char* file, int line );
+
+Association_Mode*
+__getassociation( void* the_transfer, char* file, int line );
+
+Usage_Mode
+__getusage( void* the_transfer, char* file, int line );
+
+Boolean
+__outoffile( void* the_transfer, char* file, int line );
+
+void*
+__readrecord( Access_Mode*  the_access,
+              signed long   the_index,
+              char*         the_buf_addr,
+              char*         file,
+              int           line );
+
+void
+__writerecord( Access_Mode*  the_access,
+               signed long   the_index,
+               char*         the_val_addr,
+               unsigned long the_val_len,
+               char*         file,
+               int           line );
+
+VarString*
+__gettextrecord( Text_Mode* the_text, char* file, int line );
+
+unsigned long
+__gettextindex( Text_Mode* the_text, char* file, int line );
+
+Access_Mode*
+__gettextaccess( Text_Mode* the_text, char* file, int line );
+
+Boolean
+__eoln( Text_Mode* the_text, char* file, int line );
+
+void
+__settextrecord( Text_Mode* the_text,
+                 VarString* the_text_rec,
+                 char*      file,
+                 int        line );
+
+void
+__settextindex( Text_Mode*  the_text,
+                signed long the_text_index, 
+                char*       file,
+                int         line );
+
+void
+__settextaccess( Text_Mode*   the_text,
+                 Access_Mode* the_access,
+                 char*        file,
+                 int          line );
+
+#endif

gcc/ch/runtime/flsetps.c

+/* Implement POWERSET runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+extern void __cause_ex1 (char *exname, char *file, int lineno);
+
+/*
+ * function __flsetpowerset
+ *
+ * parameters:
+ *	ps		powerset
+ *	bitlength	length of powerset
+ *      minval          set low bound
+ *      filename        caller's file name
+ *      lineno          caller's line number
+ *
+ * returns:
+ *	int		largest enumeration value
+ * exceptions:
+ *      "empty"         if set is empty
+ *
+ * abstract:
+ *  Find last bit set in a powerset and return the corresponding value.
+ *
+ */
+long
+__flsetpowerset (ps, bitlength, minval, filename, lineno)
+     SET_WORD      *ps;
+     unsigned long  bitlength;
+     long           minval;
+     char          *filename;
+     int            lineno;
+{
+  unsigned long bitno;
+
+  if (bitlength <= SET_CHAR_SIZE)
+    {
+      SET_CHAR cset = *((SET_CHAR *)ps);
+      if (cset != 0)
+	{
+	  /* found a bit set .. calculate which */
+	  for (bitno = SET_CHAR_SIZE; bitno >= 1; bitno--)
+	    if (GET_BIT_IN_CHAR (cset, bitno - 1))
+	      break;
+	  /* return its index */
+	  return bitno + minval - 1;
+	}
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      SET_SHORT sset = *((SET_SHORT *)ps);
+      if (sset != 0)
+	{
+	  /* found a bit set .. calculate which */
+	  for (bitno = SET_SHORT_SIZE; bitno >= 1; bitno--)
+	    if (GET_BIT_IN_SHORT (sset, bitno - 1))
+	      break;
+	  /* return its index */
+	  return bitno + minval - 1;
+	}
+    }
+  else /* set composed of array of one or more WORDs */
+    {
+      SET_WORD	*endp = ps;
+      SET_WORD	*p = ps + BITS_TO_WORDS(bitlength) - 1;
+      unsigned long cnt;
+      
+      /* FIXME: bitorder problems? */
+      for (cnt = ((bitlength - 1) / SET_WORD_SIZE) * SET_WORD_SIZE;
+	   p >= endp; p--, cnt -= SET_WORD_SIZE)
+	{
+	  SET_WORD c = *p;
+	  if (c)
+	    {
+	      /* found a bit set .. calculate which */
+	      for (bitno = SET_WORD_SIZE; bitno >= 1; bitno--)
+		if (GET_BIT_IN_WORD (c, bitno - 1))
+		  break;
+	      return cnt + bitno + minval - 1;
+	    }
+	}
+    }
+  /* no bits found - raise exception */
+  __cause_ex1 ("empty", filename, lineno);
+}

gcc/ch/runtime/format.h

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#ifndef _format_h_
+#define _format_h_
+
+#include "iomodes.h"
+#include "fileio.h"
+
+extern Text_Mode __stdin_text;
+extern Text_Mode __stdout_text;
+extern Text_Mode __stderr_text;
+
+void
+__readtext_f( Text_Mode*      TextLoc,
+              signed long     Index,
+              char*           fmtptr,
+              int             fmtlen,
+              __tmp_IO_list*  ioptr,
+              int             iolen,
+              char*           file,
+              int             line );
+
+void
+__readtext_s( void*           string_ptr,
+              int             string_len,
+              char*           fmtptr,
+              int             fmtlen,
+              __tmp_IO_list*  ioptr,
+              int             iolen,
+              char*           file,
+              int             line );
+
+void
+__writetext_f( Text_Mode*      Text_Loc,
+               signed long     Index,
+               char*           fmtptr,
+               int             fmtlen,
+               __tmp_IO_list*  ioptr,
+               int             iolen,
+               char*           file,
+               int             line );
+
+void
+__writetext_s( void*           string_ptr,
+               int             string_len,
+               char*           fmtptr,
+               int             fmtlen,
+               __tmp_IO_list*  ioptr,
+               int             iolen,
+               char*           file,
+               int             line );
+
+#endif _format_h_

gcc/ch/runtime/getassoc.c

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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 "fileio.h"
+
+Association_Mode*
+__getassociation( void* the_transfer, char* file, int line )
+{
+  Access_Mode* the_access;
+
+  if( !the_transfer )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+  if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+    the_access = ((Text_Mode*)the_transfer)->access_sub;
+  else
+    the_access = (Access_Mode*)the_transfer;
+
+  return the_access->association;
+}

gcc/ch/runtime/gettextaccess.c

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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 "fileio.h"
+
+Access_Mode*
+__gettextaccess( Text_Mode* the_text, char* file, int line )
+{
+  if( !the_text )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_TEXT );
+
+  return the_text->access_sub;
+}
+

gcc/ch/runtime/getusage.c

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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 "fileio.h"
+
+Usage_Mode
+__getusage( void* the_transfer, char* file, int line )
+{
+  Access_Mode* the_access;
+
+  if( !the_transfer )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+  if( TEST_FLAG((Text_Mode*)the_transfer, IO_TEXTLOCATION ))
+    the_access = ((Text_Mode*)the_transfer)->access_sub;
+  else
+    the_access = (Access_Mode*)the_transfer;
+
+  if( !the_access->association )
+    CHILLEXCEPTION( file, line, NOTCONNECTED, IS_NOT_CONNECTED );
+  return the_access->association->usage;
+}
+

gcc/ch/runtime/inps.c

+/* Implement POWERSET runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __inpowerset
+ *
+ * parameters:
+ *	bitno		bit number within set
+ *	powerset	the powerset
+ *	bitlength	length of powerset in bits
+ *      minval          number of lowest bit stored
+ *
+ * returns:
+ *	int		1 .. found
+ *			0 .. not found
+ *
+ * exceptions:
+ *  rangefail
+ *
+ * abstract:
+ *  checks if a given value is included in a powerset
+ *
+ */
+int
+__inpowerset (bitno, powerset, bitlength, minval)
+     unsigned long  bitno;
+     SET_WORD      *powerset;
+     unsigned long  bitlength;
+     long           minval;
+{
+  if (bitno < minval || (bitno - minval) >= bitlength)
+    return 0;
+    
+  bitno -= minval;
+  if (bitlength <= SET_CHAR_SIZE)
+    return GET_BIT_IN_CHAR (*((SET_CHAR *)powerset), bitno);
+  else if (bitlength <= SET_SHORT_SIZE)
+    return GET_BIT_IN_SHORT (*((SET_SHORT *)powerset), bitno);
+  else
+    return GET_BIT_IN_WORD (powerset[bitno / SET_WORD_SIZE],
+			    bitno % SET_WORD_SIZE);
+}

gcc/ch/runtime/ioerror.c

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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 <setjmp.h>
+
+/* define names of IO-exceptions */
+
+char * __IO_exception_names[] =
+{
+  "UNUSED",
+  "notassociated",
+  "associatefail",
+  "createfail",
+  "deletefail",
+  "modifyfail",
+  "connectfail",
+  "notconnected",
+  "empty",
+  "rangefail",
+  "spacefail",
+  "readfail",
+  "writefail",
+  "textfail",
+};
+
+jmp_buf __io_exception;
+
+jmp_buf __rw_exception;

gcc/ch/runtime/ioerror.h

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#ifndef _ioerror_h_
+#define _ioerror_h_
+
+#include <setjmp.h>
+
+/* Note: numbers must be in the same order as
+   strings in ioerror.c */
+typedef enum 
+{ NOTASSOCIATED = 1,
+  ASSOCIATEFAIL,
+  CREATEFAIL, 
+  DELETEFAIL,
+  MODIFYFAIL,
+  CONNECTFAIL,
+  NOTCONNECTED,
+  EMPTY,
+  RANGEFAIL,
+  SPACEFAIL,
+  READFAIL,
+  WRITEFAIL,
+  TEXTFAIL
+} io_exceptions_t;
+
+#ifndef FIRST_IO_ERROR_NUMBER
+#define FIRST_IO_ERROR_NUMBER 0
+#endif
+
+typedef enum {
+  FIRST_AND_UNUSED = FIRST_IO_ERROR_NUMBER,
+  INTERNAL_ERROR,
+  INVALID_IO_LIST,
+  REPFAC_OVERFLOW,
+  CLAUSE_WIDTH_OVERFLOW,
+  UNMATCHED_CLOSING_PAREN,
+  UNMATCHED_OPENING_PAREN,
+  BAD_FORMAT_SPEC_CHAR,
+  NO_PAD_CHAR,
+  IO_CONTROL_NOT_VALID,
+  DUPLICATE_QUALIFIER,
+  NO_FRACTION_WIDTH,
+  NO_EXPONENT_WIDTH,
+  FRACTION_WIDTH_OVERFLOW,
+  EXPONENT_WIDTH_OVERFLOW,
+  NO_FRACTION,
+  NO_EXPONENT,
+  NEGATIVE_FIELD_WIDTH,
+  TEXT_LOC_OVERFLOW,
+  IOLIST_EXHAUSTED,
+  CONVCODE_MODE_MISFIT,
+  SET_CONVERSION_ERROR,
+  BOOL_CONVERSION_ERROR,
+  NON_INT_FIELD_WIDTH,
+  EXCESS_IOLIST_ELEMENTS,
+  NOT_ENOUGH_CHARS,
+  NO_CHARS_FOR_INT,
+  NO_CHARS_FOR_FLOAT,
+  NO_EXPONENT_VAL,
+  INT_VAL_OVERFLOW,
+  REAL_OVERFLOW,
+  NO_DIGITS_FOR_INT,
+  NO_DIGITS_FOR_FLOAT,
+  NO_CHARS_FOR_SET,
+  NO_CHARS_FOR_CHAR,
+  NO_CHARS_FOR_BOOLS,
+  NO_CHARS_FOR_CHARS,
+  NO_CHARS_FOR_TEXT,
+  NO_CHARS_FOR_EDIT,
+  NO_SPACE_TO_SKIP,
+  FORMAT_TEXT_MISMATCH,
+  INTEGER_RANGE_ERROR,
+  SET_RANGE_ERROR,
+  CHAR_RANGE_ERROR,
+  INVALID_CHAR,
+/* end of formatting errors */
+  NULL_ASSOCIATION,
+  NULL_ACCESS,
+  NULL_TEXT,
+  IS_NOT_ASSOCIATED,
+  IS_ASSOCIATED,
+  GETCWD_FAILS,
+  INVALID_ASSOCIATION_MODE,
+  FILE_EXISTING,
+  CREATE_FAILS,
+  DELETE_FAILS,
+  RENAME_FAILS,
+  IMPL_RESTRICTION,
+  NOT_EXISTING,
+  NOT_READABLE,
+  NOT_WRITEABLE,
+  NOT_INDEXABLE,
+  NOT_SEQUENCIBLE,
+  NO_CURRENT_POS,
+  NOT_VARIABLE,
+  NOT_FIXED,
+  NOT_INDEXED, 
+  LENGTH_CHANGE,
+  LSEEK_FAILS,
+  BUFFER_ALLOC,
+  OPEN_FAILS,
+  NO_ACCESS_SUBLOCATION, 
+  BAD_INDEX,
+  IS_NOT_CONNECTED,
+  NO_PATH_NAME,
+  PATHNAME_ALLOC,
+  BAD_USAGE,
+  OUT_OF_FILE,
+  NULL_STORE_LOC,
+  STORE_LOC_ALLOC,
+  OS_IO_ERROR,
+  RECORD_TOO_LONG,
+  RECORD_TOO_SHORT,
+  BAD_TEXTINDEX,
+  NULL_TEXTREC
+} io_info_word_t;
+
+
+extern
+char* io_info_text [];
+
+extern
+char* exc_text [];
+ 
+extern 
+jmp_buf __io_exception;
+
+extern 
+jmp_buf __rw_exception;
+
+void __cause_exception (char *ex, char* f, int line, int info);
+extern char * __IO_exception_names[];
+
+#define IOEXCEPTION(EXC,INFO) \
+    longjmp( __io_exception, (EXC<<16) + INFO )
+
+#define RWEXCEPTION(EXC,INFO) \
+    longjmp( __rw_exception, (EXC<<16) + INFO )
+
+#define CHILLEXCEPTION(FILE,LINE,EXC,INFO) \
+    __cause_exception (__IO_exception_names[EXC], FILE, LINE, INFO);
+
+#endif

gcc/ch/runtime/iomodes.h

+/* Implement Input/Output runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#ifndef _iomodes_h_
+#define _iomodes_h_
+
+#include "auxtypes.h"
+
+typedef enum { ReadOnly, WriteOnly, ReadWrite
+} Usage_Mode;
+
+typedef enum { First, Same, Last
+} Where_Mode;
+
+typedef enum { None, Fixed, VaryingChars
+} Record_t;
+
+/* association flags */
+#define IO_ISASSOCIATED 0x00000001
+#define IO_EXISTING     0x00000002
+#define IO_READABLE     0x00000004
+#define IO_WRITEABLE    0x00000008
+#define IO_INDEXABLE    0x00000010
+#define IO_SEQUENCIBLE  0x00000020
+#define IO_VARIABLE     0x00000040
+#define IO_FIRSTLINE    0x00000100
+#define IO_FORCE_PAGE   0x00000200
+
+struct Access_Mode;
+
+#define READBUFLEN 512
+typedef struct
+{
+  unsigned long len;
+  unsigned long cur;
+  char buf[READBUFLEN];
+} readbuf_t;
+
+typedef struct Association_Mode {
+  unsigned long       flags;      /* INIT = 0 */
+  char*               pathname;
+  struct Access_Mode* access;
+  int                 handle;
+  readbuf_t*          bufptr;
+  long                syserrno;
+  char                usage;
+  char                ctl_pre;
+  char                ctl_post;
+} Association_Mode;
+
+/*
+   rectype   indexed   max. reclength    act. reclength
+   ---------------------------------------------------
+   None        T/F        0
+   Fixed       T/F     SIZE(recmode)  =  SIZE(recmode)
+   Varying       F     SIZE(recmode) >=  length
+*/
+
+/* access/text flags */
+#define IO_TEXTLOCATION 0x80000000
+#define IO_INDEXED      0x00000001
+#define IO_TEXTIO       0x00000002
+#define IO_OUTOFFILE    0x00010000
+
+typedef struct Access_Mode {
+  unsigned long     flags;     /* INIT */   
+  unsigned long     reclength; /* INIT */
+  signed long       lowindex;  /* INIT */
+  signed long       highindex; /* INIT */
+  Association_Mode* association;
+  unsigned long     base;
+  char*             store_loc;
+  Record_t          rectype;   /* INIT */
+} Access_Mode;
+
+typedef struct Text_Mode {
+  unsigned long flags;         /* INIT */
+  VarString*    text_record;   /* INIT */
+  Access_Mode*  access_sub;    /* INIT */
+  unsigned long actual_index;
+} Text_Mode;
+
+typedef enum
+{
+    __IO_UNUSED,
+
+    __IO_ByteVal,
+    __IO_UByteVal,
+    __IO_IntVal,
+    __IO_UIntVal,
+    __IO_LongVal,
+    __IO_ULongVal,
+
+    __IO_ByteLoc,
+    __IO_UByteLoc,
+    __IO_IntLoc,
+    __IO_UIntLoc,
+    __IO_LongLoc,
+    __IO_ULongLoc,
+
+    __IO_ByteRangeLoc,
+    __IO_UByteRangeLoc,
+    __IO_IntRangeLoc,
+    __IO_UIntRangeLoc,
+    __IO_LongRangeLoc,
+    __IO_ULongRangeLoc,
+
+    __IO_BoolVal,
+    __IO_BoolLoc,
+    __IO_BoolRangeLoc,
+
+    __IO_SetVal,
+    __IO_SetLoc,
+    __IO_SetRangeLoc,
+
+    __IO_CharVal,
+    __IO_CharLoc,
+    __IO_CharRangeLoc,
+
+    __IO_CharStrLoc,
+
+    __IO_CharVaryingLoc,
+
+    __IO_BitStrLoc,
+
+    __IO_RealVal,
+    __IO_RealLoc,
+    __IO_LongRealVal,
+    __IO_LongRealLoc
+} __tmp_IO_enum;
+
+typedef struct
+{
+    long        value;
+    char*       name;
+} __tmp_IO_enum_table_type;
+
+typedef struct
+{
+    long                      value;
+    __tmp_IO_enum_table_type* name_table;
+} __tmp_WIO_set;
+
+typedef struct
+{
+    char*       ptr;
+    long        lower;
+    long        upper;
+} __tmp_IO_charrange;
+
+typedef union
+{
+      signed long  slong;
+    unsigned long  ulong;
+}  __tmp_IO_long;
+
+typedef struct
+{
+    void*         ptr;
+    __tmp_IO_long lower;
+    __tmp_IO_long upper;
+} __tmp_IO_intrange;
+
+typedef struct
+{
+    void*           ptr;
+    unsigned long   lower;
+    unsigned long   upper;
+} __tmp_RIO_boolrange;
+
+typedef struct
+{
+    void*                     ptr;
+    long                      length;
+    __tmp_IO_enum_table_type* name_table;
+} __tmp_RIO_set;
+
+typedef struct
+{
+    void*                      ptr;
+    long                       length;
+    __tmp_IO_enum_table_type*  name_table;
+    unsigned long              lower;
+    unsigned long              upper;
+} __tmp_RIO_setrange;
+
+typedef struct
+{
+    char*       string;
+    long        string_length;
+} __tmp_IO_charstring;
+
+typedef union
+{
+    char                     __valbyte;
+    unsigned char            __valubyte;
+    short                    __valint;
+    unsigned short           __valuint;
+    long                     __vallong;
+    unsigned long            __valulong;
+    void*                    __locint;
+    __tmp_IO_intrange        __locintrange;
+
+    unsigned char            __valbool;
+    unsigned char*           __locbool;
+    __tmp_RIO_boolrange      __locboolrange;
+
+    __tmp_WIO_set            __valset;
+    __tmp_RIO_set            __locset;
+    __tmp_RIO_setrange       __locsetrange;
+
+    unsigned char            __valchar;
+    unsigned char*           __locchar;
+    __tmp_IO_charrange       __loccharrange;
+
+    __tmp_IO_charstring      __loccharstring;
+
+    float                    __valreal;
+    float*                   __locreal;
+    double                   __vallongreal;
+    double*                  __loclongreal;
+} __tmp_IO_union;
+
+/*
+ * CAUTION: The longest variant of __tmp_IO_union is 5 words long.
+ * Together with __descr this caters for double alignment where required.
+ */
+typedef struct
+{
+    __tmp_IO_union    __t;
+    __tmp_IO_enum     __descr;
+} __tmp_IO_list;
+
+#endif

gcc/ch/runtime/ltps.c

+/* Implement POWERSET runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __ltpowerset
+ *
+ * parameters:
+ *	left		powerset
+ *	right		powerset
+ *	bitlength	length of powerset
+ *
+ * returns:
+ *	int		1 .. left is proper subset of right
+ *                           (excludes case where left == right)
+ *			0 .. not
+ *
+ * abstract:
+ *  check if one powerset is included in another
+ *
+ */
+int
+__ltpowerset (left, right, bitlength)
+     SET_WORD      *left;
+     SET_WORD      *right;
+     unsigned long  bitlength;
+{
+  if (bitlength <= SET_CHAR_SIZE)
+    {
+      if ((*((SET_CHAR *)left) & *((SET_CHAR *)right))
+	  != *((SET_CHAR *)left))
+	return 0;
+      if (*((SET_CHAR *)left) != *((SET_CHAR *)right))
+	return 1;
+      return 0;
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      if ((*((SET_SHORT *)left) & *((SET_SHORT *)right))
+	  != *((SET_SHORT *)left))
+	return 0;
+      if (*((SET_SHORT *)left) != *((SET_SHORT *)right))
+	return 1;
+      return 0;
+    }
+  else
+    {
+      SET_WORD	*endp = left + BITS_TO_WORDS(bitlength);
+      int all_equal = 1;              /* assume all bits are equal */
+    
+      while (left < endp)
+	{
+	  if ((*right & *left) != *left)
+	    return 0;
+	  if (*left != *right)
+	    all_equal = 0;
+	  left++;
+	  right++;
+	}
+      if (left == endp && all_equal)    /* exclude TRUE return for == case */
+	return 0;
+      return 1;
+    }
+}

gcc/ch/runtime/ltstr.c

+/* Implement string-related runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Bill Cox
+
+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.  */
+
+#define MIN(a, b)  ((a) < (b) ? (a) : (b))
+
+/*
+ * function __ltstring
+ *
+ * parameters:
+ *     S1 - pointer to left string
+ *     LEN1 - length of left string
+ *     S2 - pointer to right string
+ *     LEN2 - length of right string
+ *
+ * returns:
+ *     1 if left string is a proper subset of the right string, 0 otherwise
+ *
+ * exceptions:
+ *     none
+ *
+ * abstract:
+ *     compares two character strings for subset relationship
+ *
+ */
+
+int __ltstring (s1, len1, s2, len2)
+     char *s1;
+     int len1;
+     char *s2;
+     int len2;
+{
+  int i;
+
+  i = memcmp (s1, s2, MIN (len1, len2));
+  if (i)
+    return (i < 0);
+  return (len1 < len2);
+}

gcc/ch/runtime/rts.h

+/* GNU CHILL compiler regression test file
+ Copyright (C) 1992, 1993 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. */
+
+#ifndef __rts_h_
+#define __rts_h_
+
+typedef enum
+{
+  UNUSED,
+  Process,
+  Signal,
+  Buffer,
+  Event,
+  Synonym,
+  Exception,
+  LAST_AND_UNUSED,
+} TaskingEnum;
+
+typedef void (*EntryPoint) ();
+
+typedef struct
+{
+  char       *name;
+  short      *value;
+  int         value_defined;
+  EntryPoint  entry;
+  unsigned char /*TaskingEnum*/ type;
+} TaskingStruct;
+
+typedef struct
+{
+  short ptype;
+  short pcopy;
+} INSTANCE;
+
+#endif /* __rts_h_ */

gcc/ch/runtime/sliceps.c

+/* Implement POWERSET runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser, et al
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include "powerset.h"
+
+/*
+ * function __powerset_slice
+ *
+ * parameters:
+ *      dps             dest powerset
+ *      dbl             destination bit length
+ *	sps		sourcepowerset
+ *	sbl     	source powerset length in bits
+ *      start           starting bit number
+ *      end             ending bit number
+ *
+ * exceptions:
+ *  none
+ *
+ * abstract:
+ *  Extract into a powerset a slice of another powerset.
+ *
+ */
+extern void
+__pscpy (SET_WORD      *dps,
+	 unsigned long  dbl,
+	 unsigned long  doffset,
+	 SET_WORD      *sps,
+	 unsigned long  sbl,
+	 unsigned long  start,
+	 unsigned long  length);
+
+void
+__psslice (dps, dbl, sps, sbl, start, length)
+     SET_WORD      *dps;
+     unsigned long  dbl;
+     SET_WORD      *sps;
+     unsigned long  sbl;
+     unsigned long  start;
+     unsigned long  length;
+{
+  /* simply supply a zero destination offset and copy the slice */
+  __pscpy (dps, dbl, (unsigned long)0, sps, sbl, start, length);
+}

gcc/ch/runtime/unhex.c

+/* Implement runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <setjmp.h>
+
+/*
+ * function unhandled_exception
+ *
+ * parameter:
+ *  exname		name of exception
+ *  file		filename
+ *  lineno		line number
+ *  user_arg		user specified argument
+ *
+ * returns:
+ *  never
+ *
+ * abstract:
+ *  print an error message about unhandled exception and call abort
+ *
+ */
+
+void
+unhandled_exception (exname, file, lineno, user_arg)
+     char *exname;
+     char *file;
+     int lineno;
+     int user_arg;
+{
+  sleep (1); /* give previous output a chance to finish */
+  fprintf (stderr, "ChillLib: unhandled exception `%s' in file %s at line %d\n",
+	   exname, file, lineno);
+  fflush (stderr);
+  abort ();
+} /* unhandled_exception */

gcc/ch/runtime/unhex1.c

+/* Implement runtime actions for CHILL.
+   Copyright (C) 1992,1993 Free Software Foundation, Inc.
+   Author: Wilfried Moser
+
+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.  */
+
+#define __CHILL_LIB__
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <setjmp.h>
+
+extern void cause_exception (char *ex, char *file, int lineno, int arg);
+extern void unhandled_exception (char *ex, char *file, int lineno, int arg);
+
+/*
+ * function __unhandled_ex
+ *
+ * parameter:
+ *  exname		name of exception
+ *  file		filename
+ *  lineno		line number
+ *
+ * returns:
+ *  never
+ *
+ * abstract:
+ *  This function gets called by compiler generated code when an unhandled
+ *  exception occures.
+ *  First cause_exception gets called (which may be user defined) and
+ *  then the standard unhandled exception routine gets called.
+ *
+ */
+
+void
+__unhandled_ex (exname, file, lineno)
+     char *exname;
+     char *file;
+     int lineno;
+{
+    cause_exception (exname, file, lineno, 0);
+    unhandled_exception (exname, file, lineno, 0);
+} /* unhandled_exception */

gcc/ch/satisfy.c

+/* Name-satisfaction for GNU Chill compiler.
+   Copyright (C) 1993 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 <stdio.h>
+#include "config.h"
+#include "tree.h"
+#include "flags.h"
+#include "ch-tree.h"
+#include "lex.h"
+
+#define SATISFY(ARG) ((ARG) = satisfy(ARG, chain))
+
+extern void error           PROTO((char *, ...));
+extern void error_with_decl PROTO((tree, char *, ...));
+extern void expand_decl     PROTO((tree));
+extern void layout_enum     PROTO((tree));
+
+struct decl_chain
+{
+  struct decl_chain *prev;
+  /* DECL can be a decl, or a POINTER_TYPE or a REFERENCE_TYPE. */
+  tree decl;
+};
+
+/* forward declaration */
+tree satisfy PROTO((tree, struct decl_chain *));
+
+static struct decl_chain dummy_chain;
+#define LOOKUP_ONLY (chain==&dummy_chain)
+
+/* Recursive helper routine to logically reverse the chain. */
+static void
+cycle_error_print (chain, decl)
+     struct decl_chain *chain;
+     tree decl;
+{
+  if (chain->decl != decl)
+    {
+      cycle_error_print (chain->prev, decl);
+      if (TREE_CODE_CLASS (TREE_CODE (chain->decl)) == 'd')
+	error_with_decl (chain->decl, "  `%s', which depends on ...");
+    }
+}
+
+tree
+safe_satisfy_decl (decl, prev_chain)
+     tree decl;
+     struct decl_chain *prev_chain;
+{
+  struct decl_chain new_link;
+  struct decl_chain *link;
+  struct decl_chain *chain = prev_chain;
+  char *save_filename = input_filename;
+  int save_lineno = lineno;
+  tree result = decl;
+  
+  if (decl == NULL_TREE)
+    return decl;
+
+  if (!LOOKUP_ONLY)
+    {
+      int pointer_type_breaks_cycle = 0;
+      /* Look for a cycle.
+	 We could do this test more efficiently by setting a flag.  FIXME */
+      for (link = prev_chain; link != NULL; link = link->prev)
+	{
+	  if (TREE_CODE_CLASS (TREE_CODE (link->decl)) != 'd')
+	    pointer_type_breaks_cycle = 1;
+	  if (link->decl == decl)
+	    {
+	      if (!pointer_type_breaks_cycle)
+		{
+		  error_with_decl (decl, "Cycle: `%s' depends on ...");
+		  cycle_error_print (prev_chain, decl);
+		  error_with_decl (decl, "  `%s'");
+		  return error_mark_node;
+		}
+	      /* There is a cycle, but it includes a pointer type,
+		 so we're OK.  However, we still have to continue
+		 the satisfy (for example in case this is a TYPE_DECL
+		 that points to a LANG_DECL).  The cycle-check for
+		 POINTER_TYPE/REFERENCE_TYPE should stop the recursion. */
+	      break;
+	    }
+	}
+
+      new_link.decl = decl;
+      new_link.prev = prev_chain;
+      chain = &new_link;
+    }
+
+  input_filename = DECL_SOURCE_FILE (decl);
+  lineno = DECL_SOURCE_LINE (decl);
+
+  switch ((enum chill_tree_code)TREE_CODE (decl))
+    {
+    case ALIAS_DECL:
+      if (!LOOKUP_ONLY && !DECL_POSTFIX_ALL(decl))
+	result = safe_satisfy_decl (DECL_ABSTRACT_ORIGIN (decl), chain);
+      break;
+    case BASED_DECL:
+      SATISFY (TREE_TYPE (decl));
+      SATISFY (DECL_ABSTRACT_ORIGIN (decl));
+      break;
+    case CONST_DECL:
+      SATISFY (TREE_TYPE (decl));
+      SATISFY (DECL_INITIAL (decl));
+      if (!LOOKUP_ONLY)
+	{
+	  if (DECL_SIZE (decl) == 0)
+	    {
+	      tree init_expr = DECL_INITIAL (decl);
+	      tree init_type;
+	      tree specified_mode = TREE_TYPE (decl);
+
+	      if (init_expr == NULL_TREE
+		  || TREE_CODE (init_expr) == ERROR_MARK)
+		goto bad_const;
+	      init_type = TREE_TYPE (init_expr);
+	      if (specified_mode == NULL_TREE)
+		{
+		  if (init_type == NULL_TREE)
+		    {
+		      check_have_mode (init_expr, "SYN without mode");
+		      goto bad_const;
+		    }
+		  TREE_TYPE (decl) = init_type;
+		  CH_DERIVED_FLAG (decl) = CH_DERIVED_FLAG (init_expr);
+		}
+	      else if (CH_IS_ASSOCIATION_MODE (specified_mode) ||
+		       CH_IS_ACCESS_MODE (specified_mode) || CH_IS_TEXT_MODE (specified_mode) ||
+		       CH_IS_BUFFER_MODE (specified_mode) || CH_IS_EVENT_MODE (specified_mode))
+		{
+		  error ("SYN of this mode not allowed");
+		  goto bad_const;
+		}
+	      else if (!CH_COMPATIBLE (init_expr, specified_mode))
+		{
+		  error ("mode of SYN incompatible with value");
+		  goto bad_const;
+		} 
+	      else if (discrete_type_p (specified_mode)
+		       && TREE_CODE (init_expr) == INTEGER_CST
+		       && (compare_int_csts (LT_EXPR, init_expr,
+					     TYPE_MIN_VALUE (specified_mode))
+			   || compare_int_csts (GT_EXPR, init_expr,
+						TYPE_MAX_VALUE(specified_mode))
+			   ))
+		{
+		  error ("SYN value outside range of its mode");
+		  /* set an always-valid initial value to prevent 
+		     other errors. */
+		  DECL_INITIAL (decl) = TYPE_MIN_VALUE (specified_mode);
+		}
+	      else if (CH_STRING_TYPE_P (specified_mode) 
+		       && (init_type && CH_STRING_TYPE_P (init_type))
+		       && integer_zerop (string_assignment_condition (specified_mode, init_expr)))
+		{
+		  error ("INIT string too large for mode");
+		  DECL_INITIAL (decl) = error_mark_node;
+		}
+	      else
+		{
+		  struct ch_class class;
+		  class.mode = TREE_TYPE (decl);
+		  class.kind = CH_VALUE_CLASS;
+		  DECL_INITIAL (decl)
+		    = convert_to_class (class, DECL_INITIAL (decl));
+		}
+	      /* DECL_SIZE is set to prevent re-doing this stuff. */
+	      DECL_SIZE (decl) = TYPE_SIZE (TREE_TYPE (decl));
+	      if (! TREE_CONSTANT (DECL_INITIAL (decl))
+		  && TREE_CODE (DECL_INITIAL (decl)) != ERROR_MARK)
+		{
+		  error_with_decl (decl,
+				   "value of %s is not a valid constant");
+		  DECL_INITIAL (decl) = error_mark_node;
+		}
+	    }
+	  result = DECL_INITIAL (decl);
+	}
+      break;
+    bad_const:
+      DECL_INITIAL (decl) = error_mark_node;
+      TREE_TYPE (decl) = error_mark_node;
+      return error_mark_node;
+    case FUNCTION_DECL:
+      SATISFY (TREE_TYPE (decl));
+      if (CH_DECL_PROCESS (decl))
+	safe_satisfy_decl (DECL_TASKING_CODE_DECL (decl), 
+			   prev_chain);
+      break;
+    case PARM_DECL:
+      SATISFY (TREE_TYPE (decl));
+      break;
+    /* RESULT_DECL doesn't need to be satisfied;  
+       it's only built internally in pass 2 */
+    case TYPE_DECL:
+      SATISFY (TREE_TYPE (decl));
+      if (CH_DECL_SIGNAL (decl))
+	safe_satisfy_decl (DECL_TASKING_CODE_DECL (decl), 
+			   prev_chain);
+      if (!LOOKUP_ONLY)
+	{
+	  if (TYPE_NAME (TREE_TYPE (decl)) == NULL_TREE)
+	    TYPE_NAME (TREE_TYPE (decl)) = decl;
+	  layout_decl (decl, 0);
+	  if (CH_DECL_SIGNAL (decl) && CH_TYPE_NONVALUE_P (TREE_TYPE (decl)))
+	    error ("mode with non-value property in signal definition");
+	  result = TREE_TYPE (decl);
+	}
+      break;
+    case VAR_DECL:
+      SATISFY (TREE_TYPE (decl));
+      if (!LOOKUP_ONLY)
+	{
+	  layout_decl (decl, 0);
+	  if (TREE_READONLY (TREE_TYPE (decl)))
+	    TREE_READONLY (decl) = 1;
+	}
+      break;
+    default:
+      ;
+    }
+
+  /* Now set the DECL_RTL, if needed. */
+  if (!LOOKUP_ONLY && DECL_RTL (decl) == 0
+      && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL
+	  || TREE_CODE (decl) == CONST_DECL))
+    {
+      if (TREE_CODE (decl) == FUNCTION_DECL && decl_function_context (decl))
+	make_function_rtl (decl);
+      else if (!TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
+	expand_decl (decl);
+      else
+	{ char * asm_name;
+	  if (current_module == 0 || TREE_PUBLIC (decl)
+	      || current_function_decl)
+	    asm_name = NULL;
+	  else
+	    {
+	      asm_name = (char*)
+		alloca (IDENTIFIER_LENGTH (current_module->prefix_name)
+			+ IDENTIFIER_LENGTH (DECL_NAME (decl)) + 3);
+	      sprintf (asm_name, "%s__%s",
+		       IDENTIFIER_POINTER (current_module->prefix_name),
+		       IDENTIFIER_POINTER (DECL_NAME (decl)));
+	    }
+	  make_decl_rtl (decl, asm_name, TREE_PUBLIC (decl));
+	}
+    }
+
+  input_filename = save_filename;
+  lineno = save_lineno;
+
+  return result;
+}
+
+tree
+satisfy_decl (decl, lookup_only)
+     tree decl;
+     int lookup_only;
+{
+  return safe_satisfy_decl (decl, lookup_only ? &dummy_chain : NULL);
+}
+
+static void
+satisfy_list (exp, chain)
+     register tree exp;
+     struct decl_chain *chain;
+{
+  for (; exp != NULL_TREE; exp = TREE_CHAIN (exp))
+    {
+      SATISFY (TREE_VALUE (exp));
+      SATISFY (TREE_PURPOSE (exp));
+    }
+}
+
+static void
+satisfy_list_values (exp, chain)
+     register tree exp;
+     struct decl_chain *chain;
+{
+  for (; exp != NULL_TREE; exp = TREE_CHAIN (exp))
+    {
+      SATISFY (TREE_VALUE (exp));
+    }
+}
+
+tree
+satisfy (exp, chain)
+     tree exp;
+     struct decl_chain *chain;
+{
+  int arg_length;
+  int i;
+  tree decl;
+
+  if (exp == NULL_TREE)
+    return NULL_TREE;
+
+#if 0
+  if (!UNSATISFIED (exp))
+    return exp;
+#endif
+
+  switch (TREE_CODE_CLASS (TREE_CODE (exp)))
+    {
+    case 'd':
+      if (!LOOKUP_ONLY)
+	return safe_satisfy_decl (exp, chain);
+      break;
+    case 'r':
+    case 's':
+    case '<':
+    case 'e':
+      switch ((enum chill_tree_code)TREE_CODE (exp))
+	{
+	case REPLICATE_EXPR:
+	  goto binary_op;
+	case TRUTH_NOT_EXPR:
+	  goto unary_op;
+	case COMPONENT_REF:
+	  SATISFY (TREE_OPERAND (exp, 0));
+	  if (!LOOKUP_ONLY && TREE_TYPE (exp) == NULL_TREE)
+	    return resolve_component_ref (exp);
+	  return exp;
+	case CALL_EXPR:
+	  SATISFY (TREE_OPERAND (exp, 0));
+	  SATISFY (TREE_OPERAND (exp, 1));
+	  if (!LOOKUP_ONLY && TREE_TYPE (exp) == NULL_TREE)
+	    return build_generalized_call (TREE_OPERAND (exp, 0),
+					   TREE_OPERAND (exp, 1));
+	  return exp;
+	case CONSTRUCTOR:
+	  { tree link = TREE_OPERAND (exp, 1);
+	    int expand_needed = TREE_TYPE (exp)
+	      && TREE_CODE_CLASS (TREE_CODE (TREE_TYPE (exp))) != 't';
+	    for (; link != NULL_TREE; link = TREE_CHAIN (link))
+	      {
+		SATISFY (TREE_VALUE (link));
+		if (!TUPLE_NAMED_FIELD (link))
+		  SATISFY (TREE_PURPOSE (link));
+	      }
+	    SATISFY (TREE_TYPE (exp));
+	    if (expand_needed && !LOOKUP_ONLY)
+	      {
+		tree type = TREE_TYPE (exp);
+		TREE_TYPE (exp) = NULL_TREE; /* To force expansion. */
+		return chill_expand_tuple (type, exp);
+	      }
+	    return exp;
+	  }
+	default:
+	  ;
+	}
+      arg_length = tree_code_length[TREE_CODE (exp)];
+      for (i = 0; i < arg_length; i++)
+	SATISFY (TREE_OPERAND (exp, i));
+      return exp;
+    case '1':
+    unary_op:
+      SATISFY (TREE_OPERAND (exp, 0));
+      if ((enum chill_tree_code)TREE_CODE (exp) == PAREN_EXPR)
+	return TREE_OPERAND (exp, 0);
+      if (!LOOKUP_ONLY)
+	return finish_chill_unary_op (exp);
+      break;
+    case '2':
+    binary_op:
+      SATISFY (TREE_OPERAND (exp, 0));
+      SATISFY (TREE_OPERAND (exp, 1));
+      if (!LOOKUP_ONLY && TREE_CODE (exp) != RANGE_EXPR)
+	return finish_chill_binary_op (exp);
+      break;
+    case 'x':
+      switch ((enum chill_tree_code)TREE_CODE (exp))
+	{
+	case IDENTIFIER_NODE:
+	  decl = lookup_name (exp);
+	  if (decl == NULL)
+	    {
+	      if (LOOKUP_ONLY)
+		return exp;
+	      error ("undeclared identifier `%s'", IDENTIFIER_POINTER (exp));
+	      return error_mark_node;
+	    }
+	  if (LOOKUP_ONLY)
+	    return decl;
+	  return safe_satisfy_decl (decl, chain);
+	case TREE_LIST:
+	  satisfy_list (exp, chain);
+	  break;
+	default:
+	  ;
+	}
+      break;
+    case 't':
+      /* If TYPE_SIZE is non-NULL, exp and its subfields has already been
+	 satified and laid out.  The exception is pointer and reference types,
+	 which we layout before we lay out their TREE_TYPE. */
+      if (TYPE_SIZE (exp) && TREE_CODE (exp) != POINTER_TYPE
+	  && TREE_CODE (exp) != REFERENCE_TYPE)
+	return exp;
+      if (TYPE_MAIN_VARIANT (exp) != exp)
+	SATISFY (TYPE_MAIN_VARIANT (exp));
+      switch ((enum chill_tree_code)TREE_CODE (exp))
+	{
+	case LANG_TYPE:
+	  {
+	    tree d = TYPE_DOMAIN (exp);
+	    tree t = satisfy (TREE_TYPE (exp), chain);
+	    SATISFY (d);
+	    /* It is possible that one of the above satisfy calls recursively
+	       caused exp to be satisfied, in which case we're done. */
+	    if (TREE_CODE (exp) != LANG_TYPE)
+	      return exp;
+	    TREE_TYPE (exp) = t;
+	    TYPE_DOMAIN (exp) = d;
+	    if (!LOOKUP_ONLY)
+	      exp = smash_dummy_type (exp);
+	  }
+	  break;
+	case ARRAY_TYPE:
+	  SATISFY (TREE_TYPE (exp));
+	  SATISFY (TYPE_DOMAIN (exp));
+	  SATISFY (TYPE_ATTRIBUTES (exp));
+	  if (!LOOKUP_ONLY)
+	    CH_TYPE_NONVALUE_P (exp) = CH_TYPE_NONVALUE_P (TREE_TYPE (exp));
+	  if (!TYPE_SIZE (exp)  && !LOOKUP_ONLY)
+	    exp = layout_chill_array_type (exp);
+	  break;
+	case FUNCTION_TYPE:
+	  SATISFY (TREE_TYPE (exp));
+	  if (TREE_CODE_CLASS (TREE_CODE (TREE_TYPE (exp))) != 't'
+	      && !LOOKUP_ONLY && TREE_CODE (TREE_TYPE (exp)) != ERROR_MARK)
+	    {
+	      error ("RETURNS spec with invalid mode");
+	      TREE_TYPE (exp) = error_mark_node;
+	    }
+	  satisfy_list_values (TYPE_ARG_TYPES (exp), chain);
+	  if (!TYPE_SIZE (exp)  && !LOOKUP_ONLY)
+	    layout_type (exp);
+	  break;
+	case ENUMERAL_TYPE:
+	  if (TYPE_SIZE (exp) == NULL_TREE && !LOOKUP_ONLY)
+	    { tree pair;
+	      /* FIXME:  Should this use satisfy_decl? */
+	      for (pair = TYPE_VALUES (exp); pair; pair = TREE_CHAIN (pair))
+		SATISFY (DECL_INITIAL (TREE_VALUE (pair)));
+	      layout_enum (exp);
+	    }
+	  break;
+	case INTEGER_TYPE:
+	  SATISFY (TYPE_MIN_VALUE (exp));
+	  SATISFY (TYPE_MAX_VALUE (exp));
+	  if (TREE_TYPE (exp) != NULL_TREE)
+	    { /* A range type */
+	      if (TREE_TYPE (exp) != ridpointers[(int) RID_RANGE]
+		  && TREE_TYPE (exp) != ridpointers[(int) RID_BIN]
+		  && TREE_TYPE (exp) != string_index_type_dummy)
+		SATISFY (TREE_TYPE (exp));
+	      if (!TYPE_SIZE (exp)  && !LOOKUP_ONLY)
+		exp = layout_chill_range_type (exp, 1);
+	    }
+	  break;
+	case POINTER_TYPE:
+	case REFERENCE_TYPE:
+	  if (LOOKUP_ONLY)
+	    SATISFY (TREE_TYPE (exp));
+	  else
+	    {
+	      struct decl_chain *link;
+	      int already_seen = 0;
+	      for (link = chain; ; link = link->prev)
+		{
+		  if (link == NULL)
+		    {	
+		      struct decl_chain new_link;
+		      new_link.decl = exp;
+		      new_link.prev = chain;
+		      TREE_TYPE (exp) = satisfy (TREE_TYPE (exp), &new_link);
+		      break;
+		    }
+		  else if (link->decl == exp)
+		    {
+		      already_seen = 1;
+		      break;
+		    }
+		}
+	      if (!TYPE_SIZE (exp))
+		{
+		  layout_type (exp);
+		  if (TREE_CODE (exp) == REFERENCE_TYPE)
+		    CH_NOVELTY (exp) = CH_NOVELTY (TREE_TYPE (exp));
+		  if (! already_seen)
+		    {
+		      tree valtype = TREE_TYPE (exp);
+		      if (TREE_CODE_CLASS (TREE_CODE (valtype)) != 't')
+			{
+			  if (TREE_CODE (valtype) != ERROR_MARK)
+			    error ("operand to REF is not a mode");
+			  TREE_TYPE (exp) = error_mark_node;
+			  return error_mark_node;
+			}
+		      else if (TREE_CODE (exp) == POINTER_TYPE
+			       && TYPE_POINTER_TO (valtype) == NULL)
+			TYPE_POINTER_TO (valtype) = exp;
+		    }
+		}
+	    }
+	  break;
+	case RECORD_TYPE:
+	  {
+	    /* FIXME: detected errors in here will be printed as
+	       often as this sequence runs. Find another way or
+	       place to print the errors. */
+	    /* if we have an ACCESS or TEXT mode we have to set
+	       maximum_field_alignment to 0 to fit with runtime
+	       system, even when we compile with -fpack. */
+	    extern int maximum_field_alignment;
+	    int save_maximum_field_alignment = maximum_field_alignment;
+
+	    if (CH_IS_ACCESS_MODE (exp) || CH_IS_TEXT_MODE (exp))
+	      maximum_field_alignment = 0;
+
+	    for (decl = TYPE_FIELDS (exp); decl; decl = TREE_CHAIN (decl))
+	      {
+		SATISFY (TREE_TYPE (decl));
+		if (!LOOKUP_ONLY)
+		  {
+		    /* if we have a UNION_TYPE here (variant structure), check for
+		       non-value mode in it. This is not allowed (Z.200/pg. 33) */
+		    if (TREE_CODE (TREE_TYPE (decl)) == UNION_TYPE &&
+			CH_TYPE_NONVALUE_P (TREE_TYPE (decl)))
+		      {
+			error ("field with non-value mode in variant structure not allowed");
+			TREE_TYPE (decl) = error_mark_node;
+		      }
+		    /* RECORD_TYPE gets the non-value property if one of the
+		       fields has the non-value property */
+		    CH_TYPE_NONVALUE_P (exp) |= CH_TYPE_NONVALUE_P (TREE_TYPE (decl));
+		  }
+		if (TREE_CODE (decl) == CONST_DECL)
+		  {
+		    SATISFY (DECL_INITIAL (decl));
+		    if (!LOOKUP_ONLY)
+		      {
+			if (CH_IS_BUFFER_MODE (exp) || CH_IS_EVENT_MODE (exp))
+			  DECL_INITIAL (decl)
+			    = check_queue_size (exp, DECL_INITIAL (decl));
+			else if (CH_IS_TEXT_MODE (exp) &&
+				 DECL_NAME (decl) == get_identifier ("__textlength"))
+			  DECL_INITIAL (decl)
+			    = check_text_length (exp, DECL_INITIAL (decl));
+		      }
+		  }
+		else if (TREE_CODE (decl) == FIELD_DECL)
+		  {
+		    SATISFY (DECL_INITIAL (decl));
+		  }
+	      }
+	    satisfy_list (TYPE_TAG_VALUES (exp), chain);
+	    if (!TYPE_SIZE (exp)  && !LOOKUP_ONLY)
+	      exp = layout_chill_struct_type (exp);
+	    maximum_field_alignment = save_maximum_field_alignment;
+
+	    /* perform some checks on nonvalue modes, they are record_mode's */
+	    if (!LOOKUP_ONLY)
+	      {
+		if (CH_IS_BUFFER_MODE (exp))
+		  {
+		    tree elemmode = buffer_element_mode (exp);
+		    if (elemmode != NULL_TREE && CH_TYPE_NONVALUE_P (elemmode))
+		      {
+			error ("buffer element mode must not have non-value property");
+			invalidate_buffer_element_mode (exp);
+		      }
+		  }
+		else if (CH_IS_ACCESS_MODE (exp))
+		  {
+		    tree recordmode = access_recordmode (exp);
+		    if (recordmode != NULL_TREE && CH_TYPE_NONVALUE_P (recordmode))
+		      {
+			error ("recordmode must not have the non-value property");
+			invalidate_access_recordmode (exp);
+		      }
+		  }
+	      }
+	  }
+	  break;
+	case SET_TYPE:
+	  SATISFY (TYPE_DOMAIN (exp));
+	  if (!TYPE_SIZE (exp)  && !LOOKUP_ONLY)
+	    exp = layout_powerset_type (exp);
+	  break;
+	case UNION_TYPE:
+	  for (decl = TYPE_FIELDS (exp); decl; decl = TREE_CHAIN (decl))
+	    {
+	      SATISFY (TREE_TYPE (decl));
+	      if (!LOOKUP_ONLY)
+		CH_TYPE_NONVALUE_P (exp) |= CH_TYPE_NONVALUE_P (TREE_TYPE (decl));
+	    }
+	  if (!TYPE_SIZE (exp)  && !LOOKUP_ONLY)
+	    exp = layout_chill_variants (exp);
+	  break;
+	default:
+	  ;
+	}
+    }
+  return exp;
+}

gcc/ch/timing.c

+/* Implement timing-related actions for 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.  */
+
+#include <stdio.h>
+#include <limits.h>
+#include <string.h>
+#include "config.h"
+#include "tree.h"
+#include "rtl.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "input.h"
+#include "obstack.h"
+#include "lex.h"
+
+#ifndef LONG_TYPE_SIZE
+#define LONG_TYPE_SIZE BITS_PER_WORD
+#endif
+
+/* set non-zero if input text is forced to lowercase */
+extern int ignore_case;
+
+/* set non-zero if special words are to be entered in uppercase */
+extern int special_UC;
+
+/* timing modes */
+tree abs_timing_type_node;
+tree duration_timing_type_node;
+
+/* rts time type */
+static tree rtstime_type_node = NULL_TREE;
+
+/* the stack for AFTER primval [ DELAY ] IN 
+   and has following layout
+
+   TREE_VALUE (TREE_VALUE (after_stack)) = current time or NULL_TREE (if DELAY specified)
+   TREE_PURPOSE (TREE_VALUE (after_stack)) = the duration location
+   TREE_VALUE (TREE_PURPOSE (after_stack)) = label at TIMEOUT
+   TREE_PURPOSE (TREE_PURPOSE (after_stack)) = label at the end of AFTER action
+*/
+tree after_stack = NULL_TREE;
+
+/* in pass 1 we need a seperate list for the labels */
+static tree after_stack_pass_1 = NULL_TREE;
+static tree after_help;
+
+void
+timing_init ()
+{
+  tree ptr_ftype_durt_ptr_int;
+  tree int_ftype_abst_ptr_int;
+  tree void_ftype_ptr;
+  tree long_ftype_int_int_int_int_int_int_int_ptr_int;
+  tree void_ftype_abstime_ptr;
+  tree int_ftype_ptr_durt_ptr;
+  tree void_ftype_durt_ptr;
+  tree void_ftype_ptr_durt_ptr_int;
+  tree temp;
+  tree endlink;
+  tree ulong_type;
+  
+  ulong_type = TREE_TYPE (lookup_name (
+		          get_identifier ((ignore_case || ! special_UC ) ?
+					  "ulong" : "ULONG")));
+
+  /* build modes for TIME and DURATION */
+  duration_timing_type_node = make_unsigned_type (LONG_TYPE_SIZE);
+  temp = pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_DURATION],
+			       duration_timing_type_node));
+  SET_CH_NOVELTY_NONNIL (duration_timing_type_node, temp);
+  abs_timing_type_node = make_unsigned_type (LONG_TYPE_SIZE);
+  temp = pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_TIME],
+			       abs_timing_type_node));
+  SET_CH_NOVELTY_NONNIL (abs_timing_type_node, temp);
+
+  /* the mode of time the runtimesystem returns */
+  if (rtstime_type_node == NULL_TREE)
+  {
+      tree decl1, decl2, result;
+
+      decl1 = build_decl (FIELD_DECL,
+			  get_identifier ("secs"),
+			  ulong_type);
+      DECL_INITIAL (decl1) = NULL_TREE;
+      decl2 = build_decl (FIELD_DECL,
+			  get_identifier ("nsecs"),
+			  ulong_type);
+      DECL_INITIAL (decl2) = NULL_TREE;
+      TREE_CHAIN (decl2) = NULL_TREE;
+      TREE_CHAIN (decl1) = decl2;
+      
+      result = build_chill_struct_type (decl1);
+      pushdecl (temp = build_decl (TYPE_DECL,
+	get_identifier ("__tmp_rtstime"), result));
+      DECL_SOURCE_LINE (temp) = 0;
+      satisfy_decl (temp, 0);
+      rtstime_type_node = TREE_TYPE (temp);
+  }
+  
+  endlink = void_list_node;
+  
+  ptr_ftype_durt_ptr_int
+    = build_function_type (ptr_type_node,
+         tree_cons (NULL_TREE, duration_timing_type_node,
+             tree_cons (NULL_TREE, ptr_type_node,
+                 tree_cons (NULL_TREE, integer_type_node,
+                     endlink))));
+
+  int_ftype_abst_ptr_int
+    = build_function_type (integer_type_node,
+         tree_cons (NULL_TREE, abs_timing_type_node,
+             tree_cons (NULL_TREE, ptr_type_node,
+                 tree_cons (NULL_TREE, integer_type_node,
+                     endlink))));
+
+  void_ftype_ptr
+     = build_function_type (void_type_node,
+	   tree_cons (NULL_TREE, ptr_type_node,
+	       endlink));
+
+  long_ftype_int_int_int_int_int_int_int_ptr_int
+    = build_function_type (abs_timing_type_node,
+	 tree_cons (NULL_TREE, integer_type_node,
+	    tree_cons (NULL_TREE, integer_type_node,
+	       tree_cons (NULL_TREE, integer_type_node,
+	          tree_cons (NULL_TREE, integer_type_node,
+	             tree_cons (NULL_TREE, integer_type_node,
+	                tree_cons (NULL_TREE, integer_type_node,
+	                   tree_cons (NULL_TREE, integer_type_node,
+	                      tree_cons (NULL_TREE, ptr_type_node,
+	                         tree_cons (NULL_TREE, integer_type_node,
+			            endlink))))))))));
+
+  void_ftype_abstime_ptr
+    = build_function_type (void_type_node,
+          tree_cons (NULL_TREE, abs_timing_type_node,
+              tree_cons (NULL_TREE, ptr_type_node,
+                  endlink)));
+
+  int_ftype_ptr_durt_ptr
+    = build_function_type (integer_type_node,
+          tree_cons (NULL_TREE, ptr_type_node,
+              tree_cons (NULL_TREE, duration_timing_type_node,
+                  tree_cons (NULL_TREE, ptr_type_node,
+                      endlink))));
+
+  void_ftype_durt_ptr
+    = build_function_type (void_type_node,
+          tree_cons (NULL_TREE, duration_timing_type_node,
+              tree_cons (NULL_TREE, ptr_type_node,
+                  endlink)));
+
+  void_ftype_ptr_durt_ptr_int
+    = build_function_type (void_type_node,
+        tree_cons (NULL_TREE, ptr_type_node,
+          tree_cons (NULL_TREE, duration_timing_type_node,
+            tree_cons (NULL_TREE, ptr_type_node,
+              tree_cons (NULL_TREE, integer_type_node,
+                endlink)))));
+
+  builtin_function ("_abstime", long_ftype_int_int_int_int_int_int_int_ptr_int,
+		    NOT_BUILT_IN, NULL_PTR);
+  builtin_function ("__check_cycle", void_ftype_ptr_durt_ptr_int,
+		    NOT_BUILT_IN, NULL_PTR);
+  builtin_function ("__convert_duration_rtstime", void_ftype_durt_ptr,
+		    NOT_BUILT_IN, NULL_PTR);
+  builtin_function ("__define_timeout", ptr_ftype_durt_ptr_int,
+		    NOT_BUILT_IN, NULL_PTR);
+  builtin_function ("_inttime", void_ftype_abstime_ptr,
+		    NOT_BUILT_IN, NULL_PTR);
+  builtin_function ("__remaintime", int_ftype_ptr_durt_ptr,
+		    NOT_BUILT_IN, NULL_PTR);
+  builtin_function ("__rtstime", void_ftype_ptr,
+		    NOT_BUILT_IN, NULL_PTR);
+  builtin_function ("__wait_until", int_ftype_abst_ptr_int,
+		    NOT_BUILT_IN, NULL_PTR);
+}
+
+#if 0
+ *
+ * build AT action
+ *
+ * AT primval IN
+ *  ok-actionlist
+ * TIMEOUT
+ *  to-actionlist
+ * END;
+ *
+ * gets translated to
+ *
+ * if (__wait_until (primval) == 0)
+ *   ok-actionlist
+ * else
+ *   to-action-list
+ *
+#endif
+
+void
+build_at_action (t)
+     tree t;
+{
+  tree abstime, expr, filename, fcall;
+  
+  if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK)
+    abstime = convert (abs_timing_type_node, build_int_2 (0, 0));
+  else
+    abstime = t;
+  
+  if (TREE_TYPE (abstime) != abs_timing_type_node)
+    {
+      error ("absolute time value must be of mode TIME.");
+      abstime = convert (abs_timing_type_node, build_int_2 (0, 0));
+    }
+  filename = force_addr_of (get_chill_filename ());
+  fcall = build_chill_function_call (
+	    lookup_name (get_identifier ("__wait_until")),
+	      tree_cons (NULL_TREE, abstime,
+		tree_cons (NULL_TREE, filename,
+		  tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
+  expr = build (EQ_EXPR, integer_type_node, fcall, integer_zero_node);
+  expand_start_cond (expr, 0);
+  emit_line_note (input_filename, lineno);
+}
+
+#if 0
+ *
+ * build CYCLE action
+ *
+ * CYCLE primval IN
+ *  actionlist
+ * END;
+ *
+ * gets translated to
+ *
+ * {
+ *    RtsTime  now; 
+ *  label:
+ *    __rtstime (&now); 
+ *     actionlist
+ *    __check_cycle (&now, primval, filename, lineno); 
+ *    goto label;
+ *  }
+ *
+#endif
+
+tree
+build_cycle_start (t)
+    tree t;
+{
+  tree purpose = build_tree_list (NULL_TREE, NULL_TREE);
+  tree toid = build_tree_list (purpose, NULL_TREE);
+
+  /* define the label. Note: define_label needs to be called in
+     pass 1 and pass 2. */
+  TREE_VALUE (toid) = define_label (input_filename, lineno,
+				    get_unique_identifier ("CYCLE_label"));
+  if (! ignoring)
+    {
+      tree duration_value, now_location;
+      
+      if (t == NULL_TREE || TREE_CODE (t) == ERROR_MARK)
+	duration_value = convert (duration_timing_type_node, build_int_2 (0,0));
+      else
+	duration_value = t;
+      
+      if (TREE_TYPE (duration_value) != duration_timing_type_node)
+	{
+	  error ("duration primitive value must be of mode DURATION.");
+	  duration_value = convert (duration_timing_type_node, build_int_2 (0,0));
+	}
+      TREE_PURPOSE (TREE_PURPOSE (toid)) = duration_value;
+      /* define the variable */
+      now_location = decl_temp1 (get_unique_identifier ("CYCLE_var"),
+				 rtstime_type_node, 0,
+				 NULL_TREE, 0, 0);
+      TREE_VALUE (TREE_PURPOSE (toid)) = force_addr_of (now_location);
+      
+      /* build the call to __rtstime */
+      expand_expr_stmt (
+        build_chill_function_call (lookup_name (get_identifier ("__rtstime")),
+          build_tree_list (NULL_TREE, TREE_VALUE (TREE_PURPOSE (toid)))));
+    }
+
+  return toid;
+}
+
+void
+build_cycle_end (toid)
+     tree toid;
+{
+  tree filename, linenumber;
+  
+  /* here we call __check_cycle and then jump to beginning of this
+     action */
+  filename = force_addr_of (get_chill_filename ());
+  linenumber = get_chill_linenumber ();
+  expand_expr_stmt (
+    build_chill_function_call (
+      lookup_name (get_identifier ("__check_cycle")),
+	tree_cons (NULL_TREE, TREE_VALUE (TREE_PURPOSE (toid)),
+          tree_cons (NULL_TREE, TREE_PURPOSE (TREE_PURPOSE (toid)),
+	    tree_cons (NULL_TREE, filename,
+	      tree_cons (NULL_TREE, linenumber, NULL_TREE))))));
+  expand_goto (TREE_VALUE (toid));
+}
+
+#if 0
+ *
+ * build AFTER ACTION
+ *
+ * AFTER primval [ DELAY ] IN
+ *  action-list
+ * TIMEOUT
+ *  to-action-list
+ * END
+ *
+ * gets translated to
+ *
+ * {
+ *   struct chill_time __now; 
+ *   duration dur = primval; 
+ *   if (! delay_spceified)
+ *     __rts_time (&__now); 
+ *     .
+ *     .
+ *    goto end-label;
+ *   to-label:
+ *     .
+ *     .
+ *   end-label:
+ * }
+ *
+#endif
+
+void
+build_after_start (duration, delay_flag)
+    tree duration;
+    int  delay_flag;
+{
+  tree value, purpose;
+  
+  if (! ignoring)
+    {
+      value = tree_cons (NULL_TREE, NULL_TREE, NULL_TREE);
+      purpose = after_stack_pass_1;
+      after_stack_pass_1 = TREE_CHAIN (after_stack_pass_1);
+      after_stack = tree_cons (purpose, value, after_stack);
+      
+      if (TREE_TYPE (duration) != duration_timing_type_node)
+        {
+	  error ("duration primitive value must be of mode DURATION.");
+	  duration = convert (duration_timing_type_node, build_int_2 (0,0));
+        }
+      TREE_PURPOSE (value) = decl_temp1 (get_identifier ("AFTER_duration"),
+					 duration_timing_type_node, 0,
+					 duration, 0, 0);
+      
+      if (! delay_flag)
+        {
+	  /* in this case we have to get the current time */
+	  TREE_VALUE (value) = decl_temp1 (get_unique_identifier ("AFTER_now"),
+					   rtstime_type_node, 0,
+					   NULL_TREE, 0, 0);
+	  /* build the function call to initialize the variable */
+	  expand_expr_stmt (
+            build_chill_function_call (lookup_name (get_identifier ("__rtstime")),
+              build_tree_list (NULL_TREE, force_addr_of (TREE_VALUE (value)))));
+        }
+    }
+  else
+    {
+      /* in pass 1 we just save the labels */
+      after_help = tree_cons (NULL_TREE, NULL_TREE, after_help);
+      after_stack_pass_1 = chainon (after_stack_pass_1, after_help);
+    }
+}
+
+void
+build_after_timeout_start ()
+{
+  tree label_name, goto_where;
+  
+  if (! ignoring)
+    {
+      /* jump to the end of AFTER action */
+      lookup_and_expand_goto (TREE_PURPOSE (TREE_PURPOSE (after_stack)));
+      label_name = TREE_VALUE (TREE_PURPOSE (after_stack));
+      /* mark we are in TIMEOUT part of AFTER action */
+      TREE_VALUE (TREE_PURPOSE (after_stack)) = NULL_TREE;
+    }
+  else
+    {
+      label_name = get_unique_identifier ("AFTER_tolabel");
+      TREE_VALUE (after_help) = label_name;
+    }
+  define_label (input_filename, lineno, label_name);
+}
+
+void
+build_after_end ()
+{
+  tree label_name;
+    
+  /* define the end label */
+  if (! ignoring)
+    {
+      label_name = TREE_PURPOSE (TREE_PURPOSE (after_stack));
+      after_stack = TREE_CHAIN (after_stack);
+    }
+  else
+    {
+      label_name = get_unique_identifier ("AFTER_endlabel");
+      TREE_PURPOSE (after_help) = label_name;
+      after_help = TREE_CHAIN (after_help);
+    }
+  define_label (input_filename, lineno, label_name);
+}
+
+tree
+build_timeout_preface ()
+{
+  tree timeout_value = null_pointer_node;
+  
+  if (after_stack != NULL_TREE &&
+      TREE_VALUE (TREE_PURPOSE (after_stack)) != NULL_TREE)
+    {
+      tree to_loc;
+      
+      to_loc = decl_temp1 (get_unique_identifier ("TOloc"),
+			   rtstime_type_node, 0, NULL_TREE, 0, 0);
+      timeout_value = force_addr_of (to_loc);
+
+      if (TREE_VALUE (TREE_VALUE (after_stack)) == NULL_TREE)
+        {
+	  /* DELAY specified -- just call __convert_duration_rtstime for
+	     given duration value */
+	  expand_expr_stmt (
+            build_chill_function_call (
+              lookup_name (get_identifier ("__convert_duration_rtstime")),
+                tree_cons (NULL_TREE, TREE_PURPOSE (TREE_VALUE (after_stack)),
+                  tree_cons (NULL_TREE, timeout_value, NULL_TREE))));
+        }
+      else
+        {
+	  /* delay not specified -- call __remaintime which returns the 
+	     remaining time of duration in rtstime format and check the 
+	     result */
+	  tree fcall = 
+            build_chill_function_call (
+              lookup_name (get_identifier ("__remaintime")),
+                tree_cons (NULL_TREE, force_addr_of (TREE_VALUE (TREE_VALUE (after_stack))),
+		  tree_cons (NULL_TREE, TREE_PURPOSE (TREE_VALUE (after_stack)),
+                    tree_cons (NULL_TREE, timeout_value, NULL_TREE))));
+	  tree expr = build (NE_EXPR, integer_type_node,
+			     fcall, integer_zero_node);
+	  expand_start_cond (expr, 0);
+	  lookup_and_expand_goto (TREE_VALUE (TREE_PURPOSE (after_stack)));
+	  expand_end_cond ();
+        }
+    }
+  return timeout_value;
+}
+
+void
+build_timesupervised_call (fcall, to_loc)
+    tree fcall;
+    tree to_loc;
+{
+  if (to_loc == null_pointer_node)
+    expand_expr_stmt (fcall);
+  else
+    {
+      tree expr = build (NE_EXPR, integer_type_node, fcall, integer_zero_node);
+      expand_start_cond (expr, 0);
+      lookup_and_expand_goto (TREE_VALUE (TREE_PURPOSE (after_stack)));
+      expand_end_cond ();
+    }
+}