�

Migrate from devo/gcc/ch.

From-SVN: r22034

gcc/ch/actions.h

+/* Declarations for ch-actions.c.
+   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.  */
+
+/* used by compile_file */
+
+void init_chill PROTO((void));
+
+extern int grant_count;
+
+extern void push_handler PROTO((void));
+extern void pop_handler PROTO((int));
+extern void push_action PROTO((void));
+
+extern int  chill_handle_single_dimension_case_label PROTO((tree, tree, int *, int *));
+extern tree build_chill_multi_dimension_case_expr    PROTO((tree, tree, tree));
+extern tree build_multi_case_selector_expression     PROTO((tree, tree));
+extern void compute_else_ranges                      PROTO((tree, tree));

gcc/ch/except.c

+/* Exception support for GNU CHILL.
+   WARNING:  Only works for native (needs setjmp.h)!  FIXME!
+   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 "rtl.h"
+
+/* On Suns this can get you to the right definition if you
+   set the right value for TARGET.  */
+#include <setjmp.h>
+#ifdef sequent
+/* Can you believe they forgot this?  */
+#ifndef _JBLEN
+#define _JBLEN 11
+#endif
+#endif
+
+#ifndef _JBLEN
+#define _JBLEN (sizeof(jmp_buf)/sizeof(int))
+#define _JBLEN_2 _JBLEN+20
+#else
+/* if we use i.e. posix threads, this buffer must be longer */
+#define _JBLEN_2 _JBLEN+20
+#endif
+
+/* On Linux setjmp is __setjmp FIXME: what is for CROSS */
+#ifndef SETJMP_LIBRARY_NAME
+#ifdef __linux__
+#define SETJMP_LIBRARY_NAME "__setjmp"
+#else
+#define SETJMP_LIBRARY_NAME "setjmp"
+#endif
+#endif
+
+extern int  expand_exit_needed;
+extern tree build_chill_exception_decl PROTO((char *));
+extern void chill_handle_case_default  PROTO((void));
+extern void emit_jump                  PROTO((rtx));
+extern void expand_decl                PROTO((tree));
+extern void fatal                      PROTO((char *, ...));
+extern void make_decl_rtl              PROTO((tree, char *, int));
+extern void rest_of_decl_compilation   PROTO((tree, char *, int, int));
+
+static tree link_handler_decl;
+static tree handler_link_pointer_type;
+static tree unlink_handler_decl;
+static int exceptions_initialized = 0;
+static void emit_setup_handler PROTO((void));
+static void initialize_exceptions PROTO((void));
+static tree char_pointer_type_for_handler;
+
+/* If this is 1, operations to push and pop on the __exceptionStack
+   are inline.  The default is is to use a function call, to
+   allow for a per-thread exception stack. */
+static int inline_exception_stack_ops = 0;
+
+struct handler_state
+{
+  struct handler_state *next;
+
+  /* Starts at 0, then incremented for every <on-alternative>. */
+  int prev_on_alternative;
+
+  /* If > 0: handler number for ELSE handler. */
+  int else_handler;
+
+  int action_number;
+
+  char do_pushlevel;
+
+  tree on_alt_list;
+  tree setjmp_expr;
+
+  /* A decl for the static handler array (used to map exception name to int).*/
+  tree handler_array_decl;
+
+  rtx end_label;
+
+  /* Used to pass a tree from emit_setup_handler to chill_start_on. */
+  tree handler_ref;
+
+  tree unlink_cleanup;
+
+  tree function;
+
+  /* flag to indicate that we are currently compiling this handler.
+     is_handled will need this to determine an unhandled exception */
+  int compiling;
+};
+
+/* This is incremented by one each time we start an action which
+   might have an ON-handler.  It is reset between passes. */
+static int action_number = 0;
+
+int action_nesting_level = 0;
+
+/* The global_handler_list is constructed in pass 1.  It is not sorted.
+   It contains one element for each action that actually had an ON-handler.
+   An element's ACTION_NUMBER matches the action_number
+   of that action.  The global_handler_list is eaten up during pass 2. */
+#define ACTION_NUMBER(HANDLER) ((HANDLER)->action_number)
+struct handler_state *global_handler_list = NULL;
+
+/* This is a stack of handlers, one for each nested ON-handler. */
+static struct handler_state *current_handler = NULL;
+
+static struct handler_state *free_handlers = NULL; /* freelist */
+
+static tree handler_element_type;
+static tree handler_link_type;
+static tree BISJ;
+static tree jbuf_ident, prev_ident, handlers_ident;
+static tree exception_stack_decl = 0;
+
+/* Chain of cleanups assocated with exception handlers.
+   The TREE_PURPOSE is an INTEGER_CST whose value is the
+   DECL_ACTION_NESTING_LEVEL (when the handled actions was entered).
+   The TREE_VALUE is an expression to expand when we exit that action. */
+
+static tree cleanup_chain = NULL_TREE;
+
+#if 0
+/* Merge the current sequence onto the tail of the previous one. */
+
+void
+pop_sequence ()
+{
+  rtx sequence_first = get_insns ();
+
+  end_sequence ();
+  emit_insns (sequence_first);
+  
+}
+#endif
+
+/* Things we need to do at the beginning of pass 2. */
+
+void
+except_init_pass_2 ()
+{
+  /* First sort the global_handler_list on ACTION_NUMBER.
+     This will already be in close to reverse order (the exception being
+     nested ON-handlers), so insertion sort should essentially linear. */
+
+  register struct handler_state *old_list = global_handler_list;
+
+  /* First add a dummy final element. */
+  if (free_handlers)
+    global_handler_list = free_handlers;
+  else
+    global_handler_list
+      = (struct handler_state*) permalloc (sizeof (struct handler_state));
+  /* Make the final dummy "larger" than any other element. */
+  ACTION_NUMBER (global_handler_list) = action_number + 1;
+  /* Now move all the elements in old_list over to global_handler_list. */
+  while (old_list != NULL)
+    {
+      register struct handler_state **ptr = &global_handler_list;
+      /* Unlink from old_list. */
+      register struct handler_state *current = old_list;
+      old_list = old_list->next;
+
+      while (ACTION_NUMBER (current) > ACTION_NUMBER (*ptr))
+	ptr = &(*ptr)->next;
+      /* Link into proper place in global_handler_list (new list). */
+      current->next = *ptr;
+      *ptr = current;
+    }
+     
+  /* Don't forget to reset action_number. */
+  action_number = 0;
+}
+
+/* This function is called at the beginning of an action that might be
+   followed by an ON-handler.  Chill syntax doesn't let us know if
+   we actually have an ON-handler until we see the ON, so we save
+   away during pass 1 that information for use during pass 2. */
+
+void
+push_handler ()
+{
+  register struct handler_state *hstate;
+
+  action_number++;
+  action_nesting_level++;
+
+  if (pass == 1)
+    {
+      if (free_handlers)
+	{
+	  hstate = free_handlers;
+	  free_handlers = hstate->next;
+	}
+      else
+	{
+	  hstate =
+	    (struct handler_state*) permalloc (sizeof (struct handler_state));
+	}
+
+      hstate->next = current_handler;
+      current_handler = hstate;
+      hstate->prev_on_alternative = 0;
+      hstate->else_handler = 0;
+      hstate->on_alt_list = NULL_TREE;
+      hstate->compiling = 0;
+
+      ACTION_NUMBER (hstate) = action_number;
+      return;
+    }
+
+  if (ACTION_NUMBER (global_handler_list) != action_number)
+    return;
+
+  /* OK.  This action actually has an ON-handler.
+     Pop it from global_handler_list, and use it. */
+
+  hstate = global_handler_list;
+  global_handler_list = hstate->next;
+
+  /* Since this is pass 2, let's generate prologue code for that. */
+
+  hstate->next = current_handler;
+  current_handler = hstate;
+
+  hstate->prev_on_alternative = 0;
+  hstate->function = current_function_decl;
+
+  emit_setup_handler ();
+}
+
+static tree
+start_handler_array ()
+{
+  tree handler_array_type, decl;
+
+  push_obstacks_nochange ();
+  end_temporary_allocation ();
+  handler_array_type = build_array_type (handler_element_type, NULL_TREE);
+  decl = build_lang_decl (VAR_DECL,
+			  get_unique_identifier ("handler_table"),
+			  handler_array_type);
+
+/*  TREE_TYPE (decl) = handler_array_type;*/
+  TREE_READONLY (decl) = 1;
+  TREE_STATIC (decl) = 1;
+  DECL_INITIAL (decl) = error_mark_node;
+  
+  pushdecl (decl);
+  make_decl_rtl (decl, NULL_PTR, 0);
+  current_handler->handler_array_decl = decl;
+  return decl;
+}
+
+static void
+finish_handler_array ()
+{
+  tree decl = current_handler->handler_array_decl;
+  tree t;
+  tree handler_array_init = NULL_TREE;
+  int handlers_count = 1;
+  int nelts;
+
+  /* Build the table mapping exceptions to handler(-number)s.
+     This is done in reverse order. */
+  
+  /* First push the end of the list.  This is either the ELSE
+     handler (current_handler->else_handler>0) or NULL handler to indicate
+     the end of the list (if current_handler->else-handler == 0).
+     The following works either way. */
+  handler_array_init = build_tree_list
+    (NULL_TREE, chill_expand_tuple
+     (handler_element_type,
+      build_nt (CONSTRUCTOR, NULL_TREE,
+		tree_cons (NULL_TREE,
+			   null_pointer_node,
+			   build_tree_list (NULL_TREE,
+					    build_int_2 (current_handler->else_handler,
+							     0))))));
+  
+  for (t = current_handler->on_alt_list; t != NULL_TREE; t = TREE_CHAIN (t))
+    { tree handler_number = TREE_PURPOSE(t);
+      tree elist = TREE_VALUE (t);
+      for ( ; elist != NULL_TREE; elist = TREE_CHAIN (elist))
+	{
+	  tree ex_decl =
+	    build_chill_exception_decl (IDENTIFIER_POINTER(TREE_VALUE(elist)));
+	  tree ex_addr = build1 (ADDR_EXPR,
+				 char_pointer_type_for_handler,
+				 ex_decl);
+	  tree el = build_nt (CONSTRUCTOR, NULL_TREE,
+			      tree_cons (NULL_TREE,
+					 ex_addr,
+					 build_tree_list (NULL_TREE,
+							  handler_number)));
+	  mark_addressable (ex_decl);
+	  TREE_CONSTANT (ex_addr) = 1;
+	  handler_array_init =
+	    tree_cons (NULL_TREE,
+		       chill_expand_tuple (handler_element_type, el),
+		       handler_array_init);
+	  handlers_count++;
+	}
+    }
+
+#if 1
+  nelts = list_length (handler_array_init);
+  TYPE_DOMAIN (TREE_TYPE (decl))
+    = build_index_type (build_int_2 (nelts - 1, - (nelts == 0)));
+  layout_type (TREE_TYPE (decl));
+  DECL_INITIAL (decl)
+    = convert (TREE_TYPE (decl),
+	       build_nt (CONSTRUCTOR, NULL_TREE, handler_array_init));
+
+  /* Pop back to the obstack that is current for this binding level.
+     This is because MAXINDEX, rtl, etc. to be made below
+     must go in the permanent obstack.  But don't discard the
+     temporary data yet.  */
+  pop_obstacks ();
+  layout_decl (decl, 0);
+  /* To prevent make_decl_rtl (called indiectly by rest_of_decl_compilation)
+     throwing the existing RTL (which has already been used). */
+  PUT_MODE (DECL_RTL (decl), DECL_MODE (decl));
+  rest_of_decl_compilation (decl, (char*)0, 0, 0);
+  expand_decl_init (decl);
+#else
+  /* To prevent make_decl_rtl (called indirectly by finish_decl)
+     altering the existing RTL. */
+  GET_MODE (DECL_RTL (current_handler->handler_array_decl)) =
+    DECL_MODE (current_handler->handler_array_decl);
+
+  finish_decl (current_handler->handler_array_decl,
+	       build_nt (CONSTRUCTOR, NULL_TREE, handler_array_init),
+	       NULL_TREE);
+#endif
+}
+
+
+void
+pop_handler (used)
+     int used;
+{
+  action_nesting_level--;
+  if (pass == 1)
+    {
+      struct handler_state *old = current_handler;
+      if (old == NULL)
+	fatal ("internal error: on stack out of sync");
+      current_handler = old->next;
+
+      if (used)
+	{ /* Push unto global_handler_list. */
+	  old->next = global_handler_list;
+	  global_handler_list = old;
+	}
+      else
+	{
+	  /* Push onto free_handlers free list. */
+	  old->next = free_handlers;
+	  free_handlers = old;
+	}
+    }
+  else if (used)
+    {
+      current_handler = current_handler->next;
+    }
+}
+
+/* Emit code before an action that has an ON-handler. */
+
+static void
+emit_setup_handler ()
+{
+  tree handler_decl, handler_addr, t;
+
+  /* Field references. */
+  tree jbuf_ref, handlers_ref,prev_ref;
+  if (!exceptions_initialized)
+    {
+      /* We temporarily reset the maximum_field_alignment to zero so the
+	 compiler's exception data structures can be compatible with the
+	 run-time system, even when we're compiling with -fpack. */
+      extern int maximum_field_alignment;
+      int save_maximum_field_alignment = maximum_field_alignment;
+      maximum_field_alignment = 0;
+      push_obstacks_nochange ();
+      end_temporary_allocation ();
+      initialize_exceptions ();
+      pop_obstacks ();
+      maximum_field_alignment = save_maximum_field_alignment;
+    }
+
+  push_momentary ();
+
+  handler_decl = build_lang_decl (VAR_DECL,
+				  get_unique_identifier ("handler"),
+				  handler_link_type);
+  push_obstacks_nochange ();
+  pushdecl(handler_decl);
+  expand_decl (handler_decl);
+  finish_decl (handler_decl);
+
+  jbuf_ref = build_component_ref (handler_decl, jbuf_ident);
+  jbuf_ref = build_chill_arrow_expr (jbuf_ref, 1);
+  handlers_ref = build_component_ref (handler_decl, handlers_ident);
+  prev_ref = build_component_ref (handler_decl, prev_ident);
+
+  /* Emit code to link in handler in __exceptionStack chain. */
+  mark_addressable (handler_decl);
+  handler_addr = build1 (ADDR_EXPR, handler_link_pointer_type, handler_decl);
+  if (inline_exception_stack_ops)
+    {
+      expand_expr_stmt (build_chill_modify_expr (prev_ref,
+						 exception_stack_decl));
+      expand_expr_stmt (build_chill_modify_expr (exception_stack_decl,
+						 handler_addr));
+      current_handler->handler_ref = prev_ref;
+    }
+  else
+    {
+      expand_expr_stmt (build_chill_function_call (link_handler_decl,
+					     build_tree_list (NULL_TREE,
+							      handler_addr)));
+      current_handler->handler_ref = handler_addr;
+    }
+
+  /* Expand:  handler->__handlers = { <<array mapping names to ints } */
+  t =  build1 (NOP_EXPR, build_pointer_type (handler_element_type),
+	       build_chill_arrow_expr (start_handler_array (), 1));
+  expand_expr_stmt (build_chill_modify_expr (handlers_ref, t));
+
+  /* Emit code to unlink handler. */
+  if (inline_exception_stack_ops)
+    current_handler->unlink_cleanup
+      = build_chill_modify_expr (exception_stack_decl,
+				 current_handler->handler_ref);
+  else
+    current_handler->unlink_cleanup
+      = build_chill_function_call (unlink_handler_decl,
+				   build_tree_list(NULL_TREE,
+					       current_handler->handler_ref));
+  cleanup_chain = tree_cons (build_int_2 (action_nesting_level, 0),
+			     current_handler->unlink_cleanup,
+			     cleanup_chain);
+
+  /* Emit code for setjmp. */
+  
+  current_handler->setjmp_expr =
+    build_chill_function_call (BISJ, build_tree_list (NULL_TREE, jbuf_ref));
+  expand_start_case (1, current_handler->setjmp_expr,
+		     integer_type_node, "on handler");
+
+  chill_handle_case_label (integer_zero_node, current_handler->setjmp_expr);
+}
+
+/* Start emitting code for: <actions> ON <handlers> END.
+   Assume we've parsed <actions>, and the setup needed for it. */
+
+void
+chill_start_on ()
+{
+  expand_expr_stmt (current_handler->unlink_cleanup);
+
+  /* Emit code to jump past the handlers. */
+  current_handler->end_label = gen_label_rtx ();
+  current_handler->compiling = 1;
+  emit_jump (current_handler->end_label);
+}
+
+void
+chill_finish_on ()
+{
+  expand_end_case (current_handler->setjmp_expr);
+  
+  finish_handler_array ();
+
+  emit_label (current_handler->end_label);
+
+  pop_momentary ();
+
+  cleanup_chain = TREE_CHAIN (cleanup_chain);
+}
+
+void
+chill_handle_on_labels (labels)
+     tree labels;
+{
+  int alternative = ++current_handler->prev_on_alternative;
+  if (pass == 1)
+    {
+      tree handler_number = build_int_2 (alternative, 0);
+      current_handler->on_alt_list =
+	tree_cons (handler_number, labels, current_handler->on_alt_list);
+    }
+  else
+    {
+      /* Find handler_number saved in pass 1. */
+      tree tmp = current_handler->on_alt_list;
+      while (TREE_INT_CST_LOW (TREE_PURPOSE (tmp)) != alternative)
+	tmp = TREE_CHAIN (tmp);
+      if (expand_exit_needed)
+	expand_exit_something (), expand_exit_needed = 0;
+      chill_handle_case_label (TREE_PURPOSE (tmp),
+			       current_handler->setjmp_expr);
+    }
+}
+
+void
+chill_start_default_handler ()
+{
+  current_handler->else_handler = ++current_handler->prev_on_alternative;
+  if (!ignoring)
+    {
+      chill_handle_case_default ();
+    }
+}
+
+void
+chill_check_no_handlers ()
+{
+  if (current_handler != NULL)
+    fatal ("internal error: on stack not empty when done");
+}
+
+static void
+initialize_exceptions ()
+{
+  tree jmp_buf_type = build_array_type (integer_type_node,
+					build_index_type (build_int_2 (_JBLEN_2-1, 0)));
+  tree setjmp_fndecl, link_ftype;
+  tree parmtypes
+    = tree_cons (NULL_TREE, build_pointer_type (jmp_buf_type), void_list_node);
+
+  setjmp_fndecl = builtin_function ("setjmp",
+				    build_function_type (integer_type_node,
+							 parmtypes),
+				    NOT_BUILT_IN,
+				    SETJMP_LIBRARY_NAME);
+  BISJ = build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (setjmp_fndecl)),
+		 setjmp_fndecl);
+ 
+  char_pointer_type_for_handler
+    = build_pointer_type (build_type_variant (char_type_node, 1, 0));
+  handler_element_type =
+    build_chill_struct_type (chainon
+			     (build_decl (FIELD_DECL,
+					  get_identifier("__exceptid"),
+					  char_pointer_type_for_handler),
+			      build_decl (FIELD_DECL,
+					  get_identifier("__handlerno"),
+					  integer_type_node)));
+
+  jbuf_ident = get_identifier("__jbuf");
+  prev_ident = get_identifier("__prev");
+  handlers_ident = get_identifier("__handlers");
+
+  handler_link_type =
+    build_chill_struct_type
+      (chainon
+       (build_decl (FIELD_DECL, prev_ident, ptr_type_node),
+	chainon
+	(build_decl (FIELD_DECL, handlers_ident,
+		     build_pointer_type (handler_element_type)),
+	 build_decl (FIELD_DECL, jbuf_ident, jmp_buf_type))));
+
+  handler_link_pointer_type = build_pointer_type (handler_link_type);
+
+  if (inline_exception_stack_ops)
+    {
+      exception_stack_decl =
+	build_lang_decl (VAR_DECL,
+			 get_identifier("__exceptionStack"),
+			 handler_link_pointer_type);
+      TREE_STATIC (exception_stack_decl) = 1;
+      TREE_PUBLIC (exception_stack_decl) = 1;
+      DECL_EXTERNAL (exception_stack_decl) = 1;
+      push_obstacks_nochange ();
+      pushdecl(exception_stack_decl);
+      make_decl_rtl (exception_stack_decl, NULL_PTR, 1);
+      finish_decl (exception_stack_decl);
+    }
+
+  link_ftype = build_function_type (void_type_node,
+				    tree_cons (NULL_TREE,
+					       handler_link_pointer_type,
+					       void_list_node));
+  link_handler_decl = builtin_function ("__ch_link_handler", link_ftype,
+					NOT_BUILT_IN, NULL_PTR);
+  unlink_handler_decl = builtin_function ("__ch_unlink_handler", link_ftype,
+					  NOT_BUILT_IN, NULL_PTR);
+
+  exceptions_initialized = 1;
+}
+
+/* Do the cleanup(s) needed for a GOTO label.
+   We only need to do the last of the cleanups. */
+
+void
+expand_goto_except_cleanup (label_level)
+     int label_level;
+{
+  tree list = cleanup_chain;
+  tree last = NULL_TREE;
+  for ( ; list != NULL_TREE; list = TREE_CHAIN (list))
+    {
+      if (TREE_INT_CST_LOW (TREE_PURPOSE (list)) > label_level)
+	last = list;
+      else
+	break;
+    }
+  if (last)
+    expand_expr_stmt (TREE_VALUE (last));
+}
+
+/* Returns true if there is a valid handler for EXCEPT_NAME
+   in the current static scope.
+   0 ... no handler found
+   1 ... local handler available
+   2 ... function may propagate this exception
+*/
+
+int
+is_handled (except_name)
+     tree except_name;
+{
+  tree t;
+  struct handler_state *h = current_handler;
+
+  /* if we are are currently compiling this handler
+     we have to start at the next level */
+  if (h && h->compiling)
+    h = h->next;
+  while (h != NULL)
+    {
+      if (h->function != current_function_decl)
+	break;
+      if (h->else_handler > 0)
+	return 1;
+      for (t = h->on_alt_list; t != NULL_TREE; t = TREE_CHAIN (t))
+	{
+	  if (value_member (except_name, TREE_VALUE (t)))
+	    return 1;
+	}
+      h = h->next;
+    }
+
+  t = TYPE_RAISES_EXCEPTIONS (TREE_TYPE (current_function_decl));
+
+  if (value_member (except_name, t))
+    return 2;
+  return 0;
+}
+
+/* function generates code to reraise exceptions
+   for PROC's propagating exceptions. */
+
+void
+chill_reraise_exceptions (exceptions)
+     tree exceptions;
+{
+  tree wrk;
+
+  if (exceptions == NULL_TREE)
+    return; /* just in case */
+
+  if (pass == 1)
+    {
+      for (wrk = exceptions; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
+	chill_handle_on_labels (build_tree_list (NULL_TREE, TREE_VALUE (wrk)));
+    }
+  else /* pass == 2 */
+    {
+      chill_start_on ();
+      expand_exit_needed = 0;
+
+      for (wrk = exceptions; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
+	{
+	  chill_handle_on_labels (TREE_VALUE (wrk));
+	  /* do a CAUSE exception */
+	  expand_expr_stmt (build_cause_exception (TREE_VALUE (wrk), 0));
+	  expand_exit_needed = 1;
+	}
+      chill_finish_on ();
+    }
+  pop_handler (1);
+}

gcc/ch/grant.c

+/* Implement grant-file output & seize-file input for CHILL.
+   Copyright (C) 1992, 93, 94, 95, 1996 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 <string.h>
+#include <limits.h>
+#include "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include "flags.h"
+#include "actions.h"
+#include "input.h"
+#include "errno.h"
+#include "rtl.h"
+#include "tasking.h"
+
+/* Disable possible macro over-rides, so the externs parse
+   portably. */
+#undef strchr
+#undef strrchr
+
+#define APPEND(X,Y) X = append (X, Y)
+#define PREPEND(X,Y) X = prepend (X, Y);
+#define FREE(x) strfree (x)
+#define ALLOCAMOUNT	10000
+/* may be we can handle this in a more exciting way,
+   but this also should work for the moment */
+#define MAYBE_NEWLINE(X)                       \
+do                                             \
+{                                              \
+  if (X->len && X->str[X->len - 1] != '\n')    \
+    APPEND (X, ";\n");                         \
+} while (0)
+
+extern void assemble_constructor PROTO((char *));
+extern void assemble_name PROTO((FILE *, char *));
+extern void error PROTO((char *, ...));
+extern tree tasking_list;
+extern void tasking_registry PROTO((void));
+extern void tasking_setup PROTO((void));
+extern void build_enum_tables PROTO((void));
+extern tree process_type;
+extern void warning PROTO((char *, ...));
+extern tree get_file_function_name PROTO((int));
+extern char *asm_file_name;
+extern char *dump_base_name;
+
+/* forward declarations */
+
+/* variable indicates compilation at module level */
+int chill_at_module_level = 0;
+
+
+/* mark that a SPEC MODULE was generated */
+static int spec_module_generated = 0;
+
+/* define version strings */
+extern char *gnuchill_version;
+extern char *version_string;
+
+/* define a faster string handling */
+typedef struct
+{
+  char	*str;
+  int		len;
+  int		allocated;
+} MYSTRING;
+
+/* structure used for handling multiple grant files */
+char	*grant_file_name;
+MYSTRING	*gstring = NULL;
+MYSTRING        *selective_gstring = NULL;
+
+static MYSTRING *decode_decl                PROTO((tree));
+static MYSTRING *decode_constant            PROTO((tree));
+static void      grant_one_decl             PROTO((tree));
+static MYSTRING *get_type                   PROTO((tree));
+static MYSTRING *decode_mode                PROTO((tree));
+static MYSTRING *decode_prefix_rename       PROTO((tree));
+static MYSTRING *decode_constant_selective  PROTO((tree, tree));
+static MYSTRING *decode_mode_selective      PROTO((tree, tree));
+static MYSTRING *get_type_selective         PROTO((tree, tree));
+static MYSTRING *decode_decl_selective      PROTO((tree, tree));
+
+/* list of the VAR_DECLs of the module initializer entries */
+tree      module_init_list = NULL_TREE;
+
+/* handle different USE_SEIZE_FILE's in case of selective granting */
+typedef struct SEIZEFILELIST
+{
+  struct SEIZEFILELIST *next;
+  tree filename;
+  MYSTRING *seizes;
+} seizefile_list;
+
+static seizefile_list *selective_seizes = 0;
+
+
+static MYSTRING *
+newstring (str)
+    char	*str;
+{
+    MYSTRING	*tmp = (MYSTRING *) xmalloc (sizeof (MYSTRING));
+    unsigned	len = strlen (str);
+    
+    tmp->allocated = len + ALLOCAMOUNT;
+    tmp->str = xmalloc ((unsigned)tmp->allocated);
+    strcpy (tmp->str, str);
+    tmp->len = len;
+    return (tmp);
+}
+
+static void
+strfree (str)
+    MYSTRING	*str;
+{
+    free (str->str);
+    free (str);
+}
+
+static MYSTRING *
+append (inout, in)
+    MYSTRING	*inout;
+    char	*in;
+{
+    int	inlen = strlen (in);
+    int amount = ALLOCAMOUNT;
+
+    if (inlen >= amount)
+      amount += inlen;
+    if ((inout->len + inlen) >= inout->allocated)
+	inout->str = xrealloc (inout->str, inout->allocated += amount);
+    strcpy (inout->str + inout->len, in);
+    inout->len += inlen;
+    return (inout);
+}
+
+static MYSTRING *
+prepend (inout, in)
+    MYSTRING	*inout;
+    char	*in;
+{
+  MYSTRING *res = inout;
+  if (strlen (in))
+    {
+      res = newstring (in);
+      res = APPEND (res, inout->str);
+      FREE (inout);
+    }
+  return res;
+}
+
+void
+grant_use_seizefile (seize_filename)
+     char *seize_filename;
+{
+  APPEND (gstring, "<> USE_SEIZE_FILE \"");
+  APPEND (gstring, seize_filename);
+  APPEND (gstring, "\" <>\n");
+}
+
+static MYSTRING *
+decode_layout (layout)
+    tree layout;
+{
+  tree temp;
+  tree stepsize = NULL_TREE;
+  int  was_step = 0;
+  MYSTRING *result = newstring ("");
+  MYSTRING *work;
+
+  if (layout == integer_zero_node) /* NOPACK */
+    {
+      APPEND (result, " NOPACK");
+      return result;
+    }
+
+  if (layout == integer_one_node) /* PACK */
+    {
+      APPEND (result, " PACK");
+      return result;
+    }
+
+  APPEND (result, " ");
+  temp = layout;
+  if (TREE_PURPOSE (temp) == NULL_TREE)
+    {
+      APPEND (result, "STEP(");
+      was_step = 1;
+      temp = TREE_VALUE (temp);
+      stepsize = TREE_VALUE (temp);
+    }
+  APPEND (result, "POS(");
+
+  /* Get the starting word */
+  temp = TREE_PURPOSE (temp);
+  work = decode_constant (TREE_PURPOSE (temp));
+  APPEND (result, work->str);
+  FREE (work);
+
+  temp = TREE_VALUE (temp);
+  if (temp != NULL_TREE)
+    {
+      /* Get the starting bit */
+      APPEND (result, ", ");
+      work = decode_constant (TREE_PURPOSE (temp));
+      APPEND (result, work->str);
+      FREE (work);
+
+      temp = TREE_VALUE (temp);
+      if (temp != NULL_TREE)
+	{
+	  /* Get the length or the ending bit */
+	  tree what = TREE_PURPOSE (temp);
+	  if (what == integer_zero_node) /* length */
+	    {
+	      APPEND (result, ", ");
+	    }
+	  else
+	    {
+	      APPEND (result, ":");
+	    }
+	  work = decode_constant (TREE_VALUE (temp));
+	  APPEND (result, work->str);
+	  FREE (work);
+	}
+    }
+  APPEND (result, ")");
+
+  if (was_step)
+    {
+      if (stepsize != NULL_TREE)
+	{
+	  APPEND (result, ", ");
+	  work = decode_constant (stepsize);
+	  APPEND (result, work->str);
+	  FREE (work);
+	}
+      APPEND (result, ")");
+    }
+
+  return result;
+}
+
+static MYSTRING *
+grant_array_type (type)
+     tree type;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+  tree           layout;
+  int            varying = 0;
+
+  if (chill_varying_type_p (type))
+    {
+      varying = 1;
+      type = CH_VARYING_ARRAY_TYPE (type);
+    }
+  if (CH_STRING_TYPE_P (type))
+    {
+      tree fields = TYPE_DOMAIN (type);
+      tree maxval = TYPE_MAX_VALUE (fields);
+
+      if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
+	APPEND (result, "CHARS (");
+      else
+	APPEND (result, "BOOLS (");
+      if (TREE_CODE (maxval) == INTEGER_CST)
+	{
+	  char	wrk[20];
+	  sprintf (wrk, "%d", TREE_INT_CST_LOW (maxval) + 1);
+	  APPEND (result, wrk);
+	}
+      else if (TREE_CODE (maxval) == MINUS_EXPR
+	       && TREE_OPERAND (maxval, 1) == integer_one_node)
+	{
+	  mode_string = decode_constant (TREE_OPERAND (maxval, 0));
+	  APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	}
+      else
+	{
+	  mode_string = decode_constant (maxval);
+	  APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	  APPEND (result, "+1");
+	}
+      APPEND (result, ")");
+      if (varying)
+	APPEND (result, " VARYING");
+      return result;
+    }
+
+  APPEND (result, "ARRAY (");
+  if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
+     && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
+    {
+      mode_string = decode_constant (TYPE_MIN_VALUE (TYPE_DOMAIN (type)));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      
+      APPEND (result, ":");
+      mode_string = decode_constant (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+    }
+  else
+    {
+      mode_string = decode_mode (TYPE_DOMAIN (type));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+    }
+  APPEND (result, ") ");
+  if (varying)
+    APPEND (result, "VARYING ");
+
+  mode_string = get_type (TREE_TYPE (type));
+  APPEND (result, mode_string->str);
+  FREE (mode_string);
+
+  layout = TYPE_ATTRIBUTES (type);
+  if (layout != NULL_TREE)
+    {
+      mode_string = decode_layout (layout);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+    }
+    
+  return result;
+}
+
+static MYSTRING *
+grant_array_type_selective (type, all_decls)
+     tree type;
+     tree all_decls;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+  int            varying = 0;
+
+  if (chill_varying_type_p (type))
+    {
+      varying = 1;
+      type = CH_VARYING_ARRAY_TYPE (type);
+    }
+  if (CH_STRING_TYPE_P (type))
+    {
+      tree fields = TYPE_DOMAIN (type);
+      tree maxval = TYPE_MAX_VALUE (fields);
+
+      if (TREE_CODE (maxval) != INTEGER_CST)
+	{
+	  if (TREE_CODE (maxval) == MINUS_EXPR
+	      && TREE_OPERAND (maxval, 1) == integer_one_node)
+	    {
+	      mode_string = decode_constant_selective (TREE_OPERAND (maxval, 0), all_decls);
+	      if (mode_string->len)
+		APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  else
+	    {
+	      mode_string = decode_constant_selective (maxval, all_decls);
+	      if (mode_string->len)
+		APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	}
+      return result;
+    }
+
+  if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
+     && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
+    {
+      mode_string = decode_constant_selective (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      
+      mode_string = decode_constant_selective (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), all_decls);
+      if (mode_string->len)
+	{
+	  MAYBE_NEWLINE (result);
+	  APPEND (result, mode_string->str);
+	}
+      FREE (mode_string);
+    }
+  else
+    {
+      mode_string = decode_mode_selective (TYPE_DOMAIN (type), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+    }
+
+  mode_string = get_type_selective (TREE_TYPE (type),  all_decls);
+  if (mode_string->len)
+    {
+      MAYBE_NEWLINE (result);
+      APPEND (result, mode_string->str);
+    }
+  FREE (mode_string);
+
+  return result;
+}
+
+static MYSTRING *
+get_tag_value (val)
+    tree	val;
+{
+  MYSTRING	*result;
+    
+  if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
+    {
+      result = newstring (IDENTIFIER_POINTER (DECL_NAME (val)));
+    }
+  else if (TREE_CODE (val) == CONST_DECL)
+    {
+      /* it's a synonym -- get the value */
+      result = decode_constant (DECL_INITIAL (val));
+    }
+  else
+    {
+      result = decode_constant (val);
+    }
+  return (result);
+}
+
+static MYSTRING *
+get_tag_value_selective (val, all_decls)
+    tree	val;
+    tree        all_decls;
+{
+  MYSTRING	*result;
+    
+  if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
+      result = newstring ("");
+  else if (TREE_CODE (val) == CONST_DECL)
+    {
+      /* it's a synonym -- get the value */
+      result = decode_constant_selective (DECL_INITIAL (val), all_decls);
+    }
+  else
+    {
+      result = decode_constant_selective (val, all_decls);
+    }
+  return (result);
+}
+
+static MYSTRING *
+print_enumeral (type)
+     tree type;
+{
+  MYSTRING	*result = newstring ("");
+  tree	fields;
+
+#if 0
+  if (TYPE_LANG_SPECIFIC (type) == NULL)
+#endif
+    {
+      
+      APPEND (result, "SET (");
+      for (fields = TYPE_VALUES (type);
+	   fields != NULL_TREE;
+	   fields = TREE_CHAIN (fields))
+	{
+	  if (TREE_PURPOSE (fields) == NULL_TREE)
+	    APPEND (result, "*");
+	  else
+	    {
+	      tree decl = TREE_VALUE (fields);
+	      APPEND (result, IDENTIFIER_POINTER (TREE_PURPOSE (fields)));
+	      if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
+		{
+		  MYSTRING *val_string = decode_constant (DECL_INITIAL (decl));
+		  APPEND (result, " = ");
+		  APPEND (result, val_string->str);
+		  FREE (val_string);
+		}
+	    }
+	  if (TREE_CHAIN (fields) != NULL_TREE)
+	    APPEND (result, ",\n     ");
+	}
+      APPEND (result, ")");
+    }
+  return result;
+}
+
+static MYSTRING *
+print_enumeral_selective (type, all_decls)
+     tree type;
+     tree all_decls;
+{
+  MYSTRING	*result = newstring ("");
+  tree	fields;
+
+  for (fields = TYPE_VALUES (type);
+       fields != NULL_TREE;
+       fields = TREE_CHAIN (fields))
+    {
+      if (TREE_PURPOSE (fields) != NULL_TREE)
+	{
+	  tree decl = TREE_VALUE (fields);
+	  if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
+	    {
+	      MYSTRING *val_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
+	      if (val_string->len)
+		APPEND (result, val_string->str);
+	      FREE (val_string);
+	    }
+	}
+    }
+  return result;
+}
+
+static MYSTRING *
+print_integer_type (type)
+     tree type;
+{
+  MYSTRING *result = newstring ("");
+  MYSTRING *mode_string;
+  char     *name_ptr;
+  tree	    base_type;
+
+  if (TREE_TYPE (type))
+    {
+      mode_string = decode_mode (TREE_TYPE (type));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      
+      APPEND (result, "(");
+      mode_string = decode_constant (TYPE_MIN_VALUE (type));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+
+      if (TREE_TYPE (type) != ridpointers[(int) RID_BIN])
+	{
+	  APPEND (result, ":");
+	  mode_string = decode_constant (TYPE_MAX_VALUE (type));
+	  APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	}
+
+      APPEND (result, ")");
+      return result;
+    }
+  /* We test TYPE_MAIN_VARIANT because pushdecl often builds
+     a copy of a built-in type node, which is logically id-
+     entical but has a different address, and the same
+     TYPE_MAIN_VARIANT. */
+  /* FIXME this should not be needed! */
+
+  base_type = TREE_TYPE (type) ? TREE_TYPE (type) : type;
+
+  if (TREE_UNSIGNED (base_type))
+    {
+      if (base_type == chill_unsigned_type_node
+	  || TYPE_MAIN_VARIANT(base_type) ==
+	     TYPE_MAIN_VARIANT (chill_unsigned_type_node))
+	name_ptr = "UINT";
+      else if (base_type == long_integer_type_node
+	       || TYPE_MAIN_VARIANT(base_type) ==
+	          TYPE_MAIN_VARIANT (long_unsigned_type_node))
+	name_ptr = "ULONG";
+      else if (type == unsigned_char_type_node
+	       || TYPE_MAIN_VARIANT(base_type) ==
+	          TYPE_MAIN_VARIANT (unsigned_char_type_node))
+	name_ptr = "UBYTE";
+      else if (type == duration_timing_type_node
+	       || TYPE_MAIN_VARIANT (base_type) ==
+	          TYPE_MAIN_VARIANT (duration_timing_type_node))
+	name_ptr = "DURATION";
+      else if (type == abs_timing_type_node
+	       || TYPE_MAIN_VARIANT (base_type) ==
+	          TYPE_MAIN_VARIANT (abs_timing_type_node))
+	name_ptr = "TIME";
+      else
+	name_ptr = "UINT";
+    }
+  else
+    {
+      if (base_type == chill_integer_type_node
+	  || TYPE_MAIN_VARIANT (base_type) ==
+	     TYPE_MAIN_VARIANT (chill_integer_type_node))
+	name_ptr = "INT";
+      else if (base_type == long_integer_type_node
+	       || TYPE_MAIN_VARIANT (base_type) ==
+	          TYPE_MAIN_VARIANT (long_integer_type_node))
+	name_ptr = "LONG";
+      else if (type == signed_char_type_node
+	       || TYPE_MAIN_VARIANT (base_type) ==
+	          TYPE_MAIN_VARIANT (signed_char_type_node))
+	name_ptr = "BYTE";
+      else
+	name_ptr = "INT";
+    }
+  
+  APPEND (result, name_ptr);
+  
+  /* see if we have a range */
+  if (TREE_TYPE (type) != NULL)
+    {
+      mode_string = decode_constant (TYPE_MIN_VALUE (type));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      APPEND (result, ":");
+      mode_string = decode_constant (TYPE_MAX_VALUE (type));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+    }
+
+  return result;
+}
+
+static tree
+find_enum_parent (enumname, all_decls)
+     tree enumname;
+     tree all_decls;
+{
+  tree wrk;
+
+  for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
+    {
+      if (TREE_TYPE (wrk) != NULL_TREE && TREE_CODE (wrk) != CONST_DECL &&
+	  TREE_CODE (TREE_TYPE (wrk)) == ENUMERAL_TYPE)
+	{
+	  tree list;
+	  for (list = TYPE_VALUES (TREE_TYPE (wrk)); list != NULL_TREE; list = TREE_CHAIN (list))
+	    {
+	      if (DECL_NAME (TREE_VALUE (list)) == enumname)
+		return wrk;
+	    }
+	}
+    }
+  return NULL_TREE;
+}
+
+static MYSTRING *
+print_integer_selective (type, all_decls)
+     tree type;
+     tree all_decls;
+{
+  MYSTRING *result = newstring ("");
+  MYSTRING *mode_string;
+
+  if (TREE_TYPE (type))
+    {
+      mode_string = decode_mode_selective (TREE_TYPE (type), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+
+      if (TREE_TYPE (type) == ridpointers[(int)RID_RANGE] &&
+	  TREE_CODE (TYPE_MIN_VALUE (type)) == IDENTIFIER_NODE &&
+	  TREE_CODE (TYPE_MAX_VALUE (type)) == IDENTIFIER_NODE)
+	{
+	  /* we have a range of a set. Find parant mode and write it
+	     to SPEC MODULE. This will loose if the parent mode was SEIZED from
+	     another file.*/
+	  tree minparent = find_enum_parent (TYPE_MIN_VALUE (type), all_decls);
+	  tree maxparent = find_enum_parent (TYPE_MAX_VALUE (type), all_decls);
+
+	  if (minparent != NULL_TREE)
+	    {
+	      if (! CH_ALREADY_GRANTED (minparent))
+		{
+		  mode_string = decode_decl (minparent);
+		  if (mode_string->len)
+		    APPEND (result, mode_string->str);
+		  FREE (mode_string);
+		  CH_ALREADY_GRANTED (minparent) = 1;
+		}
+	    }
+	  if (minparent != maxparent && maxparent != NULL_TREE)
+	    {
+	      if (!CH_ALREADY_GRANTED (maxparent))
+		{
+		  mode_string = decode_decl (maxparent);
+		  if (mode_string->len)
+		    {
+		      MAYBE_NEWLINE (result);
+		      APPEND (result, mode_string->str);
+		    }
+		  FREE (mode_string);
+		  CH_ALREADY_GRANTED (maxparent) = 1;
+		}
+	    }
+	}
+      else
+	{
+	  mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
+	  if (mode_string->len)
+	    {
+	      MAYBE_NEWLINE (result);
+	      APPEND (result, mode_string->str);
+	    }
+	  FREE (mode_string);
+	  
+	  mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
+	  if (mode_string->len)
+	    {
+	      MAYBE_NEWLINE (result);
+	      APPEND (result, mode_string->str);
+	    }
+	  FREE (mode_string);
+	}
+      return result;
+    }
+
+  /* see if we have a range */
+  if (TREE_TYPE (type) != NULL)
+    {
+      mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+
+      mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
+      if (mode_string->len)
+	{
+	  MAYBE_NEWLINE (result);
+	  APPEND (result, mode_string->str);
+	}
+      FREE (mode_string);
+    }
+
+  return result;
+}
+
+static MYSTRING *
+print_struct (type)
+     tree type;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+  tree	fields;
+
+  if (chill_varying_type_p (type))
+    {
+      mode_string = grant_array_type (type);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+    }
+  else
+    {
+      fields = TYPE_FIELDS (type);
+      
+      APPEND (result, "STRUCT (");
+      while (fields != NULL_TREE)
+	{
+	  if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
+	    {
+	      tree variants;
+	      /* Format a tagged variant record type.  */
+	      APPEND (result, " CASE ");
+	      if (TYPE_TAGFIELDS (TREE_TYPE (fields)) != NULL_TREE)
+		{
+		  tree tag_list = TYPE_TAGFIELDS (TREE_TYPE (fields));
+		  for (;;)
+		    {
+		      tree tag_name = DECL_NAME (TREE_VALUE (tag_list));
+		      APPEND (result, IDENTIFIER_POINTER (tag_name));
+		      tag_list = TREE_CHAIN (tag_list);
+		      if (tag_list == NULL_TREE)
+			break;
+		      APPEND (result, ", ");
+		    }
+		}
+	      APPEND (result, " OF\n");
+	      variants = TYPE_FIELDS (TREE_TYPE (fields));
+	      
+	      /* Each variant is a FIELD_DECL whose type is an anonymous
+		 struct within the anonymous union.  */
+	      while (variants != NULL_TREE)
+		{
+		  tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
+		  tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
+		  
+		  while (tag_list != NULL_TREE)
+		    {
+		      tree tag_values = TREE_VALUE (tag_list);
+		      APPEND (result, "   (");
+		      while (tag_values != NULL_TREE)
+			{
+			  mode_string = get_tag_value (TREE_VALUE (tag_values));
+			  APPEND (result, mode_string->str);
+			  FREE (mode_string);
+			  if (TREE_CHAIN (tag_values) != NULL_TREE)
+			    {
+			      APPEND (result, ",\n    ");
+			      tag_values = TREE_CHAIN (tag_values);
+			    }
+			  else break;
+			}
+		      APPEND (result, ")");
+		      tag_list = TREE_CHAIN (tag_list);
+		      if (tag_list)
+			APPEND (result, ",");
+		      else
+			break;
+		    }
+		  APPEND (result, " : ");
+		  
+		  while (struct_elts != NULL_TREE)
+		    {
+		      mode_string = decode_decl (struct_elts);
+		      APPEND (result, mode_string->str);
+		      FREE (mode_string);
+		      
+		      if (TREE_CHAIN (struct_elts) != NULL_TREE)
+			APPEND (result, ",\n     ");
+		      struct_elts = TREE_CHAIN (struct_elts);
+		    }
+		  
+		  variants = TREE_CHAIN (variants);
+		  if (variants != NULL_TREE
+		      && TREE_CHAIN (variants) == NULL_TREE
+		      && DECL_NAME (variants) == ELSE_VARIANT_NAME)
+		    {
+		      tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
+		      APPEND (result, "\n   ELSE ");
+		      while (else_elts != NULL_TREE)
+			{
+			  mode_string = decode_decl (else_elts);
+			  APPEND (result, mode_string->str);
+			  FREE (mode_string);
+			  if (TREE_CHAIN (else_elts) != NULL_TREE)
+			    APPEND (result, ",\n     ");
+			  else_elts = TREE_CHAIN (else_elts);
+			}
+		      break;
+		    }
+		  if (variants != NULL_TREE)
+		    APPEND (result, ",\n");
+		}
+	      
+	      APPEND (result, "\n   ESAC");
+	    }
+	  else
+	    {
+	      mode_string = decode_decl (fields);
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  
+	  fields = TREE_CHAIN (fields);
+	  if (fields != NULL_TREE)
+	    APPEND (result, ",\n    ");
+	}
+      APPEND (result, ")");
+    }
+  return result;
+}
+
+static MYSTRING *
+print_struct_selective (type, all_decls)
+     tree type;
+     tree all_decls;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+  tree	fields;
+
+  if (chill_varying_type_p (type))
+    {
+      mode_string = grant_array_type_selective (type, all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+    }
+  else
+    {
+      fields = TYPE_FIELDS (type);
+      
+      while (fields != NULL_TREE)
+	{
+	  if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
+	    {
+	      tree variants;
+	      /* Format a tagged variant record type.  */
+
+	      variants = TYPE_FIELDS (TREE_TYPE (fields));
+	      
+	      /* Each variant is a FIELD_DECL whose type is an anonymous
+		 struct within the anonymous union.  */
+	      while (variants != NULL_TREE)
+		{
+		  tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
+		  tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
+		  
+		  while (tag_list != NULL_TREE)
+		    {
+		      tree tag_values = TREE_VALUE (tag_list);
+		      while (tag_values != NULL_TREE)
+			{
+			  mode_string = get_tag_value_selective (TREE_VALUE (tag_values),
+								 all_decls);
+			  if (mode_string->len)
+			    {
+			      MAYBE_NEWLINE (result);
+			      APPEND (result, mode_string->str);
+			    }
+			  FREE (mode_string);
+			  if (TREE_CHAIN (tag_values) != NULL_TREE)
+			      tag_values = TREE_CHAIN (tag_values);
+			  else break;
+			}
+		      tag_list = TREE_CHAIN (tag_list);
+		      if (!tag_list)
+			break;
+		    }
+		  
+		  while (struct_elts != NULL_TREE)
+		    {
+		      mode_string = decode_decl_selective (struct_elts, all_decls);
+		      if (mode_string->len)
+			{
+			  MAYBE_NEWLINE (result);
+			  APPEND (result, mode_string->str);
+			}
+		      FREE (mode_string);
+		      
+		      struct_elts = TREE_CHAIN (struct_elts);
+		    }
+		  
+		  variants = TREE_CHAIN (variants);
+		  if (variants != NULL_TREE
+		      && TREE_CHAIN (variants) == NULL_TREE
+		      && DECL_NAME (variants) == ELSE_VARIANT_NAME)
+		    {
+		      tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
+		      while (else_elts != NULL_TREE)
+			{
+			  mode_string = decode_decl_selective (else_elts, all_decls);
+			  if (mode_string->len)
+			    {
+			      MAYBE_NEWLINE (result);
+			      APPEND (result, mode_string->str);
+			    }
+			  FREE (mode_string);
+			  else_elts = TREE_CHAIN (else_elts);
+			}
+		      break;
+		    }
+		}
+	    }
+	  else
+	    {
+	      mode_string = decode_decl_selective (fields, all_decls);
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  
+	  fields = TREE_CHAIN (fields);
+	}
+    }
+  return result;
+}
+
+static MYSTRING *
+print_proc_exceptions (ex)
+     tree ex;
+{
+  MYSTRING	*result = newstring ("");
+
+  if (ex != NULL_TREE)
+    {
+      APPEND (result, "\n  EXCEPTIONS (");
+      for ( ; ex != NULL_TREE; ex = TREE_CHAIN (ex))
+	{
+	  APPEND (result, IDENTIFIER_POINTER (TREE_VALUE (ex)));
+	  if (TREE_CHAIN (ex) != NULL_TREE)
+	    APPEND (result, ",\n    ");
+	}
+      APPEND (result, ")");
+    }
+  return result;
+}
+
+static MYSTRING *
+print_proc_tail (type, args, print_argnames)
+     tree type;
+     tree args;
+     int print_argnames;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+  int count = 0;
+  int stopat = list_length (args) - 3;
+
+  /* do the argument modes */
+  for ( ; args != NULL_TREE; 
+       args = TREE_CHAIN (args), count++)
+    {
+      char buf[20];
+      tree argmode = TREE_VALUE (args);
+      tree attribute = TREE_PURPOSE (args);
+
+      if (argmode == void_type_node)
+	continue;
+
+      /* if we have exceptions don't print last 2 arguments */
+      if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
+	break;
+      
+      if (count)
+	APPEND (result, ",\n       ");
+      if (print_argnames)
+	{
+	  sprintf(buf, "arg%d ", count);
+	  APPEND (result, buf);
+	}
+
+      if (attribute == ridpointers[(int) RID_LOC])
+	argmode = TREE_TYPE (argmode);
+      mode_string = get_type (argmode);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+
+      if (attribute != NULL_TREE)
+	{
+	  sprintf (buf, " %s", IDENTIFIER_POINTER (attribute));
+	  APPEND (result, buf);
+	}
+    }
+  APPEND (result, ")");
+  
+  /* return type */
+  {
+    tree retn_type = TREE_TYPE (type);
+
+    if (retn_type != NULL_TREE
+	&& TREE_CODE (retn_type) != VOID_TYPE)
+      {
+	mode_string = get_type (retn_type);
+	APPEND (result, "\n  RETURNS (");
+	APPEND (result, mode_string->str);
+	FREE (mode_string);
+	if (TREE_CODE (retn_type) == REFERENCE_TYPE)
+	  APPEND (result, " LOC");
+	APPEND (result, ")");
+      }
+  }
+
+  mode_string = print_proc_exceptions (TYPE_RAISES_EXCEPTIONS (type));
+  APPEND (result, mode_string->str);
+  FREE (mode_string);
+	
+  return result;
+}
+
+static MYSTRING *
+print_proc_tail_selective (type, args, all_decls)
+     tree type;
+     tree args;
+     tree all_decls;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+  int count = 0;
+  int stopat = list_length (args) - 3;
+
+  /* do the argument modes */
+  for ( ; args != NULL_TREE; 
+       args = TREE_CHAIN (args), count++)
+    {
+      tree argmode = TREE_VALUE (args);
+      tree attribute = TREE_PURPOSE (args);
+
+      if (argmode == void_type_node)
+	continue;
+
+      /* if we have exceptions don't process last 2 arguments */
+      if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
+	break;
+      
+      if (attribute == ridpointers[(int) RID_LOC])
+	argmode = TREE_TYPE (argmode);
+      mode_string = get_type_selective (argmode, all_decls);
+      if (mode_string->len)
+	{
+	  MAYBE_NEWLINE (result);
+	  APPEND (result, mode_string->str);
+	}
+      FREE (mode_string);
+    }
+  
+  /* return type */
+  {
+    tree retn_type = TREE_TYPE (type);
+
+    if (retn_type != NULL_TREE
+	&& TREE_CODE (retn_type) != VOID_TYPE)
+      {
+	mode_string = get_type_selective (retn_type, all_decls);
+	if (mode_string->len)
+	  {
+	    MAYBE_NEWLINE (result);
+	    APPEND (result, mode_string->str);
+	  }
+	FREE (mode_string);
+      }
+  }
+	
+  return result;
+}
+
+/* output a mode (or type). */
+
+static MYSTRING *
+decode_mode (type)
+    tree type;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+
+  switch ((enum chill_tree_code)TREE_CODE (type))
+    {
+    case TYPE_DECL:
+      if (DECL_NAME (type))
+	{
+	  APPEND (result, IDENTIFIER_POINTER (DECL_NAME (type)));
+	  return result;
+	}
+      type = TREE_TYPE (type);
+      break;
+
+    case IDENTIFIER_NODE:
+      APPEND (result, IDENTIFIER_POINTER (type));
+      return result;
+
+    case LANG_TYPE:
+      /* LANG_TYPE are only used until satisfy is done,
+	 as place-holders for 'READ T', NEWMODE/SYNMODE modes,
+	 parameterised modes, and old-fashioned CHAR(N). */
+      if (TYPE_READONLY (type))
+	APPEND (result, "READ ");
+
+      mode_string = get_type (TREE_TYPE (type));
+      APPEND (result, mode_string->str);
+      if (TYPE_DOMAIN (type) != NULL_TREE)
+	{
+	  /* Parameterized mode,
+	     or old-fashioned CHAR(N) string declaration.. */
+	  APPEND (result, "(");
+	  mode_string = decode_constant (TYPE_DOMAIN (type));
+	  APPEND (result, mode_string->str);
+	  APPEND (result, ")");
+	}
+      FREE (mode_string);
+      break;
+
+    case ARRAY_TYPE:
+      mode_string = grant_array_type (type);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+
+    case BOOLEAN_TYPE:
+      APPEND (result, "BOOL");
+      break;
+
+    case CHAR_TYPE:
+      APPEND (result, "CHAR");
+      break;
+
+    case ENUMERAL_TYPE:
+      mode_string = print_enumeral (type); 
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+	
+    case FUNCTION_TYPE:
+      {
+	tree args = TYPE_ARG_TYPES (type);
+
+	APPEND (result, "PROC (");
+
+	mode_string = print_proc_tail (type, args, 0);
+	APPEND (result, mode_string->str);
+	FREE (mode_string);
+      }
+      break;
+
+    case INTEGER_TYPE:
+      mode_string = print_integer_type (type);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+	
+    case RECORD_TYPE:
+      if (CH_IS_INSTANCE_MODE (type))
+	{
+	  APPEND (result, "INSTANCE");
+	  return result;
+	}
+      else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
+	{ tree bufsize = max_queue_size (type);
+	  APPEND (result, CH_IS_BUFFER_MODE (type) ? "BUFFER " : "EVENT ");
+	  if (bufsize != NULL_TREE)
+	    {
+	      APPEND (result, "(");
+	      mode_string = decode_constant (bufsize);
+	      APPEND (result, mode_string->str);
+	      APPEND (result, ") ");
+	      FREE (mode_string);
+	    }
+	  if (CH_IS_BUFFER_MODE (type))
+	    {
+	      mode_string = decode_mode (buffer_element_mode (type));
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  break;
+	}
+      else if (CH_IS_ACCESS_MODE (type))
+	{
+	  tree indexmode, recordmode, dynamic;
+
+	  APPEND (result, "ACCESS");
+	  recordmode = access_recordmode (type);
+	  indexmode = access_indexmode (type);
+	  dynamic = access_dynamic (type);
+
+	  if (indexmode != void_type_node)
+	    {
+	      mode_string = decode_mode (indexmode);
+	      APPEND (result, " (");
+	      APPEND (result, mode_string->str);
+	      APPEND (result, ")");
+	      FREE (mode_string);
+	    }
+	  if (recordmode != void_type_node)
+	    {
+	      mode_string = decode_mode (recordmode);
+	      APPEND (result, " ");
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  if (dynamic != integer_zero_node)
+	    APPEND (result, " DYNAMIC");
+	  break;
+	}
+      else if (CH_IS_TEXT_MODE (type))
+	{
+	  tree indexmode, dynamic, length;
+
+	  APPEND (result, "TEXT (");
+	  length = text_length (type);
+	  indexmode = text_indexmode (type);
+	  dynamic = text_dynamic (type);
+
+	  mode_string = decode_constant (length);
+	  APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	  APPEND (result, ")");
+	  if (indexmode != void_type_node)
+	    {
+	      APPEND (result, " ");
+	      mode_string = decode_mode (indexmode);
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  if (dynamic != integer_zero_node)
+	    APPEND (result, " DYNAMIC");
+	  return result;
+	}
+      mode_string = print_struct (type);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+
+    case POINTER_TYPE:
+      if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
+	APPEND (result, "PTR");
+      else
+	{
+	  if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
+	    {
+	      mode_string = get_type (TREE_TYPE (type));
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  else
+	    {
+	      APPEND (result, "REF ");
+	      mode_string = get_type (TREE_TYPE (type));
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	}
+      break;
+
+    case REAL_TYPE:
+      if (TREE_INT_CST_LOW (TYPE_SIZE (type)) == 32)
+	APPEND (result, "REAL");
+      else
+	APPEND (result, "LONG_REAL");
+      break;
+
+    case SET_TYPE:
+      if (CH_BOOLS_TYPE_P (type))
+	mode_string = grant_array_type (type);
+      else
+	{
+	  APPEND (result, "POWERSET ");
+	  mode_string = get_type (TYPE_DOMAIN (type));
+	}
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+	
+    case REFERENCE_TYPE:
+      mode_string = get_type (TREE_TYPE (type));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+      
+    default:
+      APPEND (result, "/* ---- not implemented ---- */");
+      break;
+    }
+
+  return (result);
+}
+
+static tree
+find_in_decls (id, all_decls)
+     tree id;
+     tree all_decls;
+{
+  tree wrk;
+
+  for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
+    {
+      if (DECL_NAME (wrk) == id || DECL_POSTFIX (wrk) == id)
+	return wrk;
+    }
+  return NULL_TREE;
+}
+
+static int
+in_ridpointers (id)
+     tree id;
+{
+  int i;
+  for (i = RID_UNUSED; i < RID_MAX; i++)
+    {
+      if (id == ridpointers[i])
+	return 1;
+    }
+  return 0;
+}
+
+static void
+grant_seized_identifier (decl)
+     tree decl;
+{
+  seizefile_list *wrk = selective_seizes;
+  MYSTRING *mode_string;
+
+  CH_ALREADY_GRANTED (decl) = 1;
+
+  /* comes from a SPEC MODULE in the module */
+  if (DECL_SEIZEFILE (decl) == NULL_TREE)
+    return;
+
+  /* search file already in process */
+  while (wrk != 0)
+    {
+      if (wrk->filename == DECL_SEIZEFILE (decl))
+	break;
+      wrk = wrk->next;
+    }
+  if (!wrk)
+    {
+      wrk = (seizefile_list *)xmalloc (sizeof (seizefile_list));
+      wrk->next = selective_seizes;
+      selective_seizes = wrk;
+      wrk->filename = DECL_SEIZEFILE (decl);
+      wrk->seizes = newstring ("<> USE_SEIZE_FILE \"");
+      APPEND (wrk->seizes, IDENTIFIER_POINTER (DECL_SEIZEFILE (decl)));
+      APPEND (wrk->seizes, "\" <>\n");
+    }
+  APPEND (wrk->seizes, "SEIZE ");
+  mode_string = decode_prefix_rename (decl);
+  APPEND (wrk->seizes, mode_string->str);
+  FREE (mode_string);
+  APPEND (wrk->seizes, ";\n");
+}
+
+static MYSTRING *
+decode_mode_selective (type, all_decls)
+    tree type;
+    tree all_decls;
+{
+  MYSTRING	*result = newstring ("");
+  MYSTRING	*mode_string;
+  tree decl;
+
+  switch ((enum chill_tree_code)TREE_CODE (type))
+    {
+    case TYPE_DECL:
+      /* FIXME: could this ever happen ?? */
+      if (DECL_NAME (type))
+	{
+	  FREE (result);
+	  result = decode_mode_selective (DECL_NAME (type), all_decls);
+	  return result;
+	}
+      break;
+
+    case IDENTIFIER_NODE:
+      if (in_ridpointers (type))
+	/* it's a predefined, we must not search the whole list */
+	return result;
+
+      decl = find_in_decls (type, all_decls);
+      if (decl != NULL_TREE)
+	{
+	  if (CH_ALREADY_GRANTED (decl))
+	    /* already processed */
+	    return result;
+
+	  if (TREE_CODE (decl) == ALIAS_DECL && DECL_POSTFIX (decl) != NULL_TREE)
+	    {
+	      /* If CH_DECL_GRANTED, decl was granted into this scope, and
+		 so wasn't in the source code. */
+	      if (!CH_DECL_GRANTED (decl))
+		{
+		  grant_seized_identifier (decl);
+		}
+	    }
+	  else
+	    {
+	      result = decode_decl (decl);
+	      mode_string = decode_decl_selective (decl, all_decls);
+	      if (mode_string->len)
+		{
+		  PREPEND (result, mode_string->str);
+		}
+	      FREE (mode_string);
+	    }
+	}
+      return result;
+
+    case LANG_TYPE:
+      mode_string = get_type_selective (TREE_TYPE (type), all_decls);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+
+    case ARRAY_TYPE:
+      mode_string = grant_array_type_selective (type, all_decls);
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+
+    case BOOLEAN_TYPE:
+      return result;
+      break;
+
+    case CHAR_TYPE:
+      return result;
+      break;
+
+    case ENUMERAL_TYPE:
+      mode_string = print_enumeral_selective (type, all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+	
+    case FUNCTION_TYPE:
+      {
+	tree args = TYPE_ARG_TYPES (type);
+
+	mode_string = print_proc_tail_selective (type, args, all_decls);
+	if (mode_string->len)
+	  APPEND (result, mode_string->str);
+	FREE (mode_string);
+      }
+      break;
+
+    case INTEGER_TYPE:
+      mode_string = print_integer_selective (type, all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+	
+    case RECORD_TYPE:
+      if (CH_IS_INSTANCE_MODE (type))
+	{
+	  return result;
+	}
+      else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
+	{
+	  tree bufsize = max_queue_size (type);
+	  if (bufsize != NULL_TREE)
+	    {
+	      mode_string = decode_constant_selective (bufsize, all_decls);
+	      if (mode_string->len)
+		APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  if (CH_IS_BUFFER_MODE (type))
+	    {
+	      mode_string = decode_mode_selective (buffer_element_mode (type), all_decls);
+	      if (mode_string->len)
+		{
+		  MAYBE_NEWLINE (result);
+		  APPEND (result, mode_string->str);
+		}
+	      FREE (mode_string);
+	    }
+	  break;
+	}      
+      else if (CH_IS_ACCESS_MODE (type))
+	{
+	  tree indexmode = access_indexmode (type);
+	  tree recordmode = access_recordmode (type);
+	      
+	  if (indexmode != void_type_node)
+	    {
+	      mode_string = decode_mode_selective (indexmode, all_decls);
+	      if (mode_string->len)
+		{
+		  if (result->len && result->str[result->len - 1] != '\n')
+		    APPEND (result, ";\n");
+		  APPEND (result, mode_string->str);
+		}
+	      FREE (mode_string);
+	    }
+	  if (recordmode != void_type_node)
+	    {
+	      mode_string = decode_mode_selective (recordmode, all_decls);
+	      if (mode_string->len)
+		{
+		  if (result->len && result->str[result->len - 1] != '\n')
+		    APPEND (result, ";\n");
+		  APPEND (result, mode_string->str);
+		}
+	      FREE (mode_string);
+	    }
+	  break;
+	}
+      else if (CH_IS_TEXT_MODE (type))
+	{
+	  tree indexmode = text_indexmode (type);
+	  tree length = text_length (type);
+
+	  mode_string = decode_constant_selective (length, all_decls);
+	  if (mode_string->len)
+	    APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	  if (indexmode != void_type_node)
+	    {
+	      mode_string = decode_mode_selective (indexmode, all_decls);
+	      if (mode_string->len)
+		{
+		  if (result->len && result->str[result->len - 1] != '\n')
+		    APPEND (result, ";\n");
+		  APPEND (result, mode_string->str);
+		}
+	      FREE (mode_string);
+	    }
+	  break;
+	}
+      mode_string = print_struct_selective (type, all_decls);
+      if (mode_string->len)
+	{
+	  MAYBE_NEWLINE (result);
+	  APPEND (result, mode_string->str);
+	}
+      FREE (mode_string);
+      break;
+
+    case POINTER_TYPE:
+      if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
+	break;
+      else
+	{
+	  if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
+	    {
+	      mode_string = get_type_selective (TREE_TYPE (type), all_decls);
+	      if (mode_string->len)
+		APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  else
+	    {
+	      mode_string = get_type_selective (TREE_TYPE (type), all_decls);
+	      if (mode_string->len)
+		APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	}
+      break;
+
+    case REAL_TYPE:
+      return result;
+      break;
+
+    case SET_TYPE:
+      if (CH_BOOLS_TYPE_P (type))
+	mode_string = grant_array_type_selective (type, all_decls);
+      else
+	mode_string = get_type_selective (TYPE_DOMAIN (type), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+	
+    case REFERENCE_TYPE:
+      mode_string = get_type_selective (TREE_TYPE (type), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+      
+    default:
+      APPEND (result, "/* ---- not implemented ---- */");
+      break;
+    }
+
+  return (result);
+}
+
+static MYSTRING *
+get_type (type)
+    tree	type;
+{
+  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+    return newstring ("");
+
+  return (decode_mode (type));
+}
+
+static MYSTRING *
+get_type_selective (type, all_decls)
+    tree	type;
+    tree        all_decls;
+{
+  if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
+    return newstring ("");
+
+  return (decode_mode_selective (type, all_decls));
+}
+
+#if 0
+static int
+is_forbidden (str, forbid)
+    tree	str;
+    tree	forbid;
+{
+  if (forbid == NULL_TREE)
+    return (0);
+  
+  if (TREE_CODE (forbid) == INTEGER_CST)
+    return (1);
+  
+  while (forbid != NULL_TREE)
+    {
+      if (TREE_VALUE (forbid) == str)
+	return (1);
+      forbid = TREE_CHAIN (forbid);
+    }
+  /* nothing found */
+  return (0);
+}
+#endif
+
+static MYSTRING *
+decode_constant (init)
+     tree	init;
+{
+  MYSTRING *result = newstring ("");
+  MYSTRING *tmp_string;
+  tree	    type = TREE_TYPE (init);
+  tree	val = init;
+  char *op;
+  char	wrk[256];
+  MYSTRING *mode_string;
+    
+  switch ((enum chill_tree_code)TREE_CODE (val))
+    {
+    case CALL_EXPR:
+      tmp_string = decode_constant (TREE_OPERAND (val, 0));
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      val = TREE_OPERAND (val, 1);  /* argument list */
+      if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
+	{
+	  APPEND (result, " ");
+	  tmp_string = decode_constant (val);
+	  APPEND (result, tmp_string->str);
+	  FREE (tmp_string);
+	}
+      else
+	{
+	  APPEND (result, " (");
+	  if (val != NULL_TREE)
+	    {
+	      for (;;)
+		{
+		  tmp_string = decode_constant (TREE_VALUE (val));
+		  APPEND (result, tmp_string->str);
+		  FREE (tmp_string);
+		  val = TREE_CHAIN (val);
+		  if (val == NULL_TREE)
+		    break;
+		  APPEND (result, ", ");
+		}
+	    }
+	  APPEND (result, ")");
+	}
+      return result;
+
+    case NOP_EXPR:
+      /* Generate an "expression conversion" expression (a cast). */
+      tmp_string = decode_mode (type);
+
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      APPEND (result, "(");
+      val = TREE_OPERAND (val, 0);
+      type = TREE_TYPE (val);
+
+      /* If the coercee is a tuple, make sure it is prefixed by its mode. */
+      if (TREE_CODE (val) == CONSTRUCTOR
+	&& !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
+	{
+	  tmp_string = decode_mode (type);
+	  APPEND (result, tmp_string->str);
+	  FREE (tmp_string);
+	  APPEND (result, " ");
+	}
+
+      tmp_string = decode_constant (val);
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      APPEND (result, ")");
+      return result;
+
+    case IDENTIFIER_NODE:
+      APPEND (result, IDENTIFIER_POINTER (val));
+      return result;
+
+    case PAREN_EXPR:
+      APPEND (result, "(");
+      tmp_string = decode_constant (TREE_OPERAND (val, 0));
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      APPEND (result, ")");
+      return result;
+
+    case UNDEFINED_EXPR:
+      APPEND (result, "*");
+      return result;
+
+    case PLUS_EXPR:        op = "+";       goto binary;
+    case MINUS_EXPR:       op = "-";       goto binary;
+    case MULT_EXPR:        op = "*";       goto binary;
+    case TRUNC_DIV_EXPR:   op = "/";       goto binary;
+    case FLOOR_MOD_EXPR:   op = " MOD ";   goto binary;
+    case TRUNC_MOD_EXPR:   op = " REM ";   goto binary;
+    case CONCAT_EXPR:      op = "//";      goto binary;
+    case BIT_IOR_EXPR:     op = " OR ";    goto binary;
+    case BIT_XOR_EXPR:     op = " XOR ";   goto binary;
+    case TRUTH_ORIF_EXPR:  op = " ORIF ";  goto binary;
+    case BIT_AND_EXPR:     op = " AND ";   goto binary;
+    case TRUTH_ANDIF_EXPR: op = " ANDIF "; goto binary;
+    case GT_EXPR:          op = ">";       goto binary;
+    case GE_EXPR:          op = ">=";      goto binary;
+    case SET_IN_EXPR:      op = " IN ";    goto binary;
+    case LT_EXPR:          op = "<";       goto binary;
+    case LE_EXPR:          op = "<=";      goto binary;
+    case EQ_EXPR:          op = "=";       goto binary;
+    case NE_EXPR:          op = "/=";      goto binary;
+    case RANGE_EXPR:
+      if (TREE_OPERAND (val, 0) == NULL_TREE)
+	{
+	  APPEND (result, TREE_OPERAND (val, 1) == NULL_TREE ? "*" : "ELSE");
+	  return result;
+	}
+      op = ":";       goto binary;
+    binary:
+      tmp_string = decode_constant (TREE_OPERAND (val, 0));
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      APPEND (result, op);
+      tmp_string = decode_constant (TREE_OPERAND (val, 1));
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      return result;
+
+    case REPLICATE_EXPR:
+      APPEND (result, "(");
+      tmp_string = decode_constant (TREE_OPERAND (val, 0));
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      APPEND (result, ")");
+      tmp_string = decode_constant (TREE_OPERAND (val, 1));
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      return result;
+
+    case NEGATE_EXPR:     op = "-";     goto unary;
+    case BIT_NOT_EXPR:    op = " NOT "; goto unary;
+    case ADDR_EXPR:       op = "->"; goto unary;
+    unary:
+      APPEND (result, op);
+      tmp_string = decode_constant (TREE_OPERAND (val, 0));
+      APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      return result;
+
+    case INTEGER_CST:
+      APPEND (result, display_int_cst (val));
+      return result;
+
+    case REAL_CST:
+#ifndef REAL_IS_NOT_DOUBLE
+      sprintf (wrk, "%.20g", TREE_REAL_CST (val));
+#else
+      REAL_VALUE_TO_DECIMAL (TREE_REAL_CST (val), "%.20g", wrk);
+#endif
+      APPEND (result, wrk);
+      return result;
+
+    case STRING_CST:
+      {
+	char *ptr = TREE_STRING_POINTER (val);
+	int i = TREE_STRING_LENGTH (val);
+	APPEND (result, "\"");
+	while (--i >= 0)
+	  {
+	    char buf[10];
+	    unsigned char c = *ptr++;
+	    if (c == '^')
+	      APPEND (result, "^^");
+	    else if (c == '"')
+	      APPEND (result, "\"\"");
+	    else if (c == '\n')
+	      APPEND (result, "^J");
+	    else if (c < ' ' || c > '~')
+	      {
+		sprintf (buf, "^(%u)", c);
+		APPEND (result, buf);
+	      }
+	    else
+	      {
+		buf[0] = c;
+		buf[1] = 0;
+		APPEND (result, buf);
+	      }
+	  }
+	APPEND (result, "\"");
+	return result;
+      }
+
+    case CONSTRUCTOR:
+      val = TREE_OPERAND (val, 1);
+      if (type != NULL && TREE_CODE (type) == SET_TYPE
+	  && CH_BOOLS_TYPE_P (type))
+	{
+	  /* It's a bitstring. */
+	  tree domain = TYPE_DOMAIN (type);
+	  tree domain_max = TYPE_MAX_VALUE (domain);
+	  char *buf;
+	  register char *ptr;
+	  int len;
+	  if (TREE_CODE (domain_max) != INTEGER_CST
+	      || (val && TREE_CODE (val) != TREE_LIST))
+	    goto fail;
+
+	  len = TREE_INT_CST_LOW (domain_max) + 1;
+	  if (TREE_CODE (init) != CONSTRUCTOR)
+	    goto fail;
+	  buf = (char *) alloca (len + 10);
+	  ptr = buf;
+	  *ptr++ = ' ';	  
+	  *ptr++ = 'B';
+	  *ptr++ = '\'';
+	  if (get_set_constructor_bits (init, ptr, len))
+	    goto fail;
+	  for (; --len >= 0; ptr++)
+	    *ptr += '0';
+	  *ptr++ = '\'';
+	  *ptr = '\0';
+	  APPEND (result, buf);
+	  return result;
+	}
+      else
+	{ /* It's some kind of tuple */
+	  if (type != NULL_TREE)
+	    {
+	      mode_string = get_type (type);
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	      APPEND (result, " ");
+	    }
+	  if (val == NULL_TREE
+	      || TREE_CODE (val) == ERROR_MARK)
+	    APPEND (result, "[ ]");
+	  else if (TREE_CODE (val) != TREE_LIST)
+	    goto fail;
+	  else
+	    {
+	      APPEND (result, "[");
+	      for ( ; ; )
+		{
+		  tree lo_val = TREE_PURPOSE (val);
+		  tree hi_val = TREE_VALUE (val);
+		  MYSTRING *val_string;
+		  if (TUPLE_NAMED_FIELD (val))
+		    APPEND(result, ".");
+		  if (lo_val != NULL_TREE)
+		    {
+		      val_string = decode_constant (lo_val);
+		      APPEND (result, val_string->str);
+		      FREE (val_string);
+		      APPEND (result, ":");
+		    }
+		  val_string = decode_constant (hi_val);
+		  APPEND (result, val_string->str);
+		  FREE (val_string);
+		  val = TREE_CHAIN (val);
+		  if (val == NULL_TREE)
+		    break;
+		  APPEND (result, ", ");
+		}
+	      APPEND (result, "]");
+	    }
+	}
+      return result;
+    case COMPONENT_REF:
+      {
+	tree op1;
+
+	mode_string = decode_constant (TREE_OPERAND (init, 0));
+	APPEND (result, mode_string->str);
+	FREE (mode_string);
+	op1 = TREE_OPERAND (init, 1);
+	if (TREE_CODE (op1) != IDENTIFIER_NODE)
+	  {
+	    error ("decode_constant: invalid component_ref");
+	    break;
+	  }
+	APPEND (result, ".");
+	APPEND (result, IDENTIFIER_POINTER (op1));
+	return result;
+      }
+    fail:
+      error ("decode_constant: mode and value mismatch");
+      break;
+    default:
+      error ("decode_constant: cannot decode this mode");
+      break;
+    }
+  return result;
+}
+
+static MYSTRING *
+decode_constant_selective (init, all_decls)
+     tree	init;
+     tree       all_decls;
+{
+  MYSTRING *result = newstring ("");
+  MYSTRING *tmp_string;
+  tree	    type = TREE_TYPE (init);
+  tree	val = init;
+  char *op;
+  char	wrk[256];
+  MYSTRING *mode_string;
+    
+  switch ((enum chill_tree_code)TREE_CODE (val))
+    {
+    case CALL_EXPR:
+      tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      val = TREE_OPERAND (val, 1);  /* argument list */
+      if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
+	{
+	  tmp_string = decode_constant_selective (val, all_decls);
+	  if (tmp_string->len)
+	    {
+	      MAYBE_NEWLINE (result);
+	      APPEND (result, tmp_string->str);
+	    }
+	  FREE (tmp_string);
+	}
+      else
+	{
+	  if (val != NULL_TREE)
+	    {
+	      for (;;)
+		{
+		  tmp_string = decode_constant_selective (TREE_VALUE (val), all_decls);
+		  if (tmp_string->len)
+		    {
+		      MAYBE_NEWLINE (result);
+		      APPEND (result, tmp_string->str);
+		    }
+		  FREE (tmp_string);
+		  val = TREE_CHAIN (val);
+		  if (val == NULL_TREE)
+		    break;
+		}
+	    }
+	}
+      return result;
+
+    case NOP_EXPR:
+      /* Generate an "expression conversion" expression (a cast). */
+      tmp_string = decode_mode_selective (type, all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      val = TREE_OPERAND (val, 0);
+      type = TREE_TYPE (val);
+
+      /* If the coercee is a tuple, make sure it is prefixed by its mode. */
+      if (TREE_CODE (val) == CONSTRUCTOR
+	&& !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
+	{
+	  tmp_string = decode_mode_selective (type, all_decls);
+	  if (tmp_string->len)
+	    APPEND (result, tmp_string->str);
+	  FREE (tmp_string);
+	}
+
+      tmp_string = decode_constant_selective (val, all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      return result;
+
+    case IDENTIFIER_NODE:
+      tmp_string = decode_mode_selective (val, all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      return result;
+
+    case PAREN_EXPR:
+      tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      return result;
+
+    case UNDEFINED_EXPR:
+      return result;
+
+    case PLUS_EXPR:
+    case MINUS_EXPR:
+    case MULT_EXPR:
+    case TRUNC_DIV_EXPR:
+    case FLOOR_MOD_EXPR:
+    case TRUNC_MOD_EXPR:
+    case CONCAT_EXPR:
+    case BIT_IOR_EXPR:
+    case BIT_XOR_EXPR:
+    case TRUTH_ORIF_EXPR:
+    case BIT_AND_EXPR:
+    case TRUTH_ANDIF_EXPR:
+    case GT_EXPR:
+    case GE_EXPR:
+    case SET_IN_EXPR:
+    case LT_EXPR:
+    case LE_EXPR:
+    case EQ_EXPR:
+    case NE_EXPR:
+      goto binary;
+    case RANGE_EXPR:
+      if (TREE_OPERAND (val, 0) == NULL_TREE)
+	  return result;
+
+    binary:
+      tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
+      if (tmp_string->len)
+	{
+	  MAYBE_NEWLINE (result);
+	  APPEND (result, tmp_string->str);
+	}
+      FREE (tmp_string);
+      return result;
+
+    case REPLICATE_EXPR:
+      tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
+      if (tmp_string->len)
+	{
+	  MAYBE_NEWLINE (result);
+	  APPEND (result, tmp_string->str);
+	}
+      FREE (tmp_string);
+      return result;
+
+    case NEGATE_EXPR:
+    case BIT_NOT_EXPR:
+    case ADDR_EXPR:
+      tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
+      if (tmp_string->len)
+	APPEND (result, tmp_string->str);
+      FREE (tmp_string);
+      return result;
+
+    case INTEGER_CST:
+      return result;
+
+    case REAL_CST:
+      return result;
+
+    case STRING_CST:
+      return result;
+
+    case CONSTRUCTOR:
+      val = TREE_OPERAND (val, 1);
+      if (type != NULL && TREE_CODE (type) == SET_TYPE
+	  && CH_BOOLS_TYPE_P (type))
+	  /* It's a bitstring. */
+	  return result;
+      else
+	{ /* It's some kind of tuple */
+	  if (type != NULL_TREE)
+	    {
+	      mode_string = get_type_selective (type, all_decls);
+	      if (mode_string->len)
+		APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	  if (val == NULL_TREE
+	      || TREE_CODE (val) == ERROR_MARK)
+	    return result;
+	  else if (TREE_CODE (val) != TREE_LIST)
+	    goto fail;
+	  else
+	    {
+	      for ( ; ; )
+		{
+		  tree lo_val = TREE_PURPOSE (val);
+		  tree hi_val = TREE_VALUE (val);
+		  MYSTRING *val_string;
+		  if (lo_val != NULL_TREE)
+		    {
+		      val_string = decode_constant_selective (lo_val, all_decls);
+		      if (val_string->len)
+			APPEND (result, val_string->str);
+		      FREE (val_string);
+		    }
+		  val_string = decode_constant_selective (hi_val, all_decls);
+		  if (val_string->len)
+		    {
+		      MAYBE_NEWLINE (result);
+		      APPEND (result, val_string->str);
+		    }
+		  FREE (val_string);
+		  val = TREE_CHAIN (val);
+		  if (val == NULL_TREE)
+		    break;
+		}
+	    }
+	}
+      return result;
+    case COMPONENT_REF:
+      {
+	mode_string = decode_constant_selective (TREE_OPERAND (init, 0), all_decls);
+	if (mode_string->len)
+	  APPEND (result, mode_string->str);
+	FREE (mode_string);
+	return result;
+      }
+    fail:
+      error ("decode_constant_selective: mode and value mismatch");
+      break;
+    default:
+      error ("decode_constant_selective: cannot decode this mode");
+      break;
+    }
+  return result;
+}
+
+/* Assuming DECL is an ALIAS_DECL, return its prefix rename clause. */
+
+static MYSTRING *
+decode_prefix_rename (decl)
+    tree decl;
+{
+  MYSTRING *result = newstring ("");
+  if (DECL_OLD_PREFIX (decl) || DECL_NEW_PREFIX (decl))
+    {
+      APPEND (result, "(");
+      if (DECL_OLD_PREFIX (decl))
+	APPEND (result, IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl)));
+      APPEND (result, "->");
+      if (DECL_NEW_PREFIX (decl))
+ 	APPEND (result, IDENTIFIER_POINTER (DECL_NEW_PREFIX (decl)));
+      APPEND (result, ")!");
+    }
+  if (DECL_POSTFIX_ALL (decl))
+    APPEND (result, "ALL");
+  else
+    APPEND (result, IDENTIFIER_POINTER  (DECL_POSTFIX (decl)));
+  return result;
+}
+
+static MYSTRING *
+decode_decl (decl)
+    tree decl;
+{
+  MYSTRING *result = newstring ("");
+  MYSTRING *mode_string;
+  tree      type;
+  
+  switch ((enum chill_tree_code)TREE_CODE (decl))
+    {
+    case VAR_DECL:
+    case BASED_DECL:
+      APPEND (result, "DCL ");
+      APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
+      APPEND (result, " ");
+      mode_string = get_type (TREE_TYPE (decl));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
+        {
+          APPEND (result, " BASED (");
+          APPEND (result, IDENTIFIER_POINTER (DECL_ABSTRACT_ORIGIN (decl)));
+          APPEND (result, ")");
+        }
+      break;
+
+    case TYPE_DECL:
+      if (CH_DECL_SIGNAL (decl))
+	{
+	  /* this is really a signal */
+	  tree fields = TYPE_FIELDS (TREE_TYPE (decl));
+	  tree signame = DECL_NAME (decl);
+	  tree sigdest;
+	  
+	  APPEND (result, "SIGNAL ");
+	  APPEND (result, IDENTIFIER_POINTER (signame));
+	  if (IDENTIFIER_SIGNAL_DATA (signame))
+	    {
+	      APPEND (result, " = (");
+	      for ( ; fields != NULL_TREE;
+		   fields = TREE_CHAIN (fields))
+		{
+		  MYSTRING *mode_string;
+		  
+		  mode_string = get_type (TREE_TYPE (fields));
+		  APPEND (result, mode_string->str);
+		  FREE (mode_string);
+		  if (TREE_CHAIN (fields) != NULL_TREE)
+		    APPEND (result, ", ");
+		}
+	      APPEND (result, ")");
+	    }
+	  sigdest = IDENTIFIER_SIGNAL_DEST (signame);
+	  if (sigdest != NULL_TREE)
+	    {
+	      APPEND (result, " TO ");
+	      APPEND (result, IDENTIFIER_POINTER (DECL_NAME (sigdest)));
+	    }
+	}
+      else
+	{
+	  /* avoid defining a mode as itself */
+	  if (CH_NOVELTY (TREE_TYPE (decl)) == decl)
+	    APPEND (result, "NEWMODE ");
+	  else
+	    APPEND (result, "SYNMODE ");
+	  APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
+	  APPEND (result, " = ");
+	  mode_string = decode_mode (TREE_TYPE (decl));
+	  APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	}
+      break;
+      
+    case FUNCTION_DECL:
+      {
+	tree	args;
+	
+	type = TREE_TYPE (decl);
+	args = TYPE_ARG_TYPES (type);
+	
+	APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
+	
+	if (CH_DECL_PROCESS (decl))
+	  APPEND (result, ": PROCESS (");
+	else
+	  APPEND (result, ": PROC (");
+
+	args = TYPE_ARG_TYPES (type);
+	
+	mode_string = print_proc_tail (type, args, 1);
+	APPEND (result, mode_string->str);
+	FREE (mode_string);
+	
+	/* generality */
+	if (CH_DECL_GENERAL (decl))
+	  APPEND (result, " GENERAL");
+	if (CH_DECL_SIMPLE (decl))
+	  APPEND (result, " SIMPLE");
+	if (DECL_INLINE (decl))
+	  APPEND (result, " INLINE");
+	if (CH_DECL_RECURSIVE (decl))
+	  APPEND (result, " RECURSIVE");
+	APPEND (result, " END");
+      }
+      break;
+      
+    case FIELD_DECL:
+      APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
+      APPEND (result, " ");
+      mode_string = get_type (TREE_TYPE (decl));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      if (DECL_INITIAL (decl) != NULL_TREE)
+	{
+	  mode_string = decode_layout (DECL_INITIAL (decl));
+	  APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	}
+#if 0
+      if (is_forbidden (DECL_NAME (decl), forbid))
+	APPEND (result, " FORBID");
+#endif
+      break;
+      
+    case CONST_DECL:
+      if (DECL_INITIAL (decl) == NULL_TREE 
+	  || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
+	break;
+      APPEND (result, "SYN ");
+      APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
+      APPEND (result, " ");
+      mode_string = get_type (TREE_TYPE (decl));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      APPEND (result, " = ");
+      mode_string = decode_constant (DECL_INITIAL (decl));
+      APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+      
+    case ALIAS_DECL:
+      /* If CH_DECL_GRANTED, decl was granted into this scope, and
+	 so wasn't in the source code. */
+      if (!CH_DECL_GRANTED (decl))
+	{
+	  static int restricted = 0;
+	    
+	  if (DECL_SEIZEFILE (decl) != use_seizefile_name
+	      && DECL_SEIZEFILE (decl))
+	    {
+	      use_seizefile_name = DECL_SEIZEFILE (decl);
+	      restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
+	      if (! restricted)
+	        grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
+	      mark_use_seizefile_written (use_seizefile_name);
+	    }
+	  if (! restricted)
+	    {
+	      APPEND (result, "SEIZE ");
+	      mode_string = decode_prefix_rename (decl);
+	      APPEND (result, mode_string->str);
+	      FREE (mode_string);
+	    }
+	}
+      break;
+
+    default:
+      APPEND (result, "----- not implemented ------");
+      break;
+    }
+  return (result);
+}
+
+static MYSTRING *
+decode_decl_selective (decl, all_decls)
+    tree decl;
+    tree all_decls;
+{
+  MYSTRING *result = newstring ("");
+  MYSTRING *mode_string;
+  tree      type;
+
+  if (CH_ALREADY_GRANTED (decl))
+    /* do nothing */
+    return result;
+
+  CH_ALREADY_GRANTED (decl) = 1;
+
+  switch ((enum chill_tree_code)TREE_CODE (decl))
+    {
+    case VAR_DECL:
+    case BASED_DECL:
+      mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
+        {
+	  mode_string = decode_mode_selective (DECL_ABSTRACT_ORIGIN (decl), all_decls);
+	  if (mode_string->len)
+	    PREPEND (result, mode_string->str);
+	  FREE (mode_string);
+        }
+      break;
+
+    case TYPE_DECL:
+      if (CH_DECL_SIGNAL (decl))
+	{
+	  /* this is really a signal */
+	  tree fields = TYPE_FIELDS (TREE_TYPE (decl));
+	  tree signame = DECL_NAME (decl);
+	  tree sigdest;
+	  
+	  if (IDENTIFIER_SIGNAL_DATA (signame))
+	    {
+	      for ( ; fields != NULL_TREE;
+		   fields = TREE_CHAIN (fields))
+		{
+		  MYSTRING *mode_string;
+		  
+		  mode_string = get_type_selective (TREE_TYPE (fields),
+						    all_decls);
+		  if (mode_string->len)
+		    APPEND (result, mode_string->str);
+		  FREE (mode_string);
+		}
+	    }
+	  sigdest = IDENTIFIER_SIGNAL_DEST (signame);
+	  if (sigdest != NULL_TREE)
+	    {
+	      mode_string = decode_mode_selective (DECL_NAME (sigdest), all_decls);
+	      if (mode_string->len)
+		{
+		  MAYBE_NEWLINE (result);
+		  APPEND (result, mode_string->str);
+		}
+	      FREE (mode_string);
+	    }
+	}
+      else
+	{
+	  /* avoid defining a mode as itself */
+	  mode_string = decode_mode_selective (TREE_TYPE (decl), all_decls);
+	  APPEND (result, mode_string->str);
+	  FREE (mode_string);
+	}
+      break;
+      
+    case FUNCTION_DECL:
+      {
+	tree	args;
+	
+	type = TREE_TYPE (decl);
+	args = TYPE_ARG_TYPES (type);
+	
+	args = TYPE_ARG_TYPES (type);
+	
+	mode_string = print_proc_tail_selective (type, args, all_decls);
+	if (mode_string->len)
+	  APPEND (result, mode_string->str);
+	FREE (mode_string);
+      }
+      break;
+      
+    case FIELD_DECL:
+      mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      break;
+      
+    case CONST_DECL:
+      if (DECL_INITIAL (decl) == NULL_TREE 
+	  || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
+	break;
+      mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
+      if (mode_string->len)
+	APPEND (result, mode_string->str);
+      FREE (mode_string);
+      mode_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
+      if (mode_string->len)
+	{
+	  MAYBE_NEWLINE (result);
+	  APPEND (result, mode_string->str);
+	}
+      FREE (mode_string);
+      break;
+      
+    }
+  MAYBE_NEWLINE (result);
+  return (result);
+}
+
+static void
+globalize_decl (decl)
+    tree	decl;
+{
+  if (!TREE_PUBLIC (decl) && DECL_NAME (decl) &&
+      (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL))
+    {
+      extern	FILE	*asm_out_file;
+      extern	char	*first_global_object_name;
+      char		*name = XSTR (XEXP (DECL_RTL (decl), 0), 0);
+	
+      if (!first_global_object_name)
+	first_global_object_name = name + (name[0] == '*');
+      ASM_GLOBALIZE_LABEL (asm_out_file, name);
+    }
+}
+
+
+static void
+grant_one_decl (decl)
+    tree	decl;
+{
+  MYSTRING	*result;
+
+  if (DECL_SOURCE_LINE (decl) == 0)
+    return;
+  result = decode_decl (decl);
+  if (result->len)
+    {
+      APPEND (result, ";\n");
+      APPEND (gstring, result->str);
+    }
+  FREE (result);
+}
+
+static void
+grant_one_decl_selective (decl, all_decls)
+     tree decl;
+     tree all_decls;
+{
+  MYSTRING *result;
+  MYSTRING *fixups;
+
+  tree     d = DECL_ABSTRACT_ORIGIN (decl);
+
+  if (CH_ALREADY_GRANTED (d))
+    /* already done */
+    return;
+
+  result = decode_decl (d);
+  if (!result->len)
+    {
+      /* nothing to do */
+      FREE (result);
+      return;
+    }
+
+  APPEND (result, ";\n");
+
+  /* now process all undefined items in the decl */
+  fixups = decode_decl_selective (d, all_decls);
+  if (fixups->len)
+    {
+      PREPEND (result, fixups->str);
+    }
+  FREE (fixups);
+
+  /* we have finished a decl */
+  APPEND (selective_gstring, result->str);
+  FREE (result);
+}
+
+static int
+compare_memory_file (fname, buf)
+    char	*fname;
+    char	*buf;
+{
+  FILE	*fb;
+  int		c;
+
+  /* check if we have something to write */
+  if (!buf || !strlen (buf))
+    return (0);
+    
+  if ((fb = fopen (fname, "r")) == NULL)
+    return (1);
+    
+  while ((c = getc (fb)) != EOF)
+    {
+      if (c != *buf++)
+	{
+	  fclose (fb);
+	  return (1);
+	}
+    }
+  fclose (fb);
+  return (*buf ? 1 : 0);
+}
+
+void
+write_grant_file ()
+{
+  FILE	*fb;
+
+  /* We only write out the grant file if it has changed,
+     to avoid changing its time-stamp and triggering an
+     unnecessary 'make' action.  Return if no change. */
+  if (gstring == NULL || !spec_module_generated ||
+      !compare_memory_file (grant_file_name, gstring->str))
+    return;
+
+  fb = fopen (grant_file_name, "w");
+  if (fb == NULL)
+      pfatal_with_name (grant_file_name);
+    
+  /* write file. Due to problems with record sizes on VAX/VMS
+     write string to '\n' */
+#ifdef VMS
+  /* do it this way for VMS, cause of problems with
+     record sizes */
+  p = gstring->str;
+  while (*p)
+    {
+      extern char* strchr ();
+      p1 = strchr (p, '\n');
+      c = *++p1;
+      *p1 = '\0';
+      fprintf (fb, "%s", p);
+      *p1 = c;
+      p = p1;
+    }
+#else
+  /* faster way to write */
+  if (write (fileno (fb), gstring->str, gstring->len) < 0)
+    {
+      int save_errno = errno;
+      unlink (grant_file_name);
+      errno = save_errno;
+      pfatal_with_name (grant_file_name);
+    }
+#endif
+  fclose (fb);
+}
+
+
+/* handle grant statement */
+
+void
+set_default_grant_file ()
+{
+#undef strrchr
+    extern	char *strrchr ();
+    char	*p, *tmp, *fname;
+
+    if (dump_base_name)
+      fname = dump_base_name; /* Probably invoked via gcc */
+    else
+      { /* Probably invoked directly (not via gcc) */
+	fname = asm_file_name;
+	if (!fname)
+	  fname = main_input_filename ? main_input_filename : input_filename;
+	if (!fname)
+	  return;
+      }
+
+    p = strrchr (fname, '.');
+    if (!p)
+    {
+	tmp = (char *) alloca (strlen (fname) + 10);
+	strcpy (tmp, fname);
+    }
+    else
+    {
+	int	i = p - fname;
+	
+	tmp = (char *) alloca (i + 10);
+	strncpy (tmp, fname, i);
+	tmp[i] = '\0';
+    }
+    strcat (tmp, ".grt");
+    default_grant_file = build_string (strlen (tmp), tmp);
+
+    grant_file_name = TREE_STRING_POINTER (default_grant_file);
+
+    if (gstring == NULL)
+      gstring = newstring ("");
+    if (selective_gstring == NULL)
+      selective_gstring = newstring ("");
+}
+
+/* Make DECL visible under the name NAME in the (fake) outermost scope. */
+
+void
+push_granted (name, decl)
+     tree name, decl;
+{
+#if 0
+  IDENTIFIER_GRANTED_VALUE (name) = decl;
+  granted_decls = tree_cons (name, decl, granted_decls);
+#endif
+}
+
+void
+chill_grant (old_prefix, new_prefix, postfix, forbid)
+     tree old_prefix;
+     tree new_prefix;
+     tree postfix;
+     tree forbid;
+{
+  if (pass == 1)
+    {
+#if 0
+      tree old_name = old_prefix == NULL_TREE ? postfix
+	: get_identifier3 (IDENTIFIER_POINTER (old_prefix),
+			   "!", IDENTIFIER_POINTER (postfix));
+      tree new_name = new_prefix == NULL_TREE ? postfix
+	: get_identifier3 (IDENTIFIER_POINTER (new_prefix),
+			   "!", IDENTIFIER_POINTER (postfix));
+#endif
+      tree alias = build_alias_decl (old_prefix, new_prefix, postfix);
+      CH_DECL_GRANTED (alias) = 1;
+      DECL_SEIZEFILE (alias) = current_seizefile_name;
+      TREE_CHAIN (alias) = current_module->granted_decls;
+      current_module->granted_decls = alias;
+
+      if (forbid)
+	warning ("FORBID is not yet implemented");  /* FIXME */
+    }
+}
+
+/* flag GRANT ALL only once. Avoids search in case of GRANT ALL. */
+static int grant_all_seen = 0;
+
+/* check if a decl is in the list of granted decls. */
+static int
+search_in_list (name, granted_decls)
+    tree name;
+    tree granted_decls;
+{
+  tree vars;
+  
+  for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
+    if (DECL_SOURCE_LINE (vars))
+      {
+	if (DECL_POSTFIX_ALL (vars))
+	  {
+	    grant_all_seen = 1;
+	    return 1;
+	  }
+	else if (name == DECL_NAME (vars))
+	  return 1;
+      }
+  /* not found */
+  return 0;
+}
+
+static int
+really_grant_this (decl, granted_decls)
+    tree decl;
+    tree granted_decls;
+{
+  /* we never grant labels at module level */
+  if ((enum chill_tree_code)TREE_CODE (decl) == LABEL_DECL)
+    return 0;
+
+  if (grant_all_seen)
+    return 1;
+    
+  switch ((enum chill_tree_code)TREE_CODE (decl))
+    {
+    case VAR_DECL:
+    case BASED_DECL:
+    case FUNCTION_DECL:
+      return search_in_list (DECL_NAME (decl), granted_decls);
+    case ALIAS_DECL:
+    case CONST_DECL:
+      return 1;
+    case TYPE_DECL:
+      if (CH_DECL_SIGNAL (decl))
+	return search_in_list (DECL_NAME (decl), granted_decls);
+      else
+	return 1;
+    }
+
+  /* this nerver should happen */
+  error_with_decl (decl, "function \"really_grant_this\" called for `%s'.");
+  return 1;
+}
+
+/* Write a SPEC MODULE using the declarations in the list DECLS. */
+static int header_written = 0;
+static char *header_template =
+"--\n-- WARNING: this file was generated by\n\
+-- GNUCHILL version %s\n-- based on gcc version %s\n--\n";
+
+void
+write_spec_module (decls, granted_decls)
+     tree decls;
+     tree granted_decls;
+{
+  tree	 vars;
+  char   *hdr;
+
+  if (granted_decls == NULL_TREE)
+    return;
+  
+  use_seizefile_name = NULL_TREE;
+
+  if (!header_written)
+    {
+      hdr = (char*) alloca (strlen (gnuchill_version)
+			    + strlen (version_string)
+			    + strlen (header_template) + 1);
+      sprintf (hdr, header_template, gnuchill_version, version_string);
+      APPEND (gstring, hdr);
+      header_written = 1;
+    }      
+  APPEND (gstring, IDENTIFIER_POINTER (current_module->name));
+  APPEND (gstring, ": SPEC MODULE\n");
+
+  /* first of all we look for GRANT ALL specified */
+  search_in_list (NULL_TREE, granted_decls);
+
+  if (grant_all_seen != 0)
+    {
+      /* write all identifiers to grant file */
+      for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
+	{
+	  if (DECL_SOURCE_LINE (vars))
+	    {
+	      if (DECL_NAME (vars))
+		{
+		  if ((TREE_CODE (vars) != CONST_DECL || !CH_DECL_ENUM (vars)) &&
+		      really_grant_this (vars, granted_decls))
+		    grant_one_decl (vars);
+		}
+	      else if (DECL_POSTFIX_ALL (vars))
+		{
+		  static int restricted = 0;
+		
+		  if (DECL_SEIZEFILE (vars) != use_seizefile_name
+		      && DECL_SEIZEFILE (vars))
+		    {
+		      use_seizefile_name = DECL_SEIZEFILE (vars);
+		      restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
+		      if (! restricted)
+			grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
+		      mark_use_seizefile_written (use_seizefile_name);
+		    }
+		  if (! restricted)
+		    {
+		      APPEND (gstring, "SEIZE ALL;\n");
+		    }
+		}
+	    }
+	}
+    }
+  else
+    {
+      seizefile_list *wrk, *x;
+
+      /* do a selective write to the grantfile. This will reduce the
+	 size of a grantfile and speed up compilation of 
+	 modules depending on this grant file */
+
+      if (selective_gstring == 0)
+	selective_gstring = newstring ("");
+
+      /* first of all process all SEIZE ALL's */
+      for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
+	{
+	  if (DECL_SOURCE_LINE (vars)
+	      && DECL_POSTFIX_ALL (vars))
+	    grant_seized_identifier (vars);
+	}
+
+      /* now walk through granted decls */
+      granted_decls = nreverse (granted_decls);
+      for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
+	{
+	  grant_one_decl_selective (vars, decls);
+	}
+      granted_decls = nreverse (granted_decls);
+
+      /* append all SEIZES */
+      wrk = selective_seizes;
+      while (wrk != 0)
+	{
+	  x = wrk->next;
+	  APPEND (gstring, wrk->seizes->str);
+	  FREE (wrk->seizes);
+	  free (wrk);
+	  wrk = x;
+	}
+      selective_seizes = 0;
+      
+      /* append generated string to grant file */
+      APPEND (gstring, selective_gstring->str);
+      FREE (selective_gstring);
+      selective_gstring = NULL;
+    }
+
+  for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
+    if (DECL_SOURCE_LINE (vars))
+      {
+	MYSTRING *mode_string = decode_prefix_rename (vars);
+	APPEND (gstring, "GRANT ");
+	APPEND (gstring, mode_string->str);
+	FREE (mode_string);
+	APPEND (gstring, ";\n");
+      }
+
+  APPEND (gstring, "END;\n");
+  spec_module_generated = 1;
+
+  /* initialize this for next spec module */
+  grant_all_seen = 0;
+}
+
+/*
+ * after the dark comes, after all of the modules are at rest,
+ * we tuck the compilation unit to bed...  A story in pass 1
+ * and a hug-and-a-kiss goodnight in pass 2.
+ */
+void
+chill_finish_compile ()
+{
+  tree global_list;
+  tree chill_init_function;
+
+  tasking_setup ();
+  build_enum_tables ();
+  
+  /* We only need an initializer function for the source file if
+     a) there's module-level code to be called, or
+     b) tasking-related stuff to be initialized. */
+  if (module_init_list != NULL_TREE || tasking_list != NULL_TREE)
+    {
+      extern tree initializer_type;
+      static tree chill_init_name;
+
+      /* declare the global initializer list */
+      global_list = do_decl (get_identifier ("_ch_init_list"),
+			     build_chill_pointer_type (initializer_type), 1, 0,
+			     NULL_TREE, 1);
+
+      /* Now, we're building the function which is the *real*
+	 constructor - if there's any module-level code in this
+	 source file, the compiler puts the file's initializer entry
+	 onto the global initializer list, so each module's body code
+	 will eventually get called, after all of the processes have
+	 been started up.  */
+      
+      /* This is better done in pass 2 (when first_global_object_name
+	 may have been set), but that is too late.
+	 Perhaps rewrite this so nothing is done in pass 1. */
+      if (pass == 1)
+	{
+	  extern char *first_global_object_name;
+	  /* If we don't do this spoof, we get the name of the first
+	     tasking_code variable, and not the file name. */
+	  char *tmp = first_global_object_name;
+
+	  first_global_object_name = NULL;
+	  chill_init_name = get_file_function_name ('I');
+	  first_global_object_name = tmp;
+	  /* strip off the file's extension, if any. */
+	  tmp = strrchr (IDENTIFIER_POINTER (chill_init_name), '.');
+	  if (tmp)
+	    *tmp = '\0';
+	}
+
+      start_chill_function (chill_init_name, void_type_node, NULL_TREE,
+			    NULL_TREE, NULL_TREE);
+      TREE_PUBLIC (current_function_decl) = 1;
+      chill_init_function = current_function_decl;
+      
+      /* For each module that we've compiled, that had module-level 
+	 code to be called, add its entry to the global initializer
+	 list. */
+	 
+      if (pass == 2)
+	{
+	  tree module_init;
+
+	  for (module_init = module_init_list;  
+	       module_init != NULL_TREE;
+	       module_init = TREE_CHAIN (module_init))
+	    {
+	      tree init_entry      = TREE_VALUE (module_init);
+
+	      /* assign module_entry.next := _ch_init_list; */
+	      expand_expr_stmt (
+		build_chill_modify_expr (
+		  build_component_ref (init_entry,
+		    get_identifier ("__INIT_NEXT")),
+		      global_list));
+
+	      /* assign _ch_init_list := &module_entry; */
+	      expand_expr_stmt (
+		build_chill_modify_expr (global_list,
+		  build1 (ADDR_EXPR, ptr_type_node, init_entry)));
+	    }
+	}
+
+      tasking_registry ();
+
+      make_decl_rtl (current_function_decl, NULL, 1);
+
+      finish_chill_function ();
+
+      if (pass == 2)
+	{
+	  assemble_constructor (IDENTIFIER_POINTER (chill_init_name));
+	  globalize_decl (chill_init_function);
+	}
+
+      /* ready now to link decls onto this list in pass 2. */
+      module_init_list = NULL_TREE;
+      tasking_list = NULL_TREE;
+    }
+}
+
+

gcc/ch/lex.c

+/* Lexical analyzer for GNU CHILL. -*- C -*-
+   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
+	 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 <errno.h>
+#include <setjmp.h>
+#include <ctype.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#include "config.h"
+#include "tree.h"
+#include "input.h"
+
+#include "lex.h"
+#include "ch-tree.h"
+#include "flags.h"
+#include "parse.h"
+#include "obstack.h"
+
+#ifdef MULTIBYTE_CHARS
+#include <stdlib.h>
+#include <locale.h>
+#endif
+
+/* include the keyword recognizers */
+#include "hash.h"
+
+#undef strchr
+
+FILE* finput;
+
+static int	last_token = 0;
+/* Sun's C compiler warns about the safer sequence 
+   do { .. } while 0 
+   when there's a 'return' inside the braces, so don't use it */
+#define RETURN_TOKEN(X) { last_token = X; return (X); }
+
+/* This is set non-zero to force incoming tokens to lowercase. */
+extern int ignore_case;
+
+extern int module_number;
+extern int serious_errors;
+
+/* This is non-zero to recognize only uppercase special words. */
+extern int special_UC;
+
+extern struct obstack permanent_obstack;
+extern struct obstack temporary_obstack;
+
+#ifndef errno
+extern int errno;
+#endif
+
+extern tree build_string_type        PROTO((tree, tree));
+extern void error                    PROTO((char *, ...));
+extern void error_with_file_and_line PROTO((char *, int, char *, ...));
+extern void grant_use_seizefile      PROTO((char *));
+extern void pedwarn                  PROTO((char *, ...));
+extern void pfatal_with_name         PROTO((char *));
+extern void push_obstacks PROTO((struct obstack *, struct obstack *));
+extern void set_identifier_size      PROTO((int));
+extern void sorry                    PROTO((char *, ...));
+extern int  target_isinf             PROTO((REAL_VALUE_TYPE));
+extern int  tolower                  PROTO((int));
+extern void warning                  PROTO((char *, ...));
+
+/* forward declarations */
+static void close_input_file         PROTO((char *));
+static tree convert_bitstring        PROTO((char *));
+static tree convert_integer          PROTO((char *));
+static void maybe_downcase           PROTO((char *));
+static int  maybe_number             PROTO((char *));
+static tree equal_number             PROTO((void));
+static void handle_use_seizefile_directive PROTO((int));
+static int  handle_name		     PROTO((tree));
+static void push_back                PROTO((int));
+static char *readstring              PROTO((int, int *));
+static void read_directive	     PROTO((void));
+static tree read_identifier	     PROTO((int));
+static tree read_number              PROTO((int));
+static void skip_c_comment           PROTO((void));
+static void skip_line_comment        PROTO((void));
+static int  skip_whitespace          PROTO((void));
+static tree string_or_char           PROTO((int, char *));
+
+/* next variables are public, because ch-actions uses them */
+
+/* the default grantfile name, set by lang_init */
+tree default_grant_file = 0;
+
+/* These tasking-related variables are NULL at the start of each 
+   compiler pass, and are set to an expression tree if and when
+   a compiler directive is parsed containing an expression.
+   The NULL state is significant;  it means 'no user-specified
+   signal_code (or whatever) has been parsed'. */
+
+/* process type, set by <> PROCESS_TYPE = number <> */
+tree process_type = NULL_TREE;
+
+/* send buffer default priority,
+   set by <> SEND_BUFFER_DEFAULT_PRIORITY = number <> */
+tree send_buffer_prio = NULL_TREE;
+
+/* send signal default priority,
+   set by <> SEND_SIGNAL_DEFAULT_PRIORITY = number <> */
+tree send_signal_prio = NULL_TREE;
+
+/* signal code, set by <> SIGNAL_CODE = number <> */
+tree signal_code = NULL_TREE;
+
+/* flag for range checking */
+int range_checking = 1;
+
+/* flag for NULL pointer checking */
+int empty_checking = 1;
+
+/* flag to indicate making all procedure local variables
+   to be STATIC */
+int all_static_flag = 0;
+
+/* flag to indicate -fruntime-checking command line option.
+   Needed for initializing range_checking and empty_checking
+   before pass 2 */
+int runtime_checking_flag = 1;
+
+/* The elements of `ridpointers' are identifier nodes
+   for the reserved type names and storage classes.
+   It is indexed by a RID_... value.  */
+tree ridpointers[(int) RID_MAX];
+
+/* Nonzero tells yylex to ignore \ in string constants.  */
+static int ignore_escape_flag = 0;
+
+static int maxtoken;		/* Current nominal length of token buffer.  */
+char *token_buffer;	/* Pointer to token buffer.
+			   Actual allocated length is maxtoken + 2.
+			   This is not static because objc-parse.y uses it.  */
+
+/* implement yylineno handling for flex */
+#define yylineno lineno
+
+static int inside_c_comment = 0;
+
+static int saw_eol = 0; /* 1 if we've just seen a '\n' */
+static int saw_eof = 0; /* 1 if we've just seen an EOF */
+
+typedef struct string_list
+  {
+    struct string_list *next;
+    char               *str;
+  } STRING_LIST;
+
+/* list of paths specified on the compiler command line by -L options. */
+static STRING_LIST *seize_path_list = (STRING_LIST *)0;
+
+/* List of seize file names.  Each TREE_VALUE is an identifier
+   (file name) from a <>USE_SEIZE_FILE<> directive.
+   The TREE_PURPOSE is non-NULL if a USE_SEIZE_FILE directive has been
+   written to the grant file. */
+static tree files_to_seize     = NULL_TREE;
+/* Last node on files_to_seize list. */
+static tree last_file_to_seize = NULL_TREE;
+/* Pointer into files_to_seize list:  Next unparsed file to read. */
+static tree next_file_to_seize = NULL_TREE;
+
+/* The most recent use_seize_file directive. */
+tree use_seizefile_name = NULL_TREE;
+
+/* If non-NULL, the name of the seizefile we're currently processing. */
+tree current_seizefile_name = NULL_TREE;
+
+/* called to reset for pass 2 */
+static void
+ch_lex_init ()
+{
+  current_seizefile_name = NULL_TREE;
+
+  lineno = 0;
+
+  saw_eol = 0;
+  saw_eof = 0;
+  /* Initialize these compiler-directive variables. */
+  process_type     = NULL_TREE;
+  send_buffer_prio = NULL_TREE;
+  send_signal_prio = NULL_TREE;
+  signal_code      = NULL_TREE;
+  all_static_flag  = 0;
+  /* reinitialize rnage checking and empty checking */
+  range_checking = runtime_checking_flag;
+  empty_checking = runtime_checking_flag;
+}
+
+
+char *
+init_parse (filename)
+     char *filename;
+{
+  int lowercase_standard_names = ignore_case || ! special_UC;
+
+  /* Open input file.  */
+  if (filename == 0 || !strcmp (filename, "-"))
+    {
+      finput = stdin;
+      filename = "stdin";
+    }
+  else
+    finput = fopen (filename, "r");
+  if (finput == 0)
+    pfatal_with_name (filename);
+
+#ifdef IO_BUFFER_SIZE
+  setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
+#endif
+
+  /* Make identifier nodes long enough for the language-specific slots.  */
+  set_identifier_size (sizeof (struct lang_identifier));
+
+  /* Start it at 0, because check_newline is called at the very beginning
+     and will increment it to 1.  */
+  lineno = 0;
+
+  /* Initialize these compiler-directive variables. */
+  process_type     = NULL_TREE;
+  send_buffer_prio = NULL_TREE;
+  send_signal_prio = NULL_TREE;
+  signal_code      = NULL_TREE;
+
+  maxtoken         = 40;
+  token_buffer     = xmalloc ((unsigned)(maxtoken + 2));
+
+  init_chill_expand ();
+
+#define ENTER_STANDARD_NAME(RID, LOWER, UPPER) \
+  ridpointers[(int) RID] = \
+    get_identifier (lowercase_standard_names ? LOWER : UPPER)
+
+  ENTER_STANDARD_NAME (RID_ALL,		"all",		"ALL");
+  ENTER_STANDARD_NAME (RID_ASSERTFAIL,	"assertfail",	"ASSERTFAIL");
+  ENTER_STANDARD_NAME (RID_ASSOCIATION,	"association",	"ASSOCIATION");
+  ENTER_STANDARD_NAME (RID_BIN,         "bin",          "BIN");
+  ENTER_STANDARD_NAME (RID_BOOL,	"bool",		"BOOL");
+  ENTER_STANDARD_NAME (RID_BOOLS,	"bools",	"BOOLS");
+  ENTER_STANDARD_NAME (RID_BYTE,	"byte",		"BYTE");
+  ENTER_STANDARD_NAME (RID_CHAR,	"char",		"CHAR");
+  ENTER_STANDARD_NAME (RID_DOUBLE,	"double",	"DOUBLE");
+  ENTER_STANDARD_NAME (RID_DURATION,    "duration",     "DURATION");
+  ENTER_STANDARD_NAME (RID_DYNAMIC,	"dynamic",	"DYNAMIC");
+  ENTER_STANDARD_NAME (RID_ELSE,	"else",		"ELSE");
+  ENTER_STANDARD_NAME (RID_EMPTY,	"empty",	"EMPTY");
+  ENTER_STANDARD_NAME (RID_FALSE,	"false",	"FALSE");
+  ENTER_STANDARD_NAME (RID_FLOAT,	"float",	"FLOAT");
+  ENTER_STANDARD_NAME (RID_GENERAL,	"general",	"GENERAL");
+  ENTER_STANDARD_NAME (RID_IN,		"in",		"IN");
+  ENTER_STANDARD_NAME (RID_INLINE,	"inline",	"INLINE");
+  ENTER_STANDARD_NAME (RID_INOUT,	"inout",	"INOUT");
+  ENTER_STANDARD_NAME (RID_INSTANCE,	"instance",	"INSTANCE");
+  ENTER_STANDARD_NAME (RID_INT,		"int",		"INT");
+  ENTER_STANDARD_NAME (RID_LOC,		"loc",		"LOC");
+  ENTER_STANDARD_NAME (RID_LONG,	"long",		"LONG");
+  ENTER_STANDARD_NAME (RID_LONG_REAL,	"long_real",	"LONG_REAL");
+  ENTER_STANDARD_NAME (RID_NULL,	"null",		"NULL");
+  ENTER_STANDARD_NAME (RID_OUT,		"out",		"OUT");
+  ENTER_STANDARD_NAME (RID_OVERFLOW,	"overflow",	"OVERFLOW");
+  ENTER_STANDARD_NAME (RID_PTR,		"ptr",		"PTR");
+  ENTER_STANDARD_NAME (RID_READ,	"read",		"READ");
+  ENTER_STANDARD_NAME (RID_REAL,	"real",		"REAL");
+  ENTER_STANDARD_NAME (RID_RANGE,	"range",	"RANGE");
+  ENTER_STANDARD_NAME (RID_RANGEFAIL,	"rangefail",	"RANGEFAIL");
+  ENTER_STANDARD_NAME (RID_RECURSIVE,	"recursive",	"RECURSIVE");
+  ENTER_STANDARD_NAME (RID_SHORT,	"short",	"SHORT");
+  ENTER_STANDARD_NAME (RID_SIMPLE,	"simple",	"SIMPLE");
+  ENTER_STANDARD_NAME (RID_TIME,        "time",         "TIME");
+  ENTER_STANDARD_NAME (RID_TRUE,	"true",		"TRUE");
+  ENTER_STANDARD_NAME (RID_UBYTE,	"ubyte",	"UBYTE");
+  ENTER_STANDARD_NAME (RID_UINT,	"uint",		"UINT");
+  ENTER_STANDARD_NAME (RID_ULONG,	"ulong",	"ULONG");
+  ENTER_STANDARD_NAME (RID_UNSIGNED,	"unsigned",	"UNSIGNED");
+  ENTER_STANDARD_NAME (RID_USHORT,	"ushort",	"USHORT");
+  ENTER_STANDARD_NAME (RID_VOID,	"void",		"VOID");
+
+  return filename;
+}
+
+void
+finish_parse ()
+{
+  if (finput != NULL)
+    fclose (finput);
+}
+
+static int yywrap ();
+
+#define YY_PUTBACK_SIZE 5
+#define YY_BUF_SIZE 1000
+
+static char yy_buffer[YY_PUTBACK_SIZE + YY_BUF_SIZE];
+static char *yy_cur = yy_buffer + YY_PUTBACK_SIZE;
+static char *yy_lim = yy_buffer + YY_PUTBACK_SIZE;
+
+int yy_refill ()
+{
+  char *buf = yy_buffer + YY_PUTBACK_SIZE;
+  int c, result;
+  bcopy (yy_cur - YY_PUTBACK_SIZE, yy_buffer, YY_PUTBACK_SIZE);
+  yy_cur = buf;
+
+ retry:
+  if (saw_eof)
+    {
+      if (yywrap ())
+	return EOF;
+      saw_eof = 0;
+      goto retry;
+    }
+
+  result = 0;
+  while (saw_eol)
+    {
+      c = check_newline ();
+      if (c == EOF)
+        {
+	  saw_eof = 1;
+	  goto retry;
+	}
+      else if (c != '\n')
+	{
+	  saw_eol = 0;
+	  buf[result++] = c;
+	}
+    }
+  
+  while (result < YY_BUF_SIZE)
+    {
+      c = getc(finput);
+      if (c == EOF)
+        {
+	  saw_eof = 1;
+	  break;
+	}
+      buf[result++] = c;
+      
+      /* Because we might switch input files on a compiler directive
+	 (that end with '>', don't read past a '>', just in case. */
+      if (c == '>')
+	break;
+      
+      if (c == '\n')
+	{
+#ifdef YYDEBUG
+	  extern int yydebug;
+	  if (yydebug)
+            fprintf (stderr, "-------------------------- finished Line %d\n",
+		     yylineno);
+#endif
+	  saw_eol = 1;
+	  break;
+	}
+    }
+
+  yy_lim = yy_cur + result;
+
+  return yy_lim > yy_cur ? *yy_cur++ : EOF;
+}
+
+#define input() (yy_cur < yy_lim ? *yy_cur++ : yy_refill ())
+
+#define unput(c) (*--yy_cur = (c))
+
+
+int starting_pass_2 = 0;
+
+int
+yylex ()
+{
+  int nextc;
+  int len;
+  char* tmp;
+  int base;
+  int ch;
+ retry:
+  ch = input ();
+  if (starting_pass_2)
+    {
+      starting_pass_2 = 0;
+      unput (ch);
+      return END_PASS_1;
+    }
+  switch (ch)
+    {
+    case ' ': case '\t': case '\n': case '\f': case '\b': case '\v': case '\r':
+      goto retry;
+    case '[':
+      return LPC;
+    case ']':
+      return RPC;
+    case '{':
+      return LC;
+    case '}':
+      return RC;
+    case '(':
+      nextc = input ();
+      if (nextc == ':')
+	return LPC;
+      unput (nextc);
+      return LPRN;
+    case ')':
+      return RPRN;
+    case ':':
+      nextc = input ();
+      if (nextc == ')')
+	return RPC;
+      else if (nextc == '=')
+	return ASGN;
+      unput (nextc);
+      return COLON;
+    case ',':
+      return COMMA;
+    case ';':
+      return SC;
+    case '+':
+      return PLUS;
+    case '-':
+      nextc = input ();
+      if (nextc == '>')
+	return ARROW;
+      if (nextc == '-')
+	{
+	  skip_line_comment ();
+	  goto retry;
+	}
+      unput (nextc);
+      return SUB;
+    case '*':
+      return MUL;
+    case '=':
+      return EQL;
+    case '/':
+      nextc = input ();
+      if (nextc == '/')
+	return CONCAT;
+      else if (nextc == '=')
+	return NE;
+      else if (nextc == '*')
+	{
+	  skip_c_comment ();
+	  goto retry;
+	}
+      unput (nextc);
+      return DIV;
+    case '<':
+      nextc = input ();
+      if (nextc == '=')
+	return LTE;
+      if (nextc == '>')
+	{
+	  read_directive ();
+	  goto retry;
+	}
+      unput (nextc);
+      return LT;
+    case '>':
+      nextc = input ();
+      if (nextc == '=')
+	return GTE;
+      unput (nextc);
+      return GT;
+
+    case 'D': case 'd':
+      base = 10;
+      goto maybe_digits;
+    case 'B': case 'b':
+      base = 2;
+      goto maybe_digits;
+    case 'H': case 'h':
+      base = 16;
+      goto maybe_digits;
+    case 'O': case 'o':
+      base = 8;
+      goto maybe_digits;
+    case 'C': case 'c':
+      nextc = input ();
+      if (nextc == '\'')
+	{
+	  int byte_val = 0;
+	  char *start;
+	  int len = 0;  /* Number of hex digits seen. */
+	  for (;;)
+	    {
+	      ch = input ();
+	      if (ch == '\'')
+		break;
+	      if (ch == '_')
+		continue;
+	      if (!isxdigit (ch))           /* error on non-hex digit */
+		{
+		  if (pass == 1)
+		    error ("invalid C'xx' ");
+		  break;
+		}
+	      if (ch >= 'a')
+		ch -= ' ';
+	      ch -= '0';
+	      if (ch > 9)
+		ch -= 7;
+	      byte_val *= 16;
+	      byte_val += (int)ch;
+
+	      if (len & 1) /* collected two digits, save byte */
+		obstack_1grow (&temporary_obstack, (char) byte_val);
+	      len++;
+	    }
+	  start = obstack_finish (&temporary_obstack);
+	  yylval.ttype = string_or_char (len >> 1, start);
+	  obstack_free (&temporary_obstack, start);
+	  return len == 2 ? SINGLECHAR : STRING;
+	}
+      unput (nextc);
+      goto letter;
+
+    maybe_digits:
+      nextc = input ();
+      if (nextc == '\'')
+	{
+	  char *start;
+	  obstack_1grow (&temporary_obstack, ch);
+	  obstack_1grow (&temporary_obstack, nextc);
+	  for (;;)
+	    {
+	      ch = input ();
+	      if (isalnum (ch))
+		obstack_1grow (&temporary_obstack, ch);
+	      else if (ch != '_')
+		break;
+	    }
+	  obstack_1grow (&temporary_obstack, '\0');
+	  start = obstack_finish (&temporary_obstack);
+	  if (ch != '\'')
+	    {
+	      unput (ch);
+	      yylval.ttype = convert_integer (start); /* Pass base? */
+	      return NUMBER;
+	    }
+	  else
+	    {
+	      yylval.ttype = convert_bitstring (start);
+	      return BITSTRING;
+	    }
+	}
+      unput (nextc);
+      goto letter;
+
+    case 'A':                                   case 'E':
+    case 'F':  case 'G':             case 'I':  case 'J':
+    case 'K':  case 'L':  case 'M':  case 'N':
+    case 'P':  case 'Q':  case 'R':  case 'S':  case 'T':
+    case 'U':  case 'V':  case 'W':  case 'X':  case 'Y':
+    case 'Z':
+    case 'a':                                   case 'e':
+    case 'f':  case 'g':             case 'i':  case 'j':
+    case 'k':  case 'l':  case 'm':  case 'n':
+    case 'p':  case 'q':  case 'r':  case 's':  case 't':
+    case 'u':  case 'v':  case 'w':  case 'x':  case 'y':
+    case 'z':
+    case '_':
+    letter:
+      return handle_name (read_identifier (ch));
+    case '\'':
+      tmp = readstring ('\'', &len);
+      yylval.ttype = string_or_char (len, tmp);
+      free (tmp);
+      return len == 1 ? SINGLECHAR : STRING;
+    case '\"':
+      tmp = readstring ('\"', &len);
+      yylval.ttype = build_chill_string (len, tmp);
+      free (tmp);
+      return STRING;
+    case '.':
+      nextc = input ();
+      unput (nextc);
+      if (isdigit (nextc)) /* || nextc == '_')  we don't start numbers with '_' */
+	goto number;
+      return DOT;
+    case '0': case '1': case '2': case '3': case '4':
+    case '5': case '6': case '7': case '8': case '9':
+    number:
+      yylval.ttype = read_number (ch);
+      return TREE_CODE (yylval.ttype) == REAL_CST ? FLOATING : NUMBER;
+    default:
+      return ch;
+    }
+}
+
+static void
+close_input_file (fn)
+  char *fn;
+{
+  if (finput == NULL)
+    abort ();
+
+  if (finput != stdin && fclose (finput) == EOF)
+    {
+      error ("can't close %s", fn);
+      abort ();
+    }
+  finput = NULL;
+}
+
+/* Return an identifier, starting with FIRST and then reading
+   more characters using input().  Return an IDENTIFIER_NODE. */
+
+static tree
+read_identifier (first)
+     int first; /* First letter of identifier */
+{
+  tree id;
+  char *start;
+  for (;;)
+    {
+      obstack_1grow (&temporary_obstack, first);
+      first = input ();
+      if (first == EOF)
+	break;
+      if (! isalnum (first) && first != '_')
+	{
+	  unput (first);
+	  break;
+	}
+    }
+  obstack_1grow (&temporary_obstack, '\0');
+  start = obstack_finish (&temporary_obstack);
+  maybe_downcase (start);
+  id = get_identifier (start);
+  obstack_free (&temporary_obstack, start);
+  return id;
+}
+
+/* Given an identifier ID, check to see if it is a reserved name,
+   and return the appropriate token type. */
+
+static int
+handle_name (id)
+     tree id;
+{
+  struct resword *tp;
+  tp = in_word_set (IDENTIFIER_POINTER (id), IDENTIFIER_LENGTH (id));
+  if (tp != NULL
+      && special_UC == isupper (tp->name[0])
+      && (tp->flags == RESERVED || tp->flags == PREDEF))
+    {
+      if (tp->rid != NORID)
+	yylval.ttype = ridpointers[tp->rid];
+      else if (tp->token == THIS)
+	yylval.ttype = lookup_name (get_identifier ("__whoami"));
+      return tp->token;
+    }
+  yylval.ttype = id;
+  return NAME;
+}
+
+static tree
+read_number (ch)
+     int ch; /* Initial character */
+{
+  tree num;
+  char *start;
+  int is_float = 0;
+  for (;;)
+    {
+      if (ch != '_')
+	obstack_1grow (&temporary_obstack, ch);
+      ch = input ();
+      if (! isdigit (ch) && ch != '_')
+	break;
+    }
+  if (ch == '.')
+    {
+      do
+	{
+	  if (ch != '_')
+	    obstack_1grow (&temporary_obstack, ch);
+	  ch = input ();
+	} while (isdigit (ch) || ch == '_');
+      is_float++;
+    }
+  if (ch == 'd' || ch == 'D' || ch == 'e' || ch == 'E')
+    {
+      /* Convert exponent indication [eEdD] to 'e'. */
+      obstack_1grow (&temporary_obstack, 'e');
+      ch = input ();
+      if (ch == '+' || ch == '-')
+	{
+	  obstack_1grow (&temporary_obstack, ch);
+	  ch = input ();
+	}
+      if (isdigit (ch) || ch == '_')
+	{
+	  do
+	    {
+	      if (ch != '_')
+		obstack_1grow (&temporary_obstack, ch);
+	      ch = input ();
+	    } while (isdigit (ch) || ch == '_');
+	}
+      else
+	{
+	  error ("malformed exponent part of floating-point literal");
+	}
+      is_float++;
+    }
+  if (ch != EOF)
+    unput (ch);
+  obstack_1grow (&temporary_obstack, '\0');
+  start = obstack_finish (&temporary_obstack);
+  if (is_float)
+    {
+      REAL_VALUE_TYPE value;
+      tree  type = double_type_node;
+      errno = 0;
+      value = REAL_VALUE_ATOF (start, TYPE_MODE (type));
+      obstack_free (&temporary_obstack, start);
+      if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT
+	  && REAL_VALUE_ISINF (value) && pedantic)
+	pedwarn ("real number exceeds range of REAL");
+      num = build_real (type, value);
+    }
+  else
+    num = convert_integer (start);
+  CH_DERIVED_FLAG (num) = 1;
+  return num;
+}
+
+/* Skip to the end of a compiler directive. */
+
+static void
+skip_directive ()
+{
+  int ch = input ();
+  for (;;)
+    {
+      if (ch == EOF)
+	{
+	  error ("end-of-file in '<>' directive");
+	  break;
+	}
+      if (ch == '\n')
+	break;
+      if (ch == '<')
+	{
+	  ch = input ();
+	  if (ch == '>')
+	    break;
+	}
+      ch = input ();
+    }
+  starting_pass_2 = 0;
+}
+
+/* Read a compiler directive.  ("<>{WS}" have already been read. ) */
+static void
+read_directive ()
+{
+  struct resword *tp;
+  tree id;
+  int ch = skip_whitespace();
+  if (isalpha (ch) || ch == '_')
+    id = read_identifier (ch);
+  else if (ch == EOF)
+    {
+      error ("end-of-file in '<>' directive"); 
+      to_global_binding_level (); 
+      return;
+    }
+  else
+    {
+      warning ("unrecognized compiler directive");
+      skip_directive ();
+      return;
+    }
+  tp = in_word_set (IDENTIFIER_POINTER (id), IDENTIFIER_LENGTH (id));
+  if (tp == NULL || special_UC != isupper (tp->name[0]))
+    {
+      if (pass == 1)
+	warning ("unrecognized compiler directive `%s'",
+		 IDENTIFIER_POINTER (id));
+    }
+  else
+    switch (tp->token)
+      {
+      case ALL_STATIC_OFF:
+	all_static_flag = 0;
+	break;
+      case ALL_STATIC_ON:
+	all_static_flag = 1;
+	break;
+      case EMPTY_OFF:
+	empty_checking = 0;
+	break;
+      case EMPTY_ON:
+	empty_checking = 1;
+	break;
+      case IGNORED_DIRECTIVE:
+	break;
+      case PROCESS_TYPE_TOKEN:
+	process_type = equal_number ();
+	break;
+      case RANGE_OFF:
+	range_checking = 0;
+	break;
+      case RANGE_ON:
+	range_checking = 1;
+	break;
+      case SEND_SIGNAL_DEFAULT_PRIORITY: 
+	send_signal_prio = equal_number ();
+	break;
+      case SEND_BUFFER_DEFAULT_PRIORITY:
+	send_buffer_prio = equal_number ();
+	break;
+      case SIGNAL_CODE:
+	signal_code = equal_number ();
+	break;
+      case USE_SEIZE_FILE:
+	handle_use_seizefile_directive (0);
+	break;
+      case USE_SEIZE_FILE_RESTRICTED:
+	handle_use_seizefile_directive (1);
+	break;
+      default:
+	if (pass == 1)
+	  warning ("unrecognized compiler directive `%s'", 
+		   IDENTIFIER_POINTER (id));
+	break;
+      }
+  skip_directive ();
+}
+
+
+tree
+build_chill_string (len, str)
+    int   len;
+    char  *str;
+{
+  tree t;
+
+  push_obstacks (&permanent_obstack, &permanent_obstack);
+  t = build_string (len, str);
+  TREE_TYPE (t) = build_string_type (char_type_node, 
+				     build_int_2 (len, 0));
+  CH_DERIVED_FLAG (t) = 1;
+  pop_obstacks ();
+  return t;
+}
+
+
+static tree
+string_or_char (len, str)
+     int   len;
+     char *str;
+{
+  tree result;
+  
+  push_obstacks (&permanent_obstack, &permanent_obstack);
+  if (len == 1)
+    {
+      result = build_int_2 ((unsigned char)str[0], 0);
+      CH_DERIVED_FLAG (result) = 1;
+      TREE_TYPE (result) = char_type_node;
+    }
+  else
+    result = build_chill_string (len, str);
+  pop_obstacks ();
+  return result;
+}
+
+
+static void
+maybe_downcase (str)
+    char        *str;
+{
+  if (! ignore_case)
+    return;
+  while (*str)
+    {
+      if (isupper (*str))
+	*str = tolower (*str);
+      str++;
+    }
+}
+
+
+static int
+maybe_number (s)
+  char	*s;
+{
+  char	fc;
+  
+  /* check for decimal number */
+  if (*s >= '0' && *s <= '9')
+    {
+      while (*s)
+	{
+	  if (*s >= '0' && *s <= '9')
+	    s++;
+	  else
+	    return 0;
+	}
+      return 1;
+    }
+  
+  fc = *s;
+  if (s[1] != '\'')
+    return 0;
+  s += 2;
+  while (*s)
+    {
+      switch (fc)
+	{
+	case 'd':
+	case 'D':
+	  if (*s < '0' || *s > '9')
+	    return 0;
+	  break;
+	case 'h':
+	case 'H':
+	  if (!isxdigit (*s))
+	    return 0;
+	  break;
+	case 'b':
+	case 'B':
+	  if (*s < '0' || *s > '1')
+	    return 0;
+	  break;
+	case 'o':
+	case 'O':
+	  if (*s < '0' || *s > '7')
+	    return 0;
+	  break;
+	default:
+	  return 0;
+	}
+      s++;
+    }
+  return 1;
+}
+
+static void
+push_back (c)
+char c;
+{
+  if (c == '\n')
+    lineno--;
+  unput (c);
+}
+
+static char *
+readstring (terminator, len)
+     char terminator;
+     int *len;
+{
+  int      c;
+  unsigned allocated = 1024;
+  char    *tmp = xmalloc (allocated);
+  int      i = 0;
+  
+  for (;;)
+    {
+      c = input ();
+      if (c == terminator)
+	{
+	  if ((c = input ()) != terminator)
+	    {
+	      unput (c);
+	      break;
+	    }
+	  else
+	    c = terminator;
+	}
+      if (c == '\n' || c == EOF)
+	  goto unterminated;
+      if (c == '^')
+	{
+	  c = input();
+	  if (c == EOF || c == '\n')
+	    goto unterminated;
+	  if (c == '^')
+	    goto storeit;
+	  if (c == '(')
+	    {
+	      int cc, count = 0;
+	      int base = 10;
+	      int next_apos = 0;
+	      int check_base = 1;
+	      c = 0;
+	      while (1)
+		{
+		  cc = input ();
+		  if (cc == terminator)
+		    {
+		      if (!(terminator == '\'' && next_apos))
+			{
+			  error ("unterminated control sequence");
+			  serious_errors++;
+			  goto done;
+			}
+		    }
+		  if (cc == EOF || cc == '\n')
+		    {
+		      c = cc;
+		      goto unterminated;
+		    }
+		  if (next_apos)
+		    {
+		      next_apos = 0;
+		      if (cc != '\'')
+			{
+			  error ("invalid integer literal in control sequence");
+			  serious_errors++;
+			  goto done;
+			}
+		      continue;
+		    }
+		  if (cc == ' ' || cc == '\t')
+		    continue;
+		  if (cc == ')')
+		    {
+		      if ((c < 0 || c > 255) && (pass == 1))
+			error ("control sequence overflow");
+		      if (! count && pass == 1)
+			error ("invalid control sequence");
+		      break;
+		    }
+		  else if (cc == ',')
+		    {
+		      if ((c < 0 || c > 255) && (pass == 1))
+			error ("control sequence overflow");
+		      if (! count && pass == 1)
+			error ("invalid control sequence");
+		      tmp[i++] = c;
+		      if (i == allocated)
+			{
+			  allocated += 1024;
+			  tmp = xrealloc (tmp, allocated);
+			}
+		      c = count = 0;
+		      base = 10;
+		      check_base = 1;
+		      continue;
+		    }
+		  else if (cc == '_')
+		    {
+		      if (! count && pass == 1)
+			error ("invalid integer literal in control sequence");
+		      continue;
+		    }
+		  if (check_base)
+		    {
+		      if (cc == 'D' || cc == 'd')
+			{
+			  base = 10;
+			  next_apos = 1;
+			}
+		      else if (cc == 'H' || cc == 'h')
+			{
+			  base = 16;
+			  next_apos = 1;
+			}
+		      else if (cc == 'O' || cc == 'o')
+			{
+			  base = 8;
+			  next_apos = 1;
+			}
+		      else if (cc == 'B' || cc == 'b')
+			{
+			  base = 2;
+			  next_apos = 1;
+			}
+		      check_base = 0;
+		      if (next_apos)
+			continue;
+		    }
+		  if (base == 2)
+		    {
+		      if (cc < '0' || cc > '1')
+			cc = -1;
+		      else
+			cc -= '0';
+		    }
+		  else if (base == 8)
+		    {
+		      if (cc < '0' || cc > '8')
+			cc = -1;
+		      else
+			cc -= '0';
+		    }
+		  else if (base == 10)
+		    {
+		      if (! isdigit (cc))
+			cc = -1;
+		      else
+			cc -= '0';
+		    }
+		  else if (base == 16)
+		    {
+		      if (!isxdigit (cc))
+			cc = -1;
+		      else
+			{
+			  if (cc >= 'a')
+			    cc -= ' ';
+			  cc -= '0';
+			  if (cc > 9)
+			    cc -= 7;
+			}
+		    }
+		  else
+		    {
+		      error ("invalid base in read control sequence");
+		      abort ();
+		    }
+		  if (cc == -1)
+		    {
+		      /* error in control sequence */
+		      if (pass == 1)
+			error ("invalid digit in control sequence");
+		      cc = 0;
+		    }
+		  c = (c * base) + cc;
+		  count++;
+		}
+	    }
+	  else
+	    c ^= 64;
+	}
+    storeit:
+      tmp[i++] = c;
+      if (i == allocated)
+	{
+	  allocated += 1024;
+	  tmp = xrealloc (tmp, allocated);
+	}
+    }
+ done:
+  tmp [*len = i] = '\0';
+  return tmp;
+
+unterminated:
+  if (c == '\n')
+    unput ('\n');
+  *len = 1;
+  if (pass == 1)
+    error ("unterminated string literal");  
+  to_global_binding_level ();
+  tmp[0] = '\0';
+  return tmp;
+}
+
+/* Convert an integer INTCHARS into an INTEGER_CST.
+   INTCHARS is on the temporary_obstack, and is popped by this function. */
+
+static tree
+convert_integer (intchars)
+     char *intchars;
+{
+#ifdef YYDEBUG
+  extern int yydebug;
+#endif
+  char *p = intchars;
+  char         *oldp = p;
+  int		base = 10, tmp;
+  int           valid_chars = 0;
+  int		overflow = 0;
+  tree		type;
+  HOST_WIDE_INT val_lo = 0, val_hi = 0;
+  tree		val;
+  
+  /* determine the base */
+  switch (*p)
+    {
+    case 'd':
+    case 'D':
+      p += 2;
+      break;
+    case 'o':
+    case 'O':
+      p += 2;
+      base = 8;
+      break;
+    case 'h':
+    case 'H':
+      p += 2;
+      base = 16;
+      break;
+    case 'b':
+    case 'B':
+      p += 2;
+      base = 2;
+      break;
+    default:
+      if (!isdigit (*p))   /* this test is for equal_number () */
+	{
+	  obstack_free (&temporary_obstack, intchars);
+	  return 0;
+	}
+      break;
+    }
+  
+  while (*p)
+    {
+      tmp = *p++;
+      if ((tmp == '\'') || (tmp == '_'))
+	continue;
+      if (tmp < '0')
+	goto bad_char;
+      if (tmp >= 'a')      /* uppercase the char */
+	tmp -= ' ';
+      switch (base)        /* validate the characters */
+	{
+	case 2:
+	  if (tmp > '1')
+	    goto bad_char;
+	  break;
+	case 8:
+	  if (tmp > '7')
+	    goto bad_char;
+	  break;
+	case 10:
+	  if (tmp > '9')
+	    goto bad_char;
+	  break;
+	case 16:
+	  if (tmp > 'F')
+	    goto bad_char;
+	  if (tmp > '9' && tmp < 'A')
+	    goto bad_char;
+	  break;
+	default:
+	  abort ();
+	}
+      tmp -= '0';
+      if (tmp > 9)
+	tmp -= 7;
+      if (mul_double (val_lo, val_hi, base, 0, &val_lo, &val_hi))
+	overflow++;
+      add_double (val_lo, val_hi, tmp, 0, &val_lo, &val_hi);
+      if (val_hi < 0)
+	overflow++;
+      valid_chars++;
+    }
+ bad_char:
+  obstack_free (&temporary_obstack, intchars);
+  if (!valid_chars)
+    {
+      if (pass == 2)
+	error ("invalid number format `%s'", oldp);
+      return 0;
+    }
+  val = build_int_2 (val_lo, val_hi);
+  /* We set the type to long long (or long long unsigned) so that
+     constant fold of literals is less likely to overflow.  */
+  if (int_fits_type_p (val, long_long_integer_type_node))
+    type = long_long_integer_type_node;
+  else
+    {
+      if (! int_fits_type_p (val, long_long_unsigned_type_node))
+	overflow++;
+      type = long_long_unsigned_type_node;
+    }
+  TREE_TYPE (val) = type;
+  CH_DERIVED_FLAG (val) = 1;
+  
+  if (overflow)
+    error ("integer literal too big");
+
+  return val;
+}
+
+/* Convert a bitstring literal on the temporary_obstack to
+   a bitstring CONSTRUCTOR.  Free the literal from the obstack. */
+
+static tree
+convert_bitstring (p)
+     char *p;
+{
+#ifdef YYDEBUG
+  extern int yydebug;
+#endif
+  int bl = 0, valid_chars = 0, bits_per_char = 0, c, k;
+  tree initlist = NULL_TREE;
+  tree val;
+  
+  /* Move p to stack so we can re-use temporary_obstack for result. */
+  char *oldp = (char*) alloca (strlen (p) + 1);
+  if (oldp == 0) fatal ("stack space exhausted");
+  strcpy (oldp, p);
+  obstack_free (&temporary_obstack, p);
+  p = oldp;
+  
+  switch (*p)
+    {
+    case 'h':
+    case 'H':
+      bits_per_char = 4;
+      break;
+    case 'o':
+    case 'O':
+      bits_per_char = 3;
+      break;
+    case 'b':
+    case 'B':
+      bits_per_char = 1;
+      break;
+    }
+  p += 2;
+
+  while (*p)
+    {
+      c = *p++;
+      if (c == '_' || c == '\'')
+	continue;
+      if (c >= 'a')
+	c -= ' ';
+      c -= '0';
+      if (c > 9)
+	c -= 7;
+      valid_chars++;
+      
+      for (k = BYTES_BIG_ENDIAN ? bits_per_char - 1 : 0;
+	   BYTES_BIG_ENDIAN ? k >= 0 : k < bits_per_char;
+	   bl++, BYTES_BIG_ENDIAN ? k-- : k++)
+	{
+	  if (c & (1 << k))
+	    initlist = tree_cons (NULL_TREE, build_int_2 (bl, 0), initlist);
+        }
+    }
+#if 0
+  /* as long as BOOLS(0) is valid it must tbe possible to
+     specify an empty bitstring */
+  if (!valid_chars)
+    {
+      if (pass == 2)
+	error ("invalid number format `%s'", oldp);
+      return 0;
+    }
+#endif
+  val = build (CONSTRUCTOR,
+	       build_bitstring_type (size_int (bl)),
+	       NULL_TREE, nreverse (initlist));
+  TREE_CONSTANT (val) = 1;
+  CH_DERIVED_FLAG (val) = 1;
+  return val;
+}
+
+/* Check if two filenames name the same file.
+   This is done by stat'ing both files and comparing their inodes.
+
+   Note: we have to take care of seize_path_list. Therefore do it the same
+   way as in yywrap. FIXME: This probably can be done better. */
+
+static int
+same_file (filename1, filename2)
+     char *filename1;
+     char *filename2;
+{
+  struct stat s[2];
+  char        *fn_input[2];
+  int         i, stat_status;
+  extern char *strchr();
+  
+  if (grant_only_flag)
+    /* do nothing in this case */
+    return 0;
+
+  /* if filenames are equal -- return 1, cause there is no need
+     to search in the include list in this case */
+  if (strcmp (filename1, filename2) == 0)
+    return 1;
+  
+  fn_input[0] = filename1;
+  fn_input[1] = filename2;
+
+  for (i = 0; i < 2; i++)
+    {
+      stat_status = stat (fn_input[i], &s[i]);
+      if (stat_status < 0 &&
+	  strchr (fn_input[i], '/') == 0)
+        {
+	  STRING_LIST *plp;
+	  char        *path;
+	  
+	  for (plp = seize_path_list; plp != 0; plp = plp->next)
+	    {
+	      path = (char *)xmalloc (strlen (fn_input[i]) +
+				      strlen (plp->str) + 2);
+	      sprintf (path, "%s/%s", plp->str, fn_input[i]);
+	      stat_status = stat (path, &s[i]);
+	      free (path);
+	      if (stat_status >= 0)
+	        break;
+  	    }
+        }
+      if (stat_status < 0)
+        pfatal_with_name (fn_input[i]);
+  }
+  return s[0].st_ino == s[1].st_ino && s[0].st_dev == s[1].st_dev;
+}
+
+/*
+ * Note that simply appending included file names to a list in this
+ * way completely eliminates the need for nested files, and the
+ * associated book-keeping, since the EOF processing in the lexer
+ * will simply process the files one at a time, in the order that the
+ * USE_SEIZE_FILE directives were scanned.
+ */
+static void
+handle_use_seizefile_directive (restricted)
+    int restricted;
+{
+  tree seen;
+  int   len;
+  int   c = skip_whitespace ();
+  char *use_seizefile_str = readstring (c, &len);
+
+  if (pass > 1)
+    return;
+
+  if (c != '\'' && c != '\"')
+    {
+      error ("USE_SEIZE_FILE directive must be followed by string");
+      return;
+    }
+
+  use_seizefile_name = get_identifier (use_seizefile_str);
+  CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name) = restricted;
+  
+  if (!grant_only_flag)
+    {
+      /* If file foo.ch contains a <> use_seize_file "bar.grt" <>,
+	 and file bar.ch contains a <> use_seize_file "foo.grt" <>,
+	 then if we're compiling foo.ch, we will indirectly be
+	 asked to seize foo.grt.  Don't. */
+      extern char *grant_file_name;
+      if (strcmp (use_seizefile_str, grant_file_name) == 0)
+	return;
+
+      /* Check if the file is already on the list. */
+      for (seen = files_to_seize; seen != NULL_TREE; seen = TREE_CHAIN (seen))
+	if (same_file (IDENTIFIER_POINTER (TREE_VALUE (seen)),
+		       use_seizefile_str))
+	  return;  /* Previously seen; nothing to do. */
+    }
+
+  /* Haven't been asked to seize this file yet, so add
+     its name to the list. */
+  {
+    tree pl = perm_tree_cons (0, use_seizefile_name, NULL_TREE);
+    if (files_to_seize == NULL_TREE)
+      files_to_seize = pl;
+    else
+      TREE_CHAIN (last_file_to_seize) = pl;
+    if (next_file_to_seize == NULL_TREE)
+      next_file_to_seize = pl;
+    last_file_to_seize = pl;
+  }
+}
+
+
+/*
+ * get input, convert to lower case for comparison
+ */
+int
+getlc (file)
+     FILE *file;
+{
+  register int c;
+
+  c = getc (file);  
+  if (isupper (c) && ignore_case)
+    c = tolower (c);
+  return c;
+}
+
+/* At the beginning of a line, increment the line number and process
+   any #-directive on this line.  If the line is a #-directive, read
+   the entire line and return a newline.  Otherwise, return the line's
+   first non-whitespace character.
+
+   (Each language front end has a check_newline() function that is called
+   from lang_init() for that language.  One of the things this function
+   must do is read the first line of the input file, and if it is a #line
+   directive, extract the filename from it and use it to initialize
+   main_input_filename.  Proper generation of debugging information in
+   the normal "front end calls cpp then calls cc1XXXX environment" depends
+   upon this being done.) */
+
+int
+check_newline ()
+{
+  register int c;
+
+  lineno++;
+
+  /* Read first nonwhite char on the line.  */
+
+  c = getc (finput);
+
+  while (c == ' ' || c == '\t')
+    c = getc (finput);
+
+  if (c != '#' || inside_c_comment)
+    {
+      /* If not #, return it so caller will use it.  */
+      return c;
+    }
+
+  /* Read first nonwhite char after the `#'.  */
+
+  c = getc (finput);
+  while (c == ' ' || c == '\t')
+    c = getc (finput);
+
+  /* If a letter follows, then if the word here is `line', skip
+     it and ignore it; otherwise, ignore the line, with an error
+     if the word isn't `pragma', `ident', `define', or `undef'.  */
+
+  if (isupper (c) && ignore_case)
+    c = tolower (c);
+
+  if (c >= 'a' && c <= 'z')
+    {
+      if (c == 'p')
+	{
+	  if (getlc (finput) == 'r'
+	      && getlc (finput) == 'a'
+	      && getlc (finput) == 'g'
+	      && getlc (finput) == 'm'
+	      && getlc (finput) == 'a'
+	      && (isspace (c = getlc (finput))))
+	    {
+#ifdef HANDLE_PRAGMA
+	      return HANDLE_PRAGMA (finput, c);
+#else
+	      goto skipline;
+#endif /* HANDLE_PRAGMA */
+	    }
+	}
+
+      else if (c == 'd')
+	{
+	  if (getlc (finput) == 'e'
+	      && getlc (finput) == 'f'
+	      && getlc (finput) == 'i'
+	      && getlc (finput) == 'n'
+	      && getlc (finput) == 'e'
+	      && (isspace (c = getlc (finput))))
+	    {
+#if 0 /*def DWARF_DEBUGGING_INFO*/
+	      if (c != '\n'
+		  && (debug_info_level == DINFO_LEVEL_VERBOSE)
+		  && (write_symbols == DWARF_DEBUG))
+	        dwarfout_define (lineno, get_directive_line (finput));
+#endif /* DWARF_DEBUGGING_INFO */
+	      goto skipline;
+	    }
+	}
+      else if (c == 'u')
+	{
+	  if (getlc (finput) == 'n'
+	      && getlc (finput) == 'd'
+	      && getlc (finput) == 'e'
+	      && getlc (finput) == 'f'
+	      && (isspace (c = getlc (finput))))
+	    {
+#if 0 /*def DWARF_DEBUGGING_INFO*/
+	      if (c != '\n'
+		  && (debug_info_level == DINFO_LEVEL_VERBOSE)
+		  && (write_symbols == DWARF_DEBUG))
+	        dwarfout_undef (lineno, get_directive_line (finput));
+#endif /* DWARF_DEBUGGING_INFO */
+	      goto skipline;
+	    }
+	}
+      else if (c == 'l')
+	{
+	  if (getlc (finput) == 'i'
+	      && getlc (finput) == 'n'
+	      && getlc (finput) == 'e'
+	      && ((c = getlc (finput)) == ' ' || c == '\t'))
+	    goto linenum;
+	}
+#if 0
+      else if (c == 'i')
+	{
+	  if (getlc (finput) == 'd'
+	      && getlc (finput) == 'e'
+	      && getlc (finput) == 'n'
+	      && getlc (finput) == 't'
+	      && ((c = getlc (finput)) == ' ' || c == '\t'))
+	    {
+	      /* #ident.  The pedantic warning is now in cccp.c.  */
+
+	      /* Here we have just seen `#ident '.
+		 A string constant should follow.  */
+
+	      while (c == ' ' || c == '\t')
+		c = getlc (finput);
+
+	      /* If no argument, ignore the line.  */
+	      if (c == '\n')
+		return c;
+
+	      ungetc (c, finput);
+	      token = yylex ();
+	      if (token != STRING
+		  || TREE_CODE (yylval.ttype) != STRING_CST)
+		{
+		  error ("invalid #ident");
+		  goto skipline;
+		}
+
+	      if (!flag_no_ident)
+		{
+#ifdef ASM_OUTPUT_IDENT
+		  extern FILE *asm_out_file;
+		  ASM_OUTPUT_IDENT (asm_out_file, TREE_STRING_POINTER (yylval.ttype));
+#endif
+		}
+
+	      /* Skip the rest of this line.  */
+	      goto skipline;
+	    }
+	}
+#endif
+
+      error ("undefined or invalid # directive");
+      goto skipline;
+    }
+
+linenum:
+  /* Here we have either `#line' or `# <nonletter>'.
+     In either case, it should be a line number; a digit should follow.  */
+
+  while (c == ' ' || c == '\t')
+    c = getlc (finput);
+
+  /* If the # is the only nonwhite char on the line,
+     just ignore it.  Check the new newline.  */
+  if (c == '\n')
+    return c;
+
+  /* Something follows the #; read a token.  */
+
+  if (isdigit(c))
+    {
+      int old_lineno = lineno;
+      int used_up = 0;
+      int l = 0;
+      extern struct obstack permanent_obstack;
+
+      do
+	{
+	  l = l * 10 + (c - '0'); /* FIXME Not portable */
+	  c = getlc(finput);
+	} while (isdigit(c));
+      /* subtract one, because it is the following line that
+	 gets the specified number */
+
+      l--;
+
+      /* Is this the last nonwhite stuff on the line?  */
+      c = getlc (finput);
+      while (c == ' ' || c == '\t')
+	c = getlc (finput);
+      if (c == '\n')
+	{
+	  /* No more: store the line number and check following line.  */
+	  lineno = l;
+	  return c;
+	}
+
+      /* More follows: it must be a string constant (filename).  */
+
+      /* Read the string constant, but don't treat \ as special.  */
+      ignore_escape_flag = 1;
+      ignore_escape_flag = 0;
+
+      if (c != '\"')
+	{
+	  error ("invalid #line");
+	  goto skipline;
+	}
+
+      for (;;)
+	{
+	  c = getc (finput);
+	  if (c == EOF || c == '\n')
+	    {
+	      error ("invalid #line");
+	      return c;
+	    }
+	  if (c == '\"')
+	    {
+	      obstack_1grow(&permanent_obstack, 0);
+	      input_filename = obstack_finish (&permanent_obstack);
+	      break;
+	    }
+	  obstack_1grow(&permanent_obstack, c);
+	}
+
+      lineno = l;
+
+      /* Each change of file name
+	 reinitializes whether we are now in a system header.  */
+      in_system_header = 0;
+
+      if (main_input_filename == 0)
+	main_input_filename = input_filename;
+
+      /* Is this the last nonwhite stuff on the line?  */
+      c = getlc (finput);
+      while (c == ' ' || c == '\t')
+	c = getlc (finput);
+      if (c == '\n')
+	return c;
+
+      used_up = 0;
+
+      /* `1' after file name means entering new file.
+	 `2' after file name means just left a file.  */
+
+      if (isdigit (c))
+	{
+	  if (c == '1')
+	    {
+	      /* Pushing to a new file.  */
+	      struct file_stack *p
+		= (struct file_stack *) xmalloc (sizeof (struct file_stack));
+	      input_file_stack->line = old_lineno;
+	      p->next = input_file_stack;
+	      p->name = input_filename;
+	      input_file_stack = p;
+	      input_file_stack_tick++;
+#ifdef DWARF_DEBUGGING_INFO
+	      if (debug_info_level == DINFO_LEVEL_VERBOSE
+		  && write_symbols == DWARF_DEBUG)
+		dwarfout_start_new_source_file (input_filename);
+#endif /* DWARF_DEBUGGING_INFO */
+
+	      used_up = 1;
+	    }
+	  else if (c == '2')
+	    {
+	      /* Popping out of a file.  */
+	      if (input_file_stack->next)
+		{
+		  struct file_stack *p = input_file_stack;
+		  input_file_stack = p->next;
+		  free (p);
+		  input_file_stack_tick++;
+#ifdef DWARF_DEBUGGING_INFO
+		  if (debug_info_level == DINFO_LEVEL_VERBOSE
+		      && write_symbols == DWARF_DEBUG)
+		    dwarfout_resume_previous_source_file (input_file_stack->line);
+#endif /* DWARF_DEBUGGING_INFO */
+		}
+	      else
+		error ("#-lines for entering and leaving files don't match");
+
+	      used_up = 1;
+	    }
+	}
+
+      /* If we have handled a `1' or a `2',
+	 see if there is another number to read.  */
+      if (used_up)
+	{
+	  /* Is this the last nonwhite stuff on the line?  */
+	  c = getlc (finput);
+	  while (c == ' ' || c == '\t')
+	    c = getlc (finput);
+	  if (c == '\n')
+	    return c;
+	  used_up = 0;
+	}
+
+      /* `3' after file name means this is a system header file.  */
+
+      if (c == '3')
+	in_system_header = 1;
+    }
+  else
+    error ("invalid #-line");
+
+  /* skip the rest of this line.  */
+ skipline:
+  while (c != '\n' && c != EOF)
+    c = getc (finput);
+  return c;
+}
+
+
+tree
+get_chill_filename ()
+{
+  return (build_chill_string (
+            strlen (input_filename) + 1,  /* +1 to get a zero terminated string */
+	      input_filename));
+}
+
+tree
+get_chill_linenumber ()
+{
+  return build_int_2 ((HOST_WIDE_INT)lineno, 0);
+}
+
+
+/* Assuming '/' and '*' have been read, skip until we've
+   read the terminating '*' and '/'. */
+
+static void
+skip_c_comment ()
+{
+  int c = input();
+  int start_line = lineno;
+
+  inside_c_comment++;
+  for (;;)
+    if (c == EOF)
+      {
+	error_with_file_and_line (input_filename, start_line,
+				  "unterminated comment");
+	break;
+      }
+    else if (c != '*')
+      c = input();
+    else if ((c = input ()) == '/')
+      break;
+  inside_c_comment--;
+}
+
+
+/* Assuming "--" has been read, skip until '\n'. */
+
+static void
+skip_line_comment ()
+{
+  for (;;)
+    {
+      int c = input ();
+
+      if (c == EOF)
+	return;
+      if (c == '\n')
+	break;
+    }
+  unput ('\n');
+}
+
+
+static int
+skip_whitespace ()
+{
+  for (;;)
+    {
+      int c = input ();
+
+      if (c == EOF)
+	return c;
+      if (c == ' ' || c == '\t' || c == '\r' || c == '\n' || c == '\v')
+	continue;
+      if (c == '/')
+	{
+	  c = input ();
+	  if (c == '*')
+	    {
+	      skip_c_comment ();
+	      continue;
+	    }
+	  else
+	    {
+	      unput (c);
+	      return '/';
+	    }
+	}
+      if (c == '-')
+	{
+	  c = input ();
+	  if (c == '-')
+	    {
+	      skip_line_comment ();
+	      continue;
+	    }
+	  else
+	    {
+	      unput (c);
+	      return '-';
+	    }
+	}
+      return c;
+    }
+}
+
+/*
+ * avoid recursive calls to yylex to parse the ' = digits' or
+ * ' = SYNvalue' which are supposed to follow certain compiler
+ * directives.  Read the input stream, and return the value parsed.
+ */
+         /* FIXME: overflow check in here */
+         /* FIXME: check for EOF around here */
+static tree
+equal_number ()
+{
+  int      c, result;
+  char    *tokenbuf;
+  char    *cursor;
+  tree     retval = integer_zero_node;
+  
+  c = skip_whitespace();
+  if ((char)c != '=')
+    {
+      if (pass == 2)
+	error ("missing `=' in compiler directive");
+      return integer_zero_node;
+    }
+  c = skip_whitespace();
+
+  /* collect token into tokenbuf for later analysis */
+  while (TRUE)
+    {
+      if (isspace (c) || c == '<')
+	break;
+      obstack_1grow (&temporary_obstack, c);
+      c = input ();
+    }
+  unput (c);             /* put uninteresting char back */
+  obstack_1grow (&temporary_obstack, '\0');        /* terminate token */
+  tokenbuf = obstack_finish (&temporary_obstack);
+  maybe_downcase (tokenbuf);
+
+  if (*tokenbuf == '-')
+    /* will fail in the next test */
+    result = BITSTRING;
+  else if (maybe_number (tokenbuf))
+    {
+      if (pass == 1)
+	return integer_zero_node;
+      push_obstacks_nochange ();
+      end_temporary_allocation ();
+      yylval.ttype = convert_integer (tokenbuf);
+      tokenbuf = 0;  /* Was freed by convert_integer. */
+      result = yylval.ttype ? NUMBER : 0;
+      pop_obstacks ();
+    }
+  else
+    result = 0;
+  
+  if (result  == NUMBER)
+    {
+      retval = yylval.ttype;
+    }
+  else if (result == BITSTRING)
+    {
+      if (pass == 1)
+        error ("invalid value follows `=' in compiler directive");
+      goto finish;
+    }
+  else /* not a number */
+    {
+      cursor = tokenbuf;
+      c = *cursor;
+      if (!isalpha (c) && c != '_')
+	{
+	  if (pass == 1)
+	    error ("invalid value follows `=' in compiler directive");
+	  goto finish;
+	}
+
+      for (cursor = &tokenbuf[1]; *cursor != '\0'; cursor++)
+	if (isalpha (*cursor) || *cursor == '_' || isdigit (*cursor))
+	  continue;
+	else
+	  {
+	    if (pass == 1)
+	      error ("invalid `%c' character in name", *cursor);
+	    goto finish;
+	  }
+      if (pass == 1)
+	goto finish;
+      else
+	{
+	  tree value = lookup_name (get_identifier (tokenbuf));
+	  if (value == NULL_TREE
+	      || TREE_CODE (value) != CONST_DECL
+	      || TREE_CODE (DECL_INITIAL (value)) != INTEGER_CST)
+	    {
+	      if (pass == 2)
+		error ("`%s' not integer constant synonym ",
+		       tokenbuf);
+	      goto finish;
+	    }
+	  obstack_free (&temporary_obstack, tokenbuf);
+	  tokenbuf = 0;
+	  push_obstacks_nochange ();
+	  end_temporary_allocation ();
+	  retval = convert (chill_taskingcode_type_node, DECL_INITIAL (value));
+	  pop_obstacks ();
+	}
+    }
+
+  /* check the value */
+  if (TREE_CODE (retval) != INTEGER_CST)
+    {
+      if (pass == 2)
+	error ("invalid value follows `=' in compiler directive");
+    }
+  else if (TREE_INT_CST_HIGH (retval) != 0 ||
+	   TREE_INT_CST_LOW (retval) > TREE_INT_CST_LOW (TYPE_MAX_VALUE (chill_unsigned_type_node)))
+    {
+      if (pass == 2)
+	error ("value out of range in compiler directive");
+    }
+ finish:
+  if (tokenbuf)
+    obstack_free (&temporary_obstack, tokenbuf);
+  return retval;
+}
+
+/*
+ * add a possible grant-file path to the list
+ */
+void
+register_seize_path (path)
+     char *path;
+{
+  int          pathlen = strlen (path);
+  char        *new_path = (char *)xmalloc (pathlen + 1);
+  STRING_LIST *pl     = (STRING_LIST *)xmalloc (sizeof (STRING_LIST));
+    
+  /* strip off trailing slash if any */
+  if (path[pathlen - 1] == '/')
+    pathlen--;
+
+  memcpy (new_path, path, pathlen);
+  pl->str  = new_path;
+  pl->next = seize_path_list;
+  seize_path_list = pl;
+}
+
+
+/* Used by decode_decl to indicate that a <> use_seize_file NAME <>
+   directive has been written to the grantfile. */
+
+void
+mark_use_seizefile_written (name)
+     tree name;
+{
+  tree node;
+
+  for (node = files_to_seize;  node != NULL_TREE; node = TREE_CHAIN (node))
+    if (TREE_VALUE (node) == name)
+      {
+	TREE_PURPOSE (node) = integer_one_node;
+	break;
+      }
+}
+
+
+static int
+yywrap ()
+{
+  extern char *strchr ();
+  extern char *chill_real_input_filename;
+  tree node;
+
+  close_input_file (input_filename);
+
+  use_seizefile_name = NULL_TREE;
+
+  if (next_file_to_seize && !grant_only_flag)
+    {
+      FILE *grt_in = NULL;
+      char *seizefile_name_chars
+	= IDENTIFIER_POINTER (TREE_VALUE (next_file_to_seize));
+
+      /* find a seize file, open it.  If it's not at the path the
+       * user gave us, and that path contains no slashes, look on
+       * the seize_file paths, specified by the '-I' options.
+       */     
+      grt_in = fopen (seizefile_name_chars, "r");
+      if (grt_in == NULL 
+	  && strchr (seizefile_name_chars, '/') == NULL)
+	{
+	  STRING_LIST *plp;
+	  char      *path;
+
+	  for (plp = seize_path_list; plp != NULL; plp = plp->next)
+	    {
+	      path = (char *)xmalloc (strlen (seizefile_name_chars)
+				      + strlen (plp->str) + 2);
+
+	      sprintf (path, "%s/%s", plp->str, seizefile_name_chars);
+	      grt_in = fopen (path, "r");
+	      if (grt_in == NULL)
+		free (path);
+	      else
+		{
+		  seizefile_name_chars = path;
+		  break;
+		}
+	    }
+	}
+
+      if (grt_in == NULL)
+	pfatal_with_name (seizefile_name_chars);
+
+      finput = grt_in;
+      input_filename = seizefile_name_chars;
+
+      lineno = 0;
+      current_seizefile_name = TREE_VALUE (next_file_to_seize);
+
+      next_file_to_seize = TREE_CHAIN (next_file_to_seize);
+
+      saw_eof = 0;
+      return 0;
+    }
+
+  if (pass == 1)
+    {
+      next_file_to_seize = files_to_seize;
+      current_seizefile_name = NULL_TREE;
+
+      if (strcmp (main_input_filename, "stdin"))
+	finput = fopen (chill_real_input_filename, "r");
+      else
+	finput = stdin;
+      if (finput == NULL)
+	{
+	  error ("can't reopen %s", chill_real_input_filename);
+	  return 1;
+	}
+      input_filename = main_input_filename;
+      ch_lex_init ();
+      lineno = 0;
+      /* Read a line directive if there is one.  */
+      ungetc (check_newline (), finput);
+      starting_pass_2 = 1;
+      saw_eof = 0;
+      if (module_number == 0)
+	warning ("no modules seen");
+      return 0;
+    }
+  return 1;
+}

gcc/ch/nloop.c

+/* Implement looping 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 "config.h"
+#include "tree.h"
+#include "ch-tree.h"
+#include "lex.h"
+#include "flags.h"
+#include "actions.h"
+#include "input.h"
+#include "obstack.h"
+#include "assert.h"
+#include "rtl.h"
+
+/* if the user codes '-flocal-loop-counter' on the command line,
+   ch-actions.c (lang_decode_option) will set this flag. */
+int flag_local_loop_counter = 0;
+
+extern tree chill_truthvalue_conversion PROTO((tree));
+extern rtx  emit_line_note              PROTO((char *, int)); 
+extern void error                       PROTO((char *, ...));
+extern rtx  expand_assignment           PROTO((tree, tree, int, int));
+extern void save_expr_under_name        PROTO((tree, tree));
+extern void stamp_nesting_label         PROTO((tree));
+extern int  int_fits_type_p             PROTO((tree, tree));
+extern void warning                     PROTO((char *, ...));
+
+/* forward declarations */
+static int  classify_loop            PROTO((void));
+static int  declare_temps            PROTO((void));
+static int  initialize_iter_var      PROTO((void));
+static int  maybe_skip_loop          PROTO((void));
+static int  top_loop_end_check       PROTO((void));
+static int  bottom_loop_end_check    PROTO((void));
+static int  increment_temps          PROTO((void));
+static tree build_temporary_variable PROTO((char *, tree));
+static tree maybe_make_for_temp      PROTO((tree, char *, tree));
+static tree chill_unsigned_type      PROTO((tree));
+
+/* In terms of the parameters passed to build_loop_iterator,
+ *   there are several types of loops.  They are encoded by
+ *   the ITER_TYPE enumeration.
+ *
+ *   1) DO FOR EVER; ... OD
+ *      indicated by a NULL_TREE start_exp, step_exp and end_exp,
+ *      condition == NULL, in_flag = 0, and ever_flag == 1 in the
+ *      first ITERATOR.
+ *
+ *   2) DO WHILE cond; ... OD
+ *      indicated by NULL_TREE start_exp, step_exp and end_exp, 
+ *      in_flag = 0, and condition != NULL.
+ *
+ *   3) DO; ... OD
+ *      indicated by NULL_TREEs in start_exp, step_exp and end_exp,
+ *      condition != NULL, in_flag == 0 and ever_flag == 0.  This
+ *      is not really a loop, but a compound statement.
+ *
+ *   4) DO FOR user_var := start_exp 
+ *         [DOWN] TO end_exp BY step_exp; ... DO
+ *      indicated by non-NULL_TREE start_exp, step_exp and end_exp.
+ *
+ *   5) DO FOR user_var [DOWN] IN discrete_mode; ... OD
+ *      indicated by in_flag == 1.  start_exp is a non-NULL_TREE 
+ *      discrete mode, with an optional down_flag.
+ *
+ *   6) DO FOR user_var [DOWN] IN powerset_expr; ... OD
+ *      indicated by in_flag == 1.  start_exp is a non-NULL_TREE 
+ *      powerset mode, with an optional down_flag.
+ *
+ *   7) DO FOR user_var [DOWN] IN location; ... OD
+ *      indicated by in_flag == 1.  start_exp is a non-NULL_TREE 
+ *      location mode, with an optional down_flag.
+ */
+typedef enum 
+{
+   DO_UNUSED,
+   DO_FOREVER,
+   DO_WHILE,
+   DO_OD,
+   DO_STEP,
+   DO_RANGE,
+   DO_POWERSET,
+   DO_LOC,
+   DO_LOC_VARYING 
+} ITER_TYPE;
+
+
+typedef struct iterator 
+{
+/* These variables only have meaning in the first ITERATOR structure. */
+  ITER_TYPE itype;                  /* type of this iterator */
+  int  error_flag;                  /* TRUE if no loop was started due to 
+				       user error */
+  tree condition;                   /* WHILE condition expression */
+  int  down_flag;                   /* TRUE if DOWN was coded */
+
+/* These variables have meaning in every ITERATOR structure. */
+  tree user_var;                    /* user's explicit iteration variable */
+  tree start_exp;                   /* user's start expression
+                                       or IN expression of a FOR .. IN*/
+  tree step_exp;                    /* user's step expression */
+  tree end_exp;                     /* user's end expression */
+  tree start_temp;                  /* temp holding evaluated start_exp */
+  tree end_temp;                    /* temp holding evaluated end_exp */
+  tree step_temp;                   /* temp holding evaluated step_exp */
+  tree powerset_temp;               /* temp holding user's initial powerset expression */
+  tree loc_ptr_temp;                /* temp holding count for LOC enumeration ptr */
+  tree iter_var;                    /* hidden variable for the loop */
+  tree iter_type;                   /* hidden variable's type */
+  tree base_type;                   /* LOC enumeration base type */
+  struct iterator *next;            /* ptr to next iterator for this loop */
+} ITERATOR;
+
+/*
+ * There's an entry like this for each nested DO loop.
+ * The list is maintained by push_loop_block
+ * and pop_loop_block.
+ */
+typedef struct loop {
+  struct loop *nxt_level;   /* pointer to enclosing loop */
+  ITERATOR    *iter_list;   /* iterators for the current loop */
+} LOOP;
+
+static LOOP *loop_stack = (LOOP *)0;
+
+#if 0
+
+Here is a CHILL DO FOR statement:
+
+DO FOR user_var := start_exp BY step_exp [DOWN] TO end_exp 
+   WHILE condition;
+
+For this loop to be 'safe', like a Pascal FOR loop, the start,
+end, and increment expressions are computed once, before the
+assignment to the iteration variable and saved in temporaries,
+before the first assignment of the iteration variable, so the
+following works:
+
+          FOR i := (i+1) TO (i+10) DO
+
+To prevent changes to the start/end/step expressions from
+effecting the loop''s termination, and to make the loop end-check
+as simple as possible, we evaluate the step expression into
+a temporary and compute a hidden iteration count before entering 
+the loop''s body.  User code cannot effect the counter, and the
+end-loop check simply decrements the counter and checks for zero.
+
+The whole phrase FOR iter := ... TO end_exp can be repeated
+multiple times, with different user-iteration variables.  This
+is discussed later.
+
+The loop counter calculations need careful design since a loop
+from MININT TO MAXINT must work, in the precision of integers.
+
+Here''s how it works, in C:
+
+        0) The DO ... OD loop is simply a block with 
+           its own scope.  
+
+	1) The DO FOR EVER is simply implemented:
+
+	   loop_top:
+		.
+		. body of loop
+		.
+		goto loop_top
+	   end_loop:
+
+	2) The DO WHILE is also simple:
+
+
+	   loop_top:
+		if (!condition) goto end_loop
+		.
+		. body of loop
+		.
+		goto loop_top
+	   end_loop:
+
+
+	3) The DO FOR [while condition] loop (no DOWN)
+
+	push a new scope,
+	decl iter_var
+
+		step_temp = step_exp
+                start_temp = start_exp
+                end_temp = end_exp
+		if (end_exp < start_exp) goto end_loop
+                /* following line is all unsigned arithmetic */
+		iter_var = (end_exp - start_exp + step_exp) / step_exp
+                user_var = start_temp
+	   loop_top:
+		if (!condition) goto end_loop
+		.
+		. body of loop
+		.
+                iter_var--
+		if (iter_var == 0) goto end_loop
+                user_var += step_temp
+		goto loop_top
+	end_loop:
+	pop scope
+
+	4) The proposed CHILL for [while condition] loop (with DOWN)
+
+	push a new scope,
+        decl iter
+		step_temp = step_exp
+                start_temp = start_exp
+                end_temp = end_exp
+		if (end_exp > start_exp) goto end_loop
+                /* following line is all unsigned arithmetic */
+		iter_var = (start_exp - end_exp + step_exp) / step_exp
+                user_var = start_temp
+	   loop_top:
+		if (!condition) goto end_loop
+		.
+		. body of loop
+		.
+                iter_var--
+		if (iter_var == 0) goto end_loop
+		user_var -= step_temp
+		goto loop_top
+	    end_loop:
+	pop scope
+
+
+        5) The range loop, which iterates over a mode''s possible
+           values, works just like the above step loops, but with
+           the start and end values taken from the mode''s lower
+           and upper domain values.
+
+
+	6) The FOR IN loop, where a location enumeration is
+           specified (see spec on page 81 of Z.200, bottom
+           of page 186):
+
+	push a new scope,
+        decl iter_var as an unsigned integer
+             loc_ptr_temp as pointer to a composite base type
+        
+               if array is varying
+                   iter_var = array''s length field
+               else
+                   iter_var = sizeof array / sizeof base_type
+	       loc_ptr_temp = &of highest or lowest indexable entry
+	   loop_top:
+		if (!condition) goto end_loop
+		.
+		. body of loop
+		.
+                iter_var--
+                if (iter_var == 0) goto end_loop               
+		loc_ptr_temp +/-= sizeof array base_type
+		goto loop_top
+	   end_loop:
+	pop scope
+
+	7) The DO FOR (DOWN) IN powerset_exp
+
+	push a new scope,
+        decl powerset_temp
+	decl iterator as basetype of powerset
+
+	        powerset_temp := start_exp
+	   loop_top:
+	        /* if DOWN */
+                if (__flsetclrpowerset () == 0) goto end_loop;
+                /* not DOWN */
+                if (__ffsetclrpowerset () == 0) goto end_loop;
+		if (!condition) goto end_loop
+		.
+		. body of loop
+		.
+		goto loop_top
+	   end_loop:
+	pop scope
+
+
+So, here''s the general DO FOR schema, as implemented here:
+
+        classify_loop       -- what type of loop have we?
+                            -- build_iterator does some of this, also
+        expand_start_loop   -- start the loop''s control scope
+        -- start scope for synthesized loop variables
+        declare_temps       -- create, initialize temporary variables
+        maybe_skip_loop     -- skip loop if end conditions unsatisfiable
+        initialize_iter_var -- initialize the iteration counter
+                            -- initialize user''s loop variable
+        expand_start_loop   -- generate top-of-loop label
+        top_loop_end_check  -- generate while code and/or
+                               powerset find-a-bit function call
+        .
+        .
+        .  user''s loop body code
+        .
+        .
+        bottom_loop_end_check  -- exit if counter has become zero
+        increment_temps     -- update temps for next iteration
+        expand_end_loop     -- generate jump back to top of loop
+        expand_end_cond     -- generate label for end of conditional
+        -- end of scope for synthesized loop variables
+        free_iterators      -- free up iterator space
+
+When there are two or more iterator phrases, each of the
+above loop steps must act upon all iterators.  For example,
+the 'increment_temps' step must increment all temporaries
+(associated with all iterators).
+
+ NOTE: Z.200, section 10.1 says that a block is ...
+       "the actions statement list in a do action, including any
+       loop counter and while control".  This means that an exp-
+       ression in a WHILE control can include references to the
+       loop counters created for the loop''s exclusive use.  
+       Example:
+
+             DCL a (1:10) INT;
+             DCL j INT;
+             DO FOR j IN a WHILE j > 0;
+             ...
+             OD;
+       The 'j' referenced in the while is the loc-identity 'j'
+       created inside the loop''s scope, and NOT the 'j' declared
+       before the loop.
+#endif
+
+/*
+ * The following routines are called directly by the
+ * CHILL parser.
+ */
+void
+push_loop_block ()
+{
+  LOOP *temp = (LOOP *)xmalloc (sizeof (LOOP));
+
+  /* push a new loop onto the stack */
+  temp->nxt_level = loop_stack;
+  temp->iter_list = (ITERATOR *)0;
+  loop_stack = temp;
+}
+
+void
+pop_loop_block ()
+{
+  LOOP *do_temp = loop_stack;
+  ITERATOR  *ip;
+
+  /* pop loop block off the list */
+  loop_stack = do_temp->nxt_level;
+
+  /* free the loop's iterator blocks */
+  ip = do_temp->iter_list;
+  while (ip != NULL)
+    {
+      ITERATOR *temp = ip->next;
+      free (ip);
+      ip = temp;
+    }
+  free (do_temp);
+}
+
+void
+begin_loop_scope ()
+{
+  ITERATOR *firstp = loop_stack->iter_list;
+
+  if (pass < 2)
+    return;
+
+  /*
+   * We need to classify the loop and declare its temporaries
+   * here, so as to define them before the WHILE condition
+   * (if any) is parsed.  The WHILE expression may refer to
+   * a temporary.
+   */
+  if (classify_loop ())
+    return;
+
+  if (firstp->itype != DO_OD)
+    declare_temps ();
+  
+  clear_last_expr ();
+  push_momentary ();
+  expand_start_bindings (0);
+}
+
+
+void
+end_loop_scope (opt_label)
+     tree opt_label;
+{
+  if (opt_label)
+    possibly_define_exit_label (opt_label);
+  poplevel (0, 0, 0);
+
+  if (pass < 2)
+    return;
+
+  expand_end_bindings (getdecls (), kept_level_p (), 0);
+  pop_momentary ();
+}
+
+/* The iterator structure records all aspects of a 
+ * 'FOR i := start [DOWN] TO end' clause or
+ * 'FOR i IN modename' or 'FOR i IN powerset' clause.
+ * It's saved on the iter_list of the current LOOP.
+ */
+void
+build_loop_iterator (user_var, start_exp, step_exp, end_exp, 
+		     down_flag, in_flag, ever_flag)
+     tree user_var, start_exp, step_exp, end_exp;
+     int  down_flag, in_flag, ever_flag;
+{
+  ITERATOR *ip = (ITERATOR *)xmalloc (sizeof (ITERATOR));
+
+  /* chain this iterator onto the current loop */
+  if (loop_stack->iter_list == NULL)
+    loop_stack->iter_list = ip;
+  else
+    {
+      ITERATOR *temp = loop_stack->iter_list;
+      while (temp->next != NULL)
+	temp = temp->next;
+      temp->next = ip;
+    }
+
+  ip->itype         = DO_UNUSED;
+  ip->user_var      = user_var;
+  ip->start_exp     = start_exp;
+  ip->step_exp      = step_exp;
+  ip->end_exp       = end_exp;
+  ip->condition     = NULL_TREE;
+  ip->start_temp    = NULL_TREE;
+  ip->end_temp      = NULL_TREE;
+  ip->step_temp     = NULL_TREE;
+  ip->down_flag     = down_flag;
+  ip->powerset_temp = NULL_TREE;
+  ip->iter_var      = NULL_TREE;
+  ip->iter_type     = NULL_TREE;
+  ip->loc_ptr_temp  = NULL_TREE;
+  ip->error_flag    = 1;          /* assume error will be found */
+  ip->next          = (ITERATOR *)0;
+
+  if (ever_flag)
+    ip->itype = DO_FOREVER;
+  else if (in_flag && start_exp != NULL_TREE)
+    {
+      if (TREE_CODE (start_exp) == ERROR_MARK)
+	return;
+      if (TREE_CODE (TREE_TYPE (start_exp)) == SET_TYPE)
+	ip->itype = DO_POWERSET;
+      else if (discrete_type_p (TREE_TYPE (ip->start_exp)))
+	ip->itype = DO_RANGE;
+      else if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ARRAY_TYPE)
+	ip->itype = DO_LOC;
+      else if (chill_varying_type_p (TREE_TYPE (ip->start_exp)))
+	ip->itype = DO_LOC_VARYING;
+      else
+	{
+	  error ("Loop's IN expression is not a composite object");
+	  return;
+	}
+    }
+  else if (start_exp == NULL_TREE && end_exp == NULL_TREE
+	   && step_exp == NULL_TREE && !down_flag)
+    ip->itype = DO_OD;
+  else
+    {
+      /* FIXME: Move this to the lexer? */
+#define CST_FITS_INT(NODE) (TREE_CODE(NODE) == INTEGER_CST &&\
+            int_fits_type_p (NODE, integer_type_node))
+
+      tree max_prec_type = integer_type_node;
+
+      if (! discrete_type_p (TREE_TYPE (ip->start_exp)))
+	{
+	  error ("start expr must have discrete mode");
+	  return;
+	}
+      if (TREE_CODE (TREE_TYPE (ip->start_exp)) == ENUMERAL_TYPE
+	  && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->start_exp)))
+	{
+	  error ("DO FOR start expression is a numbered SET");
+	  return;
+	}
+      if (TREE_CODE (TREE_TYPE (ip->end_exp)) == ENUMERAL_TYPE
+	  && CH_ENUM_IS_NUMBERED (TREE_TYPE (ip->end_exp)))
+	{
+	  error ("TO expression is a numbered SET");
+	  return;
+	}
+      /* Convert all three expressions to a common precision,
+	 which is the largest precision they exhibit, but
+         INTEGER_CST nodes are built in the lexer as
+	 long_integer_type nodes.  We'll treat convert them to
+	 integer_type_nodes if possible, for faster loop times. */
+
+      if (TYPE_PRECISION (max_prec_type) <
+	    TYPE_PRECISION (TREE_TYPE (ip->start_exp))
+	  && !CST_FITS_INT (ip->start_exp))
+	max_prec_type = TREE_TYPE (ip->start_exp);
+      if (! discrete_type_p (TREE_TYPE (ip->end_exp)))
+	{
+	  error ("TO expr must have discrete mode");
+	  return;
+	}
+      if (! CH_COMPATIBLE (ip->start_exp, 
+			   TREE_TYPE (ip->end_exp)))
+	{
+	  error ("start expr and TO expr must be compatible");
+	  return;
+	}
+      if (TYPE_PRECISION (max_prec_type) <
+	    TYPE_PRECISION (TREE_TYPE (ip->end_exp))
+	  && !CST_FITS_INT (ip->end_exp))
+	max_prec_type = TREE_TYPE (ip->end_exp);
+      if (ip->step_exp != NULL_TREE)
+	{
+	  /* assure that default 'BY 1' gets a useful type */
+	  if (ip->step_exp == integer_one_node)
+	    ip->step_exp = convert (TREE_TYPE (ip->start_exp),
+				    ip->step_exp);
+	  if (! discrete_type_p (TREE_TYPE (ip->step_exp)))
+	    {
+	      error ("BY expr must have discrete mode");
+	      return;
+	    }
+	  if (! CH_COMPATIBLE (ip->start_exp,
+		  TREE_TYPE (ip->step_exp)))
+	    {
+	      error ("start expr and BY expr must be compatible");
+	      return;
+	    }
+	  if (TYPE_PRECISION (max_prec_type) <
+		TYPE_PRECISION (TREE_TYPE (ip->step_exp))
+	      && !CST_FITS_INT (ip->step_exp))
+	    max_prec_type = TREE_TYPE (ip->step_exp);
+	}
+      if (TREE_CODE (ip->start_exp) == INTEGER_CST
+	  && TREE_CODE (ip->end_exp) == INTEGER_CST
+	  && compare_int_csts (ip->down_flag ? LT_EXPR : GT_EXPR,
+			       ip->start_exp, ip->end_exp))
+	warning ("body of DO FOR will never execute");
+
+      ip->start_exp = 
+	convert (max_prec_type, ip->start_exp);
+      ip->end_exp   = 
+	convert (max_prec_type, ip->end_exp);
+
+      if (ip->step_exp != NULL_TREE)
+	{
+	  ip->step_exp =
+	    convert (max_prec_type, ip->step_exp);
+
+	  if (TREE_CODE (ip->step_exp) != INTEGER_CST)
+	    {
+	      /* generate runtime check for negative BY expr */
+	      ip->step_exp = 
+		check_range (ip->step_exp, ip->step_exp,
+			     integer_zero_node, NULL_TREE);
+	    }
+	  else if (compare_int_csts (LE_EXPR, ip->step_exp, integer_zero_node))
+	    {
+	      error ("BY expression is negative or zero");
+	      return;
+	    }
+	}
+      ip->itype = DO_STEP;
+    }
+
+  ip->error_flag = 0;           /* no errors! */
+}
+
+void
+build_loop_start (while_control, start_label)
+     tree while_control, start_label;
+{
+  ITERATOR *firstp = loop_stack->iter_list;
+  
+  firstp->condition = while_control;
+
+  if (firstp->error_flag)
+    return;
+
+  /* We didn't know at begin_loop_scope time about the condition;
+     adjust iterator type now. */
+  if (firstp->itype == DO_OD && firstp->condition)
+    firstp->itype = DO_WHILE;
+
+  if (initialize_iter_var ())
+    return;
+  
+  if (maybe_skip_loop ())
+    return;
+
+  /* use the label as an 'exit' label, 
+     'goto' needs another sort of label */
+  expand_start_loop (start_label != NULL_TREE);
+  
+  if (top_loop_end_check ())
+    return;
+  emit_line_note (input_filename, lineno); 
+}
+
+/*
+ * Called after the last action of the loop body
+ * has been parsed.
+ */
+void
+build_loop_end ()
+{
+  ITERATOR *ip = loop_stack->iter_list;
+
+  emit_line_note (input_filename, lineno);
+
+  if (ip->error_flag)
+    return;
+
+  if (bottom_loop_end_check ())
+    return;
+
+  if (increment_temps ())
+    return;
+
+  if (ip->itype != DO_OD)
+    {
+      expand_end_loop ();
+
+      for (; ip != NULL; ip = ip->next)
+	{
+	  switch (ip->itype)
+	    {
+	    case DO_LOC_VARYING:
+	    case DO_STEP:
+	      expand_end_cond ();
+	      break;
+	    default:
+	      break;
+	    }
+	}
+    }
+}
+
+/*
+ * The rest of the routines in this file are called from
+ * the above three routines.
+ */
+static int
+classify_loop ()
+{
+  ITERATOR *firstp = loop_stack->iter_list, *ip;
+
+  firstp->error_flag = 0;
+  if (firstp->itype == DO_UNUSED || firstp->itype == DO_OD)
+    {
+      /* if we have just DO .. OD, do nothing - this is just a 
+         BEGIN .. END without creating a new scope, and no looping  */
+      if (firstp->condition != NULL_TREE)
+	firstp->itype = DO_WHILE;
+      else
+	firstp->itype = DO_OD;
+    }
+  
+  /* Issue a warning if the any loop counter is mentioned more 
+     than once in the iterator list. */
+  for (ip = firstp; ip != NULL; ip = ip->next)
+    {
+      switch (ip->itype)
+	{
+	case DO_FOREVER:
+	case DO_WHILE:
+	  break;
+	case DO_STEP:
+	case DO_RANGE:
+	case DO_POWERSET:
+	case DO_LOC:
+	case DO_LOC_VARYING:
+	  /* FIXME: check for name uniqueness */
+	  break;
+	default:
+	  ;
+	}
+    }
+  return firstp->error_flag;
+}
+
+/*
+ * Reserve space for any loop-control temporaries, initialize them
+ */
+static int
+declare_temps ()
+{
+  ITERATOR *firstp = loop_stack->iter_list, *ip;
+  tree start_ptr;
+
+  for (ip = firstp; ip != NULL; ip = ip->next)
+    {
+      switch (ip->itype)
+	{
+	case DO_FOREVER:
+	case DO_WHILE:
+	  break;
+	case DO_STEP:
+	  ip->iter_type = chill_unsigned_type (TREE_TYPE (ip->start_exp));
+
+	  /* create, initialize temporaries if expressions aren't constant */
+	  ip->start_temp = maybe_make_for_temp (ip->start_exp, "for_start",
+						ip->iter_type);
+	  ip->end_temp = maybe_make_for_temp (ip->end_exp, "for_end",
+					      ip->iter_type);
+	  /* this is just the step-expression */
+	  ip->step_temp    = maybe_make_for_temp (ip->step_exp, "for_step",
+						  ip->iter_type);
+	  goto do_step_range;
+	  
+	case DO_RANGE:
+	  ip->iter_type = chill_unsigned_type_node;
+	  
+	  ip->start_temp =
+	    (ip->down_flag ? build_chill_upper : build_chill_lower)(TREE_TYPE (ip->start_exp));
+	  ip->end_temp =
+	    (ip->down_flag ? build_chill_lower : build_chill_upper)(TREE_TYPE (ip->start_exp));
+	  
+	  ip->step_temp = integer_one_node;
+	  
+	do_step_range:
+	  if (flag_local_loop_counter)
+	    {
+	      /* (re-)declare the user's iteration variable in the 
+		 loop's scope. */
+	      tree id_node = ip->user_var;
+	      IDENTIFIER_LOCAL_VALUE (id_node) = ip->user_var = 
+		decl_temp1 (id_node, ip->iter_type, 0, NULL_TREE,
+			    0, 0);
+	    }
+	  else
+	    {
+	      /* in this case, it's a previously-declared 
+		 VAR_DECL node, checked in build_loop_iterator. */
+	      if (TREE_CODE (ip->user_var) == IDENTIFIER_NODE)
+		ip->user_var = lookup_name (ip->user_var);
+	      if (ip->user_var == NULL_TREE)
+		{
+		  error ("loop identifier undeclared");
+		  ip->error_flag = 1;
+		  return 1;
+		}
+	    }
+	  ip->iter_var = 
+	    decl_temp1 (get_unique_identifier ("iter_var"),
+			ip->iter_type, 0, NULL_TREE, 0, 0);
+	  break;
+
+	case DO_POWERSET:
+	  ip->iter_type = chill_unsigned_type (
+			    TYPE_DOMAIN (TREE_TYPE (ip->start_exp)));
+	  if (flag_local_loop_counter)
+	    {
+	      /* declare the user's iteration variable in the loop's scope. */
+	      /* in this case, it's just an IDENTIFIER_NODE */
+	      ip->user_var = 
+		decl_temp1 (ip->user_var, ip->iter_type, 0, NULL_TREE, 0, 0);
+	    }
+	  else
+	    {
+	      /* in this case, it's a previously-declared VAR_DECL node */
+	      ip->user_var = lookup_name (ip->user_var);
+	    }
+	  /* the user's powerset-expression, evaluated and saved in a temp */
+	  ip->powerset_temp = maybe_make_for_temp (ip->start_exp, "for_set",
+						 TREE_TYPE (ip->start_exp));
+	  mark_addressable (ip->powerset_temp);
+	  break;
+
+	case DO_LOC:
+	case DO_LOC_VARYING:
+	  ip->iter_type = chill_unsigned_type_node;
+	  /* create the counter temp */
+	  ip->iter_var = 
+	    build_temporary_variable ("iter_var", ip->iter_type);
+
+	  if (!CH_LOCATION_P (ip->start_exp))
+	    ip->start_exp
+	      = decl_temp1 (get_unique_identifier ("iter_loc"),
+			    TREE_TYPE (ip->start_exp), 0,
+			    ip->start_exp, 0, 0);
+
+	  if (ip->itype == DO_LOC)
+	    {
+	      tree array_type = TREE_TYPE (ip->start_exp);
+	      tree ptr_type;
+	      tree temp;
+	      
+	      if (TREE_CODE (TREE_TYPE (array_type)) == BOOLEAN_TYPE)
+		{
+		  error ("Can't iterate through array of BOOL");
+		  ip->error_flag = 1;
+		  return ip->error_flag;
+		}
+	      
+	      /* FIXME: check for array type in ip->start_exp */
+
+	      /* create pointer temporary */
+	      ip->base_type = TREE_TYPE (array_type);
+	      ptr_type = build_pointer_type (ip->base_type);
+	      ip->loc_ptr_temp =
+		build_temporary_variable ("loc_ptr_tmp", ptr_type);
+	      
+	      /* declare the user's iteration variable in 
+		 the loop's scope, as an expression, to be
+		 passed to build_component_ref later */
+	      save_expr_under_name (ip->user_var, 
+		build1 (INDIRECT_REF, ip->base_type, 
+			ip->loc_ptr_temp));
+	      
+	      /* FIXME: see stor_layout */
+	      ip->step_temp = size_in_bytes (ip->base_type);
+	      
+	      temp = TYPE_DOMAIN (array_type);
+
+	      /* pointer to first array entry to look at */
+	      start_ptr = build1 (ADDR_EXPR, ptr_type, ip->start_exp);
+	      mark_addressable (ip->start_exp);
+	      ip->start_temp = ip->down_flag ? 
+		fold (build (PLUS_EXPR, ptr_type, 
+			     start_ptr,
+		  fold (build (MULT_EXPR, integer_type_node, ip->step_temp,
+		    fold (build (MINUS_EXPR, integer_type_node,
+				 TYPE_MAX_VALUE (temp),
+				 TYPE_MIN_VALUE (temp)))))))
+		  : start_ptr;
+	    }
+	  else
+	    {
+	      tree array_length =
+		convert (integer_type_node,
+		  build_component_ref (ip->start_exp, var_length_id));
+	      tree array_type = TREE_TYPE (TREE_CHAIN (
+			TYPE_FIELDS (TREE_TYPE (ip->start_exp))));
+	      tree array_data_ptr = 
+		build_component_ref (ip->start_exp, var_data_id);
+	      tree ptr_type;
+	      
+	      if (TREE_CODE (TREE_TYPE (array_type)) == BOOLEAN_TYPE)
+		{
+		  error ("Can't iterate through array of BOOL");
+		  firstp->error_flag = 1;
+		  return firstp->error_flag;
+		}
+	      
+	      /* create pointer temporary */
+	      ip->base_type = TREE_TYPE (array_type);
+	      ptr_type = build_pointer_type (ip->base_type);
+	      ip->loc_ptr_temp = 
+		build_temporary_variable ("loc_ptr_temp", ptr_type);
+							   
+	      
+	      /* declare the user's iteration variable in 
+		 the loop's scope, as an expression, to be
+		 passed to build_component_ref later */
+	      save_expr_under_name (ip->user_var, 
+		build1 (INDIRECT_REF, ip->base_type, 
+			ip->loc_ptr_temp));
+	      
+	      /* FIXME: see stor_layout */
+	      ip->step_temp = size_in_bytes (ip->base_type);
+	      
+	      /* pointer to first array entry to look at */
+	      start_ptr = build1 (ADDR_EXPR, ptr_type, array_data_ptr);
+	      mark_addressable (array_data_ptr);
+	      ip->start_temp = ip->down_flag ? 
+		fold (build (PLUS_EXPR, ptr_type, 
+                  start_ptr,
+		    fold (build (MULT_EXPR, integer_type_node, ip->step_temp,
+		      fold (build (MINUS_EXPR, integer_type_node,
+				   array_length,
+				   integer_one_node))))))
+		  : start_ptr;
+	    }
+	default:
+	  ;
+	}
+    }
+  return firstp->error_flag;
+}
+
+/*
+ * Initialize the hidden iteration-control variables,
+ * and the user's explicit loop variable.
+ */
+static int
+initialize_iter_var ()
+{
+  ITERATOR *firstp = loop_stack->iter_list, *ip;
+
+  for (ip = firstp; ip != NULL; ip = ip->next)
+    {
+      switch (ip->itype)
+	{
+	case DO_FOREVER:
+	case DO_WHILE:
+	  break;
+	case DO_STEP:
+	case DO_RANGE:
+	  {
+	    tree count =
+	      fold (build (PLUS_EXPR, ip->iter_type, integer_one_node,
+		  fold (build (TRUNC_DIV_EXPR, ip->iter_type, 
+		    convert (ip->iter_type,
+	              fold (build (MINUS_EXPR, ip->iter_type,
+			ip->down_flag ? ip->start_temp : ip->end_temp,
+			ip->down_flag ? ip->end_temp   : ip->start_temp))),
+			       ip->step_temp))));
+	    /* initialize the loop's hidden counter variable */
+	    expand_expr_stmt (
+	      build_chill_modify_expr (ip->iter_var, count));
+
+	    /* initialize user's variable */
+	    expand_expr_stmt (
+	      build_chill_modify_expr (ip->user_var, ip->start_temp));
+	  }
+	  break;
+	case DO_POWERSET:
+	  break;
+	case DO_LOC:
+	  {
+	    tree array_type = TREE_TYPE (ip->start_exp);
+	    tree array_length =
+	      fold (build (TRUNC_DIV_EXPR, integer_type_node,
+			   size_in_bytes (array_type),
+			   size_in_bytes (TREE_TYPE (array_type))));
+
+	    expand_expr_stmt (
+	      build_chill_modify_expr (ip->iter_var, array_length));
+	    goto do_loc_common;
+	  }
+
+	case DO_LOC_VARYING:
+	  expand_expr_stmt (
+	    build_chill_modify_expr (ip->iter_var,
+	      convert (integer_type_node,
+		build_component_ref (ip->start_exp, var_length_id))));
+
+	do_loc_common:
+	  expand_expr_stmt (
+	    build_chill_modify_expr (ip->loc_ptr_temp, 
+				     ip->start_temp));
+	  break;
+
+	default:
+	  ;
+	}
+    }
+  return firstp->error_flag;
+}
+
+/* Generate code to skip the whole loop, if start expression not
+ * <= end expression (or >= for DOWN loops).  This comparison must
+ * *NOT* be done in unsigned mode, or it will fail.
+ *  Also, skip processing an empty VARYING array. 
+ */
+static int
+maybe_skip_loop ()
+{
+  ITERATOR *firstp = loop_stack->iter_list, *ip;
+
+  for (ip = firstp; ip != NULL; ip = ip->next)
+    {
+      switch (ip->itype)
+	{
+	case DO_STEP:
+	  expand_start_cond (
+	    build (ip->down_flag ? GE_EXPR : LE_EXPR, 
+		   TREE_TYPE (ip->start_exp),
+		   ip->start_exp, ip->end_exp), 0);
+	  break;
+    
+	case DO_LOC_VARYING:
+	  { tree array_length =
+	      convert (integer_type_node,
+	        build_component_ref (ip->start_exp, var_length_id));
+	    expand_start_cond (
+	      build (NE_EXPR, TREE_TYPE (array_length),
+		     array_length, integer_zero_node), 0);
+	    break;
+	  }
+	default:
+	  break;
+	}
+    }
+  return 0;
+}  
+
+/*
+ * Check at the top of the loop for a termination
+ */
+static int
+top_loop_end_check ()
+{
+  ITERATOR *firstp = loop_stack->iter_list, *ip;
+
+  /* now, exit the loop if the condition isn't TRUE. */
+  if (firstp->condition)
+    {
+      expand_exit_loop_if_false (0,
+	chill_truthvalue_conversion (firstp->condition));
+    }
+
+  for (ip = firstp; ip != NULL; ip = ip->next)
+    {
+      switch (ip->itype)
+	{
+	case DO_FOREVER:
+	case DO_WHILE:
+	case DO_STEP:
+	case DO_RANGE:
+	  break;
+	case DO_POWERSET:
+	  {
+	    tree temp1;
+	    char *func_name;
+
+	    if (ip->down_flag)
+	      func_name = "__flsetclrpowerset";
+	    else
+	      func_name = "__ffsetclrpowerset";
+	    
+	    temp1 = TYPE_MIN_VALUE
+	      (TYPE_DOMAIN (TREE_TYPE (ip->powerset_temp)));
+	    expand_exit_loop_if_false (0,
+	      build_chill_function_call (lookup_name (get_identifier (func_name)),
+	        tree_cons (NULL_TREE, force_addr_of (ip->powerset_temp),
+                  tree_cons (NULL_TREE, powersetlen (ip->powerset_temp),
+	            tree_cons (NULL_TREE, force_addr_of (ip->user_var),
+                      tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (ip->user_var)),
+		        tree_cons (NULL_TREE,
+				   convert (long_integer_type_node, temp1),
+				   NULL_TREE)))))));
+	  }
+	  break;
+	case DO_LOC:
+	case DO_LOC_VARYING:
+	  break;
+	default:
+	  ;
+	}
+    }
+  return firstp->error_flag;
+}
+
+/*
+ * Check generated temporaries for loop's end
+ */
+static int
+bottom_loop_end_check ()
+{
+  ITERATOR *firstp = loop_stack->iter_list, *ip;
+
+  emit_line_note (input_filename, lineno);
+
+  /* now, generate code to check each loop counter for termination */
+  for (ip = firstp; ip != NULL; ip = ip->next)
+    {
+      switch (ip->itype)
+	{
+	case DO_FOREVER:
+	case DO_WHILE:
+	  break;
+	case DO_STEP:
+	case DO_RANGE:
+	case DO_LOC:
+	case DO_LOC_VARYING:
+	  /* decrement iteration counter by one */
+	  chill_expand_assignment (ip->iter_var, MINUS_EXPR, integer_one_node);
+	  /* exit if it's zero */
+	  expand_exit_loop_if_false (0,
+	    build (NE_EXPR, boolean_type_node, 
+		   ip->iter_var,
+		   integer_zero_node));
+	  break;
+	case DO_POWERSET:
+	  break;
+	default:
+	  ;
+	}
+    }
+
+  return firstp->error_flag;
+}
+
+/*
+ * increment the loop-control variables.
+ */
+static int
+increment_temps ()
+{
+  ITERATOR *firstp = loop_stack->iter_list, *ip;
+
+  for (ip  = firstp; ip != NULL; ip = ip->next)
+    {
+      switch (ip->itype)
+	{
+	case DO_FOREVER:
+	case DO_WHILE:
+	  break;
+	case DO_STEP:
+	case DO_RANGE:
+	  {
+	    tree delta =
+	      fold (build (ip->down_flag ? MINUS_EXPR : PLUS_EXPR,
+			   TREE_TYPE (ip->user_var), ip->user_var,
+			   ip->step_temp));
+ 	    expand_expr_stmt (
+	      build_chill_modify_expr (ip->user_var, delta));
+	  }
+	  break;
+	case DO_LOC:
+	case DO_LOC_VARYING:
+	  /* This statement uses the C semantics, so that 
+	     the pointer is actually incremented by the 
+	     length of the object pointed to. */
+#if 1
+	  expand_expr_stmt (
+	    build_modify_expr (ip->loc_ptr_temp, 
+			       ip->down_flag ? MINUS_EXPR : PLUS_EXPR,
+			       integer_one_node));
+#else
+	  {
+	    enum tree_code op = ip->down_flag ? MINUS_EXPR : PLUS_EXPR;
+	    tree el_type = TREE_TYPE (TREE_TYPE (ip->loc_ptr_temp));
+	    chill_expand_assignment (ip->loc_ptr_temp, NOP_EXPR,
+				     build (op,
+					    TREE_TYPE (ip->loc_ptr_temp),
+					    ip->loc_ptr_temp,
+					    size_in_bytes (el_type)));
+	  }
+#endif
+	  break;
+	case DO_POWERSET:
+	  break;
+	default:
+	  ;
+	}
+    }
+  return firstp->error_flag;
+}
+
+/*
+ * Generate a (temporary) unique identifier_node of
+ * the form "__tmp_%s_%d"
+ */
+tree
+get_unique_identifier (lead)
+     char *lead;
+{
+  char idbuf [256];
+  static int idcount = 0;
+
+  sprintf (idbuf, "__tmp_%s_%d", lead ? lead : "", idcount++);
+  return get_identifier (idbuf);
+}
+
+/*
+ * build a temporary variable, given its NAME and TYPE.
+ * The name will have a number appended to assure uniqueness.
+ * return its DECL node.
+ */
+static tree
+build_temporary_variable (name, type)
+     char *name;
+     tree type;
+{
+  return decl_temp1 (get_unique_identifier (name), type, 0, NULL_TREE, 0, 0);
+}
+
+
+/*
+ * If the given expression isn't a constant, build a temp for it
+ * and evaluate the expression into the temp.  Return the tree
+ * representing either the original constant expression or the
+ * temp which now contains the expression's value. 
+ */
+static tree
+maybe_make_for_temp (exp, temp_name, exp_type)
+     tree exp;
+     char *temp_name;
+     tree exp_type;
+{
+  tree result = exp;
+
+  if (exp != NULL_TREE)
+    {
+      /* if exp isn't constant, create a temporary for its value */
+      if (TREE_CONSTANT (exp))
+	{
+          /* FIXME: assure that TREE_TYPE (result) == ip->exp_type */
+	  result = convert (exp_type, exp);
+	}
+      else {
+	/* build temp, assign the value */
+	result = decl_temp1 (get_unique_identifier (temp_name), exp_type, 0,
+			     exp, 0, 0);
+      }
+    }
+  return result;
+}
+
+
+/*
+ * Adapt the C unsigned_type function to CHILL - we need to
+ * account for any CHILL-specific integer types here.  So far,
+ * the 16-bit integer type is the only one.
+ */
+static tree
+chill_unsigned_type (type)
+     tree type;
+{
+  extern tree chill_unsigned_type_node;
+  tree type1 = TYPE_MAIN_VARIANT (type);
+
+  if (type1 == chill_integer_type_node)
+    return chill_unsigned_type_node;
+  else
+    return unsigned_type (type);
+}

gcc/ch/parse.h

+typedef union {
+  long itype;
+  tree ttype;
+  enum tree_code code;
+  char *filename;
+  int lineno;
+} YYSTYPE;
+extern YYSTYPE yylval;
+
+enum terminal
+{
+  /*EOF = 0,*/
+  last_char_nonterminal = 256,
+  /* Please keep these in alphabetic order, for easier reference and updating.
+   */
+  ABSOLUTE, ACCESS, AFTER, ALL, ALLOCATE, AND, ANDIF, ARRAY, 
+  ARROW, ASGN, ASM_KEYWORD, ASSERT, ASSOCIATION, AT,
+  BASED, BEGINTOKEN, BIN, BIT, BITSTRING, BODY, BOOLS, BUFFER,
+  BUFFERNAME, BUFFER_CODE, BY,
+  CALL, CASE, CAUSE, CDDEL, CHAR, CHARS, COLON, COMMA, CONCAT, CONST,
+  CONTINUE, CYCLE,
+  DCL, DELAY, DIV, DO, DOT, DOWN, DYNAMIC, 
+  ELSE, ELSIF, END, ENTRY, EQL, ESAC, EVENT, EVENT_CODE, EVER,
+  EXCEPTIONS, EXIT,
+  EXPR, /* an expression that has been pushed back */
+  FI, FLOATING, FOR, FORBID,
+  GENERAL, GOTO, GRANT, GT, GTE,
+  HEADEREL,
+  IF, IGNORED_DIRECTIVE, IN, INIT, INOUT, INLINE,
+  LC, LOC, LPC, LPRN, LT, LTE,
+  MOD, MODULE, MUL, 
+  NAME, NE, NEW, NEWMODE, NONREF, NOT, NUMBER,
+  OD, OF, ON, OR, ORIF,
+  PARAMATTR, PERVASIVE, PLUS, POWERSET,
+  PREFIXED, PRIORITY, PROC, PROCESS,
+  RANGE, RC, READ, READTEXT, RECEIVE, RECURSIVE, REF, REGION, REM,
+  RESULT, RETURN, RETURNS, ROUND, ROW, RPC, RPRN, RPRN_COLON,
+  SAME, SC, SEIZE, SEND, SET, SHARED, SIGNAL, SIGNALNAME, SIMPLE,
+  SINGLECHAR, SPEC, START, STATIC, STEP, STOP, STREAM, STRING, 
+  STRUCT, SUB, SYN, SYNMODE,
+  TERMINATE, TEXT, THEN, THIS, TIMEOUT, TO, TRUNC, TYPENAME, 
+  UP, USAGE,
+  VARYING, 
+  WHERE, WHILE, WITH,
+  XOR,
+
+/* These tokens only used within ch-lex.l to process compiler directives */
+  ALL_STATIC_OFF, ALL_STATIC_ON, EMPTY_OFF, EMPTY_ON,
+  GRANT_FILE_SIZE, PROCESS_TYPE_TOKEN, RANGE_OFF, RANGE_ON,
+  SEND_BUFFER_DEFAULT_PRIORITY, SEND_SIGNAL_DEFAULT_PRIORITY,
+  SIGNAL_CODE, SIGNAL_MAX_LENGTH, USE_SEIZE_FILE, USE_SEIZE_FILE_RESTRICTED,
+  USE_GRANT_FILE, 
+
+  /* These tokens are recognized, and reported as errors, by the lexer. */
+  CONTEXT, REMOTE,
+
+  /* These tokens are recognized in the lexer, and completely
+     ignored. They represent unimplemented features in the
+     current version of GNU CHILL. */
+  NOPACK, PACK,
+
+/* These tokens are recognized in the lexer, and returned
+   as reserved tokens, to prevent users from using them
+   accidently (they'll cause a parser syntax error).  They
+   represent unimplemented features in the current version
+   of GNU CHILL. */
+  POS, /*STEP, ROW,*/
+
+/* This token is passed back to the parser when an the main 
+   input file (not a seize file) has  reached end-of-file. */
+  END_PASS_1,
+
+  EMPTY, UMINUS,
+
+  dummy_last_terminal
+};

gcc/ch/runtime/concatstr.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))
+
+extern void cause_exception (char *exname, char *file, int lineno);
+
+/*
+ * function __concatstring 
+ *
+ * parameters:
+ *     OUT  - pointer to output string
+ *     S1   - pointer to left string
+ *     LEN1 - length of left string
+ *     S2   - pointer to right string
+ *     LEN2 - length of right string
+ *
+ * returns:
+ *     pointer to OUT string
+ *
+ * exceptions:
+ *     none
+ *
+ * abstract:
+ *     concatenates two character strings into the output string
+ *
+ */
+
+char *
+__concatstring (out, s1, len1, s2, len2)
+     char *out, *s1;
+     int   len1;
+     char *s2;
+     int   len2;
+{
+  if (out)
+    {
+      if (s2 /* Check for overlap between s2 and out. */
+	  && ((s2 >= out && s2 < (out + len1 + len2))
+	      || (s2 + len2 > out && s2 <= out + len1)))
+	{
+	  char *tmp = alloca (len2);
+	  memcpy (tmp, s2, len2);
+	  s2 = tmp;
+	}
+      if (s1)
+	memmove (out, s1, len1);
+      if (s2)
+	memcpy (&out[len1], s2, len2);
+    }
+  return out;
+}

gcc/ch/runtime/continue.c

+/* Implement tasking-related 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.  */
+
+#include "rtltypes.h"
+#include "rts.h"
+
+/*
+ * function __continue
+ *
+ * parameters:
+ *     evaddr     pointer to Eventlocation
+ *     filename   source file name where function gets called
+ *     lineno     linenumber in source file
+ *
+ * returns:
+ *     void
+ *
+ * exceptions:
+ *     none
+ *
+ * abstract:
+ *     implement the CHILL CONTINUE action.
+ */
+
+void
+__continue (evaddr, filename, lineno)
+     Event_Queue   **evaddr;
+     char           *filename;
+     int             lineno;
+{
+  Event_Queue  *ev = *evaddr;
+  Event_Queue  *wrk;
+
+  if (ev == 0)
+    /* nothing to do */
+    return;
+
+  /* search for 1st one is not already continued */
+  while (ev && ev->is_continued)
+    ev = ev->forward;
+  if (!ev)
+    /* all have been continued in that queue, do nothing */
+    return;
+
+  wrk = ev->startlist;
+  while (wrk)
+    {
+      Event_Queue     *tmp = (Event_Queue *)wrk->listhead;
+      
+      while (tmp->forward != wrk)
+	tmp = tmp->forward;
+      tmp->forward = wrk->forward;
+      wrk = wrk->chain;
+    }
+
+  /* so far so good, continue this one */
+  ev->is_continued = 1;
+  ev->who_continued = THIS;
+
+  /* tell the runtime system to activate the process */
+  __continue_that (ev->this, ev->priority, filename, lineno);
+}
+
+/* force function print_event to be linked */
+extern void __print_event ();
+static EntryPoint pev = __print_event;

gcc/ch/runtime/convdurrtstime.c

+/* Implement timing-related 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.  */
+
+#include "rts.h"
+
+/*
+ * function __convert_duration_rtstime
+ *
+ * parameters:
+ *      dur     the duration value
+ *      t       pointer to the duration value converted to RtsTime
+ *
+ * returns:
+ *      void
+ *
+ * exceptions:
+ *      none
+ *
+ * abstract:
+ *      converts a duration value (unsigned long in millisecs) to RtsTime
+ *      format.
+ *
+ */
+
+void
+__convert_duration_rtstime (dur, t)
+     unsigned long  dur;
+     RtsTime       *t;
+{
+  unsigned long tmp;
+    
+  t->secs = dur / 1000;
+  tmp = dur - (t->secs * 1000);
+  t->nanosecs = tmp * 1000000;
+}

gcc/ch/runtime/ffsetclrps.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 __ffsetclrpowerset
+ *
+ * parameters:
+ *	ps		powerset
+ *	bitlength	length of powerset
+ *
+ * returns:
+ *	int		-1 .. nothing found
+ *			>=0 .. index of first true bit found
+ * exceptions:
+ *  none
+ */
+
+int
+__ffsetclrpowerset (ps, bitlength, first_bit)
+     SET_WORD      *ps;
+     unsigned long  bitlength;
+     int first_bit;
+{
+  register int bitno;
+
+  if (first_bit >= bitlength)
+    return -1;
+
+#ifndef USE_CHARS
+  if (bitlength <= SET_CHAR_SIZE)
+    {
+      for (bitno = first_bit; bitno < bitlength; bitno++)
+	if (GET_BIT_IN_CHAR (*((SET_CHAR *)ps), bitno))
+	  break;
+      return bitno == bitlength ? -1 : bitno;
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      for (bitno = first_bit; bitno < bitlength; bitno++)
+	if (GET_BIT_IN_SHORT (*((SET_SHORT *)ps), bitno))
+	  break;
+      return bitno == bitlength ? -1 : bitno;
+    }
+  else
+#endif
+    {
+      unsigned int words_to_skip = (unsigned) first_bit / SET_WORD_SIZE;
+      unsigned long cnt = words_to_skip * SET_WORD_SIZE;
+      SET_WORD	*p = ps + words_to_skip;
+      SET_WORD	*endp = ps + BITS_TO_WORDS(bitlength);
+      SET_WORD	c;
+      first_bit = (unsigned) first_bit % (unsigned) SET_WORD_SIZE;
+
+      c = *p++;
+      if (c)
+	{
+	  for (bitno = first_bit; bitno < SET_WORD_SIZE; bitno++)
+	    if (GET_BIT_IN_WORD(c, bitno))
+	      goto found;
+	}
+      cnt += SET_WORD_SIZE;
+
+      while (p < endp)
+	{
+	  if ((c = *p++))
+	    {
+	      /* found a bit set .. calculate which */
+	      for (bitno = 0; bitno < SET_WORD_SIZE; bitno++)
+		if (GET_BIT_IN_WORD(c, bitno))
+		  goto found;
+	    }
+	  cnt += SET_WORD_SIZE;
+	}
+      return -1;
+    found:
+      bitno += cnt;
+      return bitno >= bitlength ? -1 : bitno;
+    }
+}

gcc/ch/runtime/flsetclrps.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 __flsetclrpowerset
+ *
+ * parameters:
+ *	ps		powerset
+ *	bitlength	length of powerset
+ *
+ * returns:
+ *	int		-1 .. nothing found
+ *			>= 0 .. index of last set bit
+ * exceptions:
+ *  none
+ *
+ * abstract:
+ *  Find last bit set in a powerset and return the corresponding value
+ *  in *out and clear this bit. Return 0 for no more found, else 1.
+ *
+ */
+int
+__flsetclrpowerset (ps, bitlength, first_bit)
+     SET_WORD      *ps;
+     unsigned long  bitlength;
+     int first_bit;
+{
+  register int bitno;
+
+#ifndef USE_CHARS
+  if (bitlength <= SET_CHAR_SIZE)
+    {
+      for (bitno = bitlength - 1; bitno >= first_bit; bitno--)
+	if (GET_BIT_IN_CHAR (*((SET_CHAR *)ps), bitno))
+	  break;
+      return bitno < first_bit ? -1 : bitno;
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      for (bitno = bitlength - 1; bitno >= first_bit; bitno--)
+	if (GET_BIT_IN_SHORT (*((SET_SHORT *)ps), bitno))
+	  break;
+      return bitno < first_bit ? -1 : bitno;
+    }
+  else
+#endif
+    {
+      SET_WORD *p, c;
+      bitno = bitlength - 1;
+      if (bitno < first_bit)
+	return -1;
+      p = &ps[(unsigned) bitno / SET_WORD_SIZE];
+      c = *p;
+      if (((unsigned) bitlength % SET_WORD_SIZE) != 0)
+	MASK_UNUSED_WORD_BITS(&c, (unsigned) bitlength % SET_WORD_SIZE);
+      if (c)
+	goto found;
+      else
+	bitno -= ((unsigned) bitno % SET_WORD_SIZE) + 1;
+      while (bitno >= first_bit)
+	{
+	  c = *--p;
+	  if (c)
+	    goto found;
+	  bitno -= SET_WORD_SIZE;
+	}
+      return -1;
+    found:
+      for (; bitno >= first_bit; bitno--)
+	{
+	  if (GET_BIT_IN_WORD (c, (unsigned) bitno % SET_WORD_SIZE))
+	    return bitno;
+	}
+      return -1;
+    }
+}

gcc/ch/runtime/leps.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 __lepowerset
+ *
+ * parameters:
+ *	left		powerset
+ *	right		powerset
+ *	bitlength	length of powerset
+ *
+ * returns:
+ *	int		1 .. left is included in right
+ *			0 .. not
+ *
+ * abstract:
+ *  check if one powerset is included in another
+ *
+ */
+int
+__lepowerset (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;
+      return 1;
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      if ((*((SET_SHORT *)left) & *((SET_SHORT *)right))
+	  != *((SET_SHORT *)left))
+	return 0;
+      return 1;
+    }
+  else
+    {
+      SET_WORD *endp = left + BITS_TO_WORDS(bitlength);
+    
+      while (left < endp)
+	{
+	  if ((*right & *left) != *left)
+	    return 0;
+	  left++;
+	  right++;
+	}
+      return 1;
+    }
+}

gcc/ch/runtime/powerset.h

+/* Common macros for 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.  */
+
+#ifndef _POWERSET_H
+#define _POWERSET_H
+
+#define USE_CHARS
+
+#ifdef USE_CHARS
+
+#define SET_WORD unsigned char
+#define SET_CHAR  unsigned char
+#define SET_SHORT unsigned char
+
+#else
+
+#ifndef SET_WORD
+#define SET_WORD unsigned int
+#endif
+#define SET_CHAR  unsigned char
+#define SET_SHORT unsigned short
+#endif
+
+#define SET_WORD_SIZE (BITS_PER_UNIT * sizeof (SET_WORD))
+#define SET_SHORT_SIZE (BITS_PER_UNIT * sizeof (SET_SHORT))
+#define SET_CHAR_SIZE BITS_PER_UNIT
+
+/* Powersets and bit strings are stored as arrays of SET_WORD.
+   if they are a word or longer.  Powersets and bit strings whic
+   fit in a byte or short are stored that way by the compiler.
+
+   The order of the bits follows native bit order:
+   If BITS_BIG_ENDIAN, bit 0 is the most significant bit (i.e. 0x80..00);
+   otherwise, bit 0 is the least significant bit (i.e. 0x1).
+
+   MASK_UNUSED_BITS masks out unused bits in powersets and bitstrings.
+   GET_BIT_IN_WORD(W,B) yields 1 (or 0) if the B'th bit if W is set (cleared).
+*/
+
+#if BITS_BIG_ENDIAN
+#define GET_BIT_IN_WORD(w,b) (((w) >> (SET_WORD_SIZE - 1 - (b))) & 1)
+#define GET_BIT_IN_SHORT(w,b) (((w) >> (SET_SHORT_SIZE - 1 - (b))) & 1)
+#define GET_BIT_IN_CHAR(w,b) (((w) >> (SET_CHAR_SIZE - 1 - (b))) & 1)
+
+#define SET_BIT_IN_WORD(w,b) ((w) |= 1 << ((SET_WORD_SIZE) - 1 - (b)))
+#define SET_BIT_IN_SHORT(w,b) ((w) |= 1 << ((SET_SHORT_SIZE) - 1 - (b)))
+#define SET_BIT_IN_CHAR(w,b) ((w) |= 1 << ((SET_CHAR_SIZE) - 1 - (b)))
+
+#define CLEAR_BIT_IN_WORD(w,b) ((w) &= ~(1 << ((SET_WORD_SIZE) - 1 - (b))))
+#define CLEAR_BIT_IN_SHORT(w,b) ((w) &= ~(1 << ((SET_SHORT_SIZE) - 1 - (b))))
+#define CLEAR_BIT_IN_CHAR(w,b) ((w) &= ~(1 << ((SET_CHAR_SIZE) - 1 - (b))))
+#define MASK_UNUSED_WORD_BITS(p,b)		   \
+{ if (b) *(p) &= (~0) << (SET_WORD_SIZE - (b)); }
+#define MASK_UNUSED_SHORT_BITS(p,b)		   \
+{ if (b) *(p) &= (~0) << (SET_SHORT_SIZE - (b)); }
+#define MASK_UNUSED_CHAR_BITS(p,b)                 \
+{ if (b) *(p) &= (~0) << (SET_CHAR_SIZE - (b)); }
+
+#else /* !BITS_BIG_ENDIAN */
+
+#define GET_BIT_IN_WORD(w,b) (((w) >> (b)) & 1)
+#define GET_BIT_IN_SHORT(w,b) GET_BIT_IN_WORD(w,b)
+#define GET_BIT_IN_CHAR(w,b) GET_BIT_IN_WORD(w,b)
+
+#define SET_BIT_IN_WORD(w,b) ((w) |= 1 << (b))
+#define SET_BIT_IN_SHORT(w,b) SET_BIT_IN_WORD(w,b)
+#define SET_BIT_IN_CHAR(w,b) SET_BIT_IN_WORD(w,b)
+
+#define CLEAR_BIT_IN_WORD(w,b) ((w) &= ~(1 << (b)))
+#define CLEAR_BIT_IN_SHORT(w,b) CLEAR_BIT_IN_WORD(w,b)
+#define CLEAR_BIT_IN_CHAR(w,b) CLEAR_BIT_IN_WORD(w,b)
+
+#define MASK_UNUSED_WORD_BITS(p,b)  \
+{ if (b) *(p) &= ~((~0) << (b)); }
+#define MASK_UNUSED_SHORT_BITS(p,b) MASK_UNUSED_WORD_BITS(p,b)
+#define MASK_UNUSED_CHAR_BITS(p,b) MASK_UNUSED_WORD_BITS(p,b)
+
+#endif
+
+
+/* Number of words needed for a bitstring/powerset of size BITLENGTH.
+   This definition handles the (BITLENGTH==0) by yielding 0. */
+
+#define BITS_TO_WORDS(BITLENGTH) \
+  (((BITLENGTH) + (SET_WORD_SIZE-1)) / SET_WORD_SIZE)
+#define BITS_TO_CHARS(BITLENGTH) \
+  (((BITLENGTH) + (SET_CHAR_SIZE-1)) / SET_CHAR_SIZE)
+
+#endif

gcc/ch/runtime/queuelength.c

+/* Implement tasking-related 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.  */
+
+#include "rtltypes.h"
+#include "rts.h"
+
+/*
+ * function __queue_length
+ *
+ * parameters:
+ *     buf_ev      Buffer or event location
+ *     is_event    0 .. buf_ev is a buffer location
+ *                 1 .. buf_ev is an event location
+ *
+ * returns:
+ *     int         number of delayed processeson an event location
+ *                 or number of send delayed processes on a buffer
+ *
+ * exceptions:
+ *     none
+ *
+ * abstract:
+ *     implements the QUEUE_LENGTH built-in.
+ *
+ */
+
+int
+__queue_length (buf_ev, is_event)
+     void  *buf_ev;
+     int    is_event;
+{
+  int            retval = 0;
+  
+  /* if buf_ev == 0 then we don't have anything */
+  if (buf_ev == 0)
+    return 0;
+
+  if (is_event)
+    {
+      /* process an event queue */
+      Event_Queue   *ev = buf_ev;
+
+      while (ev)
+	{
+	  retval++;
+	  ev = ev->forward;
+	}
+    }
+  else
+    {
+      /* process a buffer queue */
+      Buffer_Queue *bq = buf_ev;
+      Buffer_Send_Queue *bsq = bq->sendqueue;
+
+      while (bsq)
+	{
+	  retval++;
+	  bsq = bsq->forward;
+	}
+    }
+  return retval;
+}

gcc/ch/runtime/readrecord.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>
+#include <stdlib.h>
+#include <errno.h>
+#include <unistd.h>
+
+#include "fileio.h"
+
+#ifdef EOF
+#undef EOF
+#endif
+#define EOF -1
+
+static
+Boolean
+doRead( Access_Mode* the_access, void* buf, size_t nbyte )
+{
+  size_t nread;
+
+  nread = read( the_access->association->handle, buf, nbyte );
+  if( nread == nbyte )
+  {
+    CLR_FLAG( the_access, IO_OUTOFFILE );
+    return True;
+  }
+  if( nread == 0 )
+  {
+    SET_FLAG( the_access, IO_OUTOFFILE );
+    return False;
+  }
+  the_access->association->syserrno = errno;
+  RWEXCEPTION( READFAIL, OS_IO_ERROR );
+  /* no return */
+}
+
+static
+int bgetc( int handle, readbuf_t* rbptr )
+{
+  if( rbptr->cur >= rbptr->len )
+    {
+      rbptr->len = read( handle, rbptr->buf, READBUFLEN );
+      if( rbptr->len == 0 )
+	return EOF;
+      rbptr->cur = 0;
+    }
+  return rbptr->buf[rbptr->cur++];
+}
+
+static
+void bungetc( readbuf_t* rbptr, int c )
+{
+  rbptr->buf[--rbptr->cur] = c;
+}
+
+void*
+__readrecord( Access_Mode*  the_access,
+              signed long   the_index,
+              char*         the_buf_addr,
+              char*         file,
+              int           line )
+{
+  unsigned long  info;
+  char*          actaddr;
+  unsigned short actlen;
+  off_t          filepos;
+  unsigned short reclen;
+  unsigned long  readlen;
+
+  if( !the_access )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_ACCESS );
+
+  if( !the_access->association )
+    CHILLEXCEPTION( file, line, NOTCONNECTED, IS_NOT_CONNECTED );
+
+  /* Usage must not be WriteOnly */
+  if( the_access->association->usage == WriteOnly )
+    CHILLEXCEPTION( file, line, READFAIL, BAD_USAGE );
+
+  /* OUTOFFILE must not be True when connected for sequential read */
+  if( !TEST_FLAG( the_access, IO_INDEXED )
+      && TEST_FLAG( the_access, IO_OUTOFFILE ) )
+    CHILLEXCEPTION( file, line, READFAIL, OUT_OF_FILE );
+
+  /*
+   *  Positioning
+   */
+  if( TEST_FLAG( the_access, IO_INDEXED ) )
+  {
+    /* index expression must be within bounds of index mode */
+    if( the_index < the_access->lowindex
+        || the_access->highindex < the_index ) 
+      CHILLEXCEPTION( file, line, RANGEFAIL, BAD_INDEX );
+
+    filepos = the_access->base + 
+              (the_index - the_access->lowindex) * the_access->reclength;
+
+    if( lseek( the_access->association->handle, filepos, SEEK_SET ) == -1L )
+      CHILLEXCEPTION( file, line, READFAIL, LSEEK_FAILS );
+  }
+
+  /* establish store loc */
+  if( !(actaddr = the_buf_addr ))
+  {
+    /* if not yet allocated, do it now */
+    if (!the_access->store_loc)
+      if( !(the_access->store_loc = (char*)malloc( the_access->reclength ) ) )
+	CHILLEXCEPTION( file, line, SPACEFAIL, STORE_LOC_ALLOC );
+    actaddr = the_access->store_loc;
+  }
+  actlen  = the_access->reclength;
+
+  if( (info = setjmp( __rw_exception )) )
+    CHILLEXCEPTION( file, line, info>>16, info & 0xffff );
+
+  if( TEST_FLAG( the_access, IO_TEXTIO ) )
+  {
+    readlen = actlen - 2;
+    if( TEST_FLAG( the_access, IO_INDEXED ) )
+    {
+      if( ! doRead( the_access, &reclen, sizeof(reclen) ) )
+        return NULL;
+      if( reclen > readlen )
+        CHILLEXCEPTION( file, line, RANGEFAIL, RECORD_TOO_LONG );
+      if( ! doRead( the_access, actaddr + 2, reclen ) )
+        CHILLEXCEPTION( file, line, READFAIL, RECORD_TOO_SHORT );
+    }
+    else
+    { 
+      Association_Mode *assoc = the_access->association;
+      int              handle = assoc->handle;
+      readbuf_t*       rbuf   = assoc->bufptr;
+      char* cptr = actaddr+2;
+      int   curr;
+
+      reclen = 0;
+      while( readlen-- )
+      {
+        curr = bgetc( handle, rbuf );
+        if( curr == '\n' )
+          goto end_of_line;
+        if( curr == EOF )
+	{
+          if( !reclen )
+            SET_FLAG( the_access, IO_OUTOFFILE );
+          goto end_of_line;
+	}
+        *cptr++ = curr;
+        reclen++;
+      }
+      if( (curr = bgetc( handle, rbuf )) != '\n' )
+	{
+	  bungetc( rbuf, curr );
+	  CHILLEXCEPTION( file, line, RANGEFAIL, RECORD_TOO_LONG );
+	}
+end_of_line: ;
+    }
+    MOV2(actaddr,&reclen);
+  }
+  else
+  {
+    switch( the_access->rectype )
+    {
+    case Fixed:
+      if( ! doRead( the_access, actaddr, actlen ) )
+        return NULL;
+      break;
+    case VaryingChars:
+      if( TEST_FLAG( the_access->association, IO_VARIABLE ) )
+      {
+        if( ! doRead( the_access, &reclen, sizeof(reclen) ) )
+          return NULL;
+        if( reclen > actlen - 2 )
+          CHILLEXCEPTION( file, line, RANGEFAIL, RECORD_TOO_LONG );
+        readlen = TEST_FLAG( the_access, IO_INDEXED ) ? actlen - 2 : reclen;
+        if( ! doRead( the_access, actaddr + 2, readlen ) )
+          CHILLEXCEPTION( file, line, READFAIL, RECORD_TOO_SHORT );
+      }
+      else
+      {
+        if( ! doRead( the_access, actaddr + 2, reclen = actlen - 2 ) )
+          CHILLEXCEPTION( file, line, READFAIL, RECORD_TOO_SHORT );
+      }
+      MOV2(actaddr,&reclen);
+      break;
+    }
+  }
+
+  return actaddr;
+}

gcc/ch/runtime/rtsdummy.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>
+/*#include "gvarargs.h"	Gcc source and runtime libs use gvarargs.h */
+
+#include "rtltypes.h"
+
+typedef void (*init_ptr) ();
+typedef int * tasking_ptr;
+
+/* Dummy functions for rts access. When we come here we have an error. */
+
+typedef char *(*fetch_names) (int number);
+typedef int (*fetch_numbers) (char *name);
+
+static void __rts_main_loop ()
+{
+  /* do nothing in case of no run time system */
+}
+init_ptr	__RTS_MAIN_LOOP__ = __rts_main_loop;
+
+static void __rts_init ()
+{
+  /* do nothing in case of no run time system */
+}
+init_ptr	__RTS_INIT__ = __rts_init;
+
+static char *__fetch_name (int number)
+{
+    fprintf (stderr, "ChillLib: fetch_name: no runtime system library linked.\n");
+    fflush (stderr);
+    abort ();
+}
+fetch_names	__RTS_FETCH_NAMES__ = __fetch_name;
+
+static int __fetch_number (char *name)
+{
+    fprintf (stderr, "ChillLib: fetch_number: no runtime system library linked.\n");
+    fflush (stderr);
+    abort ();
+}
+fetch_numbers	__RTS_FETCH_NUMBERS__ = __fetch_number;

gcc/ch/runtime/sequencible.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"
+
+Boolean
+__sequencible( 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 );
+  return TEST_FLAG(the_assoc, IO_SEQUENCIBLE) ? True : False;
+}
+

