path: root/gcc/ch/grant.c

/* Implement grant-file output & seize-file input for CHILL.
   Copyright (C) 1992, 93-96, 98, 99, 2000 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, 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

#include "config.h"
#include "system.h"
#include "tree.h"
#include "ch-tree.h"
#include "lex.h"
#include "flags.h"
#include "actions.h"
#include "input.h"
#include "rtl.h"
#include "tasking.h"
#include "toplev.h"
#include "output.h"

#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 tree process_type;
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 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                PARAMS ((tree));
static MYSTRING *decode_constant            PARAMS ((tree));
static void      grant_one_decl             PARAMS ((tree));
static MYSTRING *get_type                   PARAMS ((tree));
static MYSTRING *decode_mode                PARAMS ((tree));
static MYSTRING *decode_prefix_rename       PARAMS ((tree));
static MYSTRING *decode_constant_selective  PARAMS ((tree, tree));
static MYSTRING *decode_mode_selective      PARAMS ((tree, tree));
static MYSTRING *get_type_selective         PARAMS ((tree, tree));
static MYSTRING *decode_decl_selective      PARAMS ((tree, tree));
static MYSTRING *newstring                  PARAMS ((const char *));
static void strfree                         PARAMS ((MYSTRING *));
static MYSTRING *append                     PARAMS ((MYSTRING *, const char *));
static MYSTRING *prepend                    PARAMS ((MYSTRING *, const char *));
static void grant_use_seizefile             PARAMS ((const char *));
static MYSTRING *decode_layout              PARAMS ((tree));
static MYSTRING *grant_array_type           PARAMS ((tree));
static MYSTRING *grant_array_type_selective PARAMS ((tree, tree));
static MYSTRING *get_tag_value              PARAMS ((tree));
static MYSTRING *get_tag_value_selective    PARAMS ((tree, tree));
static MYSTRING *print_enumeral             PARAMS ((tree));
static MYSTRING *print_enumeral_selective   PARAMS ((tree, tree));
static MYSTRING *print_integer_type         PARAMS ((tree));
static tree find_enum_parent                PARAMS ((tree, tree));
static MYSTRING *print_integer_selective    PARAMS ((tree, tree));
static MYSTRING *print_struct               PARAMS ((tree));
static MYSTRING *print_struct_selective     PARAMS ((tree, tree));
static MYSTRING *print_proc_exceptions      PARAMS ((tree));
static MYSTRING *print_proc_tail            PARAMS ((tree, tree, int));
static MYSTRING *print_proc_tail_selective  PARAMS ((tree, tree, tree));
static tree find_in_decls                   PARAMS ((tree, tree));
static int in_ridpointers                   PARAMS ((tree));
static void grant_seized_identifier         PARAMS ((tree));
static void globalize_decl                  PARAMS ((tree));
static void grant_one_decl_selective        PARAMS ((tree, tree));
static int compare_memory_file              PARAMS ((const char *, const char *));
static int search_in_list                   PARAMS ((tree, tree));
static int really_grant_this                PARAMS ((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)
    const 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;
    const 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;
    const char	*in;
{
  MYSTRING *res = inout;
  if (strlen (in))
    {
      res = newstring (in);
      res = APPEND (res, inout->str);
      FREE (inout);
    }
  return res;
}

static void
grant_use_seizefile (seize_filename)
     const 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, HOST_WIDE_INT_PRINT_DEC,
		   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;
  const 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;
  const 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:
      {
	const 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;
  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 ((int)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)
    const char	*fname;
    const 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)
    {
      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 ()
{
    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 ATTRIBUTE_UNUSED, decl ATTRIBUTE_UNUSED;
{
#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;
    default:
      break;
    }

  /* 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;
#define 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)
			    + sizeof (HEADER_TEMPLATE) /* includes \0 */);
      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;
    }
}