gcc/ch/runtime/setbitps.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 __setbitpowerset
+ *
+ * parameters:
+ *	set		destination set
+ *	bitlength	length of powerset in bits
+ *      minval          lowest valid set value
+ *      bitno           bit number within set
+ *      new_value       zero or one - (new bit value)
+ *
+ * returns:
+ *	int		1 .. found
+ *			0 .. not found
+ *
+ * exceptions:
+ *  rangefail
+ *
+ * abstract:
+ *  checks if a given value is included in a powerset
+ *
+ */
+void
+__setbitpowerset (powerset, bitlength, minval, bitno, new_value, filename, lineno)
+     SET_WORD      *powerset;
+     unsigned long  bitlength;
+     long           minval;
+     long	    bitno;
+     char	    new_value; /* booleans are represented as 8 bit value */
+     char *	    filename;
+     int	    lineno;
+{
+  if (powerset == NULL
+      || bitno < minval 
+      || (bitno - minval) >= bitlength)
+    __cause_ex1 ("rangefail", filename, lineno);
+
+  bitno -= minval;
+  if (bitlength <= SET_CHAR_SIZE)
+    {
+      if (new_value & 1)
+	SET_BIT_IN_CHAR (*((SET_CHAR *)powerset), bitno);
+      else
+	CLEAR_BIT_IN_CHAR (*((SET_CHAR *)powerset), bitno);
+    }
+  else if (bitlength <= SET_SHORT_SIZE)
+    {
+      if (new_value & 1)
+	SET_BIT_IN_SHORT (*((SET_SHORT *)powerset), bitno);
+      else
+	CLEAR_BIT_IN_SHORT (*((SET_SHORT *)powerset), bitno);
+    }
+  else
+    {
+      powerset += (bitno/SET_WORD_SIZE);
+      bitno %= SET_WORD_SIZE;
+      if (new_value & 1)
+	SET_BIT_IN_WORD (*powerset, bitno);
+      else
+	CLEAR_BIT_IN_WORD (*powerset, bitno);
+    }
+}

gcc/ch/runtime/setbits.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 __setbits
+ *
+ * parameters:
+ *	out		result
+ *      bitlength       length of bitstring in bits
+ *	startbit	starting bitnumber
+ *	endbit		ending bitnumber
+ *
+ * returns:
+ *	void
+ *
+ * exceptions:
+ *   rangefail
+ *
+ * abstract:
+ *  set all bits from starting bitnumber to ending bitnumber
+ *  in a powerset
+ *
+ */
+void
+__setbits (out, bitlength, startbit, endbit)
+     SET_WORD      *out;
+     unsigned long  bitlength;
+     long  startbit;
+     long  endbit;
+{
+  unsigned long i;
+  
+  if (out == NULL
+      || startbit < 0
+      || startbit >= bitlength 
+      || endbit < 0
+      || endbit >= bitlength 
+      || endbit < startbit)
+    __cause_ex1 ("rangefail", "__setbits", __LINE__);
+  
+  if (bitlength <= SET_CHAR_SIZE)
+    for (i = startbit; i <= endbit; i++)
+      SET_BIT_IN_CHAR (*((SET_CHAR *)out), i);
+  else if (bitlength <= SET_SHORT_SIZE)
+    for (i = startbit; i <= endbit; i++)
+      SET_BIT_IN_SHORT (*((SET_SHORT *)out), i);
+  else
+    {
+      SET_WORD	*p;
+      unsigned long       bitnr;
+      
+      /* FIXME - this is inefficient! */
+      for (i = startbit; i <= endbit; i++)
+	{
+	  p = out + (i / SET_WORD_SIZE);
+	  bitnr = i % SET_WORD_SIZE;
+	  SET_BIT_IN_WORD (*p, bitnr);
+	}
+    }
+} 

gcc/ch/runtime/settextindex.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"
+
+void
+__settextindex( Text_Mode*  the_text,
+                signed long the_text_index, 
+                char*       file,
+                int         line )
+{
+  if( !the_text )
+    CHILLEXCEPTION( file, line, EMPTY, NULL_TEXT );
+
+  if( the_text_index < 0 
+      || the_text->access_sub->reclength - 2 < the_text_index )
+    CHILLEXCEPTION( file, line, TEXTFAIL, BAD_TEXTINDEX );
+  
+  the_text->actual_index = the_text_index;
+}
+

gcc/ch/runtime/variable.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"
+
+Boolean
+__variable( 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 );
+  return TEST_FLAG( the_assoc, IO_VARIABLE ) ? True : False;
+}

gcc/ch/runtime/writeable.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"
+
+Boolean
+__writeable( 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 );
+  return TEST_FLAG(the_assoc, IO_WRITEABLE) ? True : False;
+}

gcc/ch/tasking.h

+/* Implement process-related declarations 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.  */
+
+#ifndef _CH_TASKING_H
+#define _CH_TASKING_H
+
+/* list of this module's process, buffer, etc. decls */
+extern tree tasking_list;
+
+#endif

gcc/ch/tree.c

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