From Phil Blundell:

[official-gcc.git] / gcc / ch / decl.c

/* Process declarations and variables for GNU CHILL compiler.
   Copyright (C) 1992, 93, 1994, 1998, 1999 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.  */


/* Process declarations and symbol lookup for CHILL front end.
   Also constructs types; the standard scalar types at initialization,
   and structure, union, array and enum types when they are declared.  */

/* NOTES on Chill name resolution
   
   Chill allows one to refer to an identifier that is declared later in
   the same Group.  Hence, a single pass over the code (as in C) is
   insufficient.
   
   This implementation uses two complete passes over the source code,
   plus some extra passes over internal data structures.
   
   Loosely, during pass 1, a 'scope' object is created for each Chill
   reach.  Each scope object contains a list of 'decl' objects,
   one for each 'defining occurrence' in the reach.  (This list
   is in the 'remembered_decls' field of each scope.)
   The scopes and their decls are replayed in pass 2:  As each reach
   is entered, the decls saved from pass 1 are made visible.
   
   There are some exceptions.  Declarations that cannot be referenced
   before their declaration (i.e. whose defining occurrence precede
   their reach), can be deferred to pass 2.  These include formal
   parameter declarations, and names defined in a DO action.
   
   During pass 2, as each scope is entered, we must make visible all
   the declarations defined in the scope, before we generate any code.
   We must also simplify the declarations from pass 1:  For example
   a VAR_DECL may have a array type whose bounds are expressions;
   these need to be folded.  But of course the expressions may contain
   identifiers that may be defined later in the scope - or even in
   a different module.
   
   The "satisfy" process has two main phases:
   
   1: Binding. Each identifier *referenced* in a declaration (i.e. in
   a mode or the RHS of a synonum declaration) must be bound to its
   defining occurrence.  This may need to be linking via
   grants and/or seizes (which are represented by ALIAS_DECLs).
   A further complication is handling implied name strings.
   
   2: Layout. Each CONST_DECL or TYPE_DECL *referenced* in a declaration
   must than be replaced by its value (or type).  Constants must be
   folded.  Types and declarstions must be laid out.  DECL_RTL must be set.
   While doing this, we must watch out for circular dependencies.
   
   If a scope contains nested modulions, then the Binding phase must be
   done for each nested module (recursively) before the Layout phase
   can start for that scope.  As an example of why this is needed, consider:
   
   M1: MODULE
     DCL a ARRAY [1:y] int; -- This should have 7 elements.
     SYN x = 5;
     SEIZE y;
   END M1;
   M2: MODULE
     SYN x = 2;
     SYN y = x + 5;
     GRANT y;
   END M2;

   Here, the 'x' in "x + 5" must be Bound to the 'x' in module M2.
   This must be done before we can Layout a.
   The reason this is an issue is that we do *not* have a lookup
   (or hash) table per scope (or module).  Instead we have a single
   global table we we keep adding and removing bindings from.
   (This is both for speed, and because of gcc history.)

   Note that a SEIZE generates a declaration in the current scope,
   linked to something in the surrounding scope.  Determining (binding)
   the link must be done in pass 2.  On the other hand, a GRANT
   generates a declaration in the surrounding scope, linked to
   something in the current scope.  This linkage is Bound in pass 1.

   The sequence for the above example is:
   - Enter the declarations of M1 (i.e. {a, x, y}) into the hash table.
   - For each of {a, x, y}, examine dependent expression (the
     rhs of x, the bounds of a), and Bind any identifiers to
     the current declarations (as found in the hash table).  Specifically,
     the 'y' in the array bounds of 'a' is bound to the 'y' declared by
     the SEIZE declaration.  Also, 'y' is Bound to the implicit
     declaration in the global scope (generated from the GRANT in M2).
   - Remove the bindings for M1 (i.e. {a, x, y}) from the hash table.
   - Enter the declarations of M2 (i.e. {x, y}) into the hash table.
   - For each of {x, y} examine the dependent expressions (the rhs of
     x and y), and Bind any identifiers to their current declarartions
     (in this case the 'x' in "x + 5" is bound to the 'x' that is 2.
   - Remove the bindings for M2 (i.e. {x, y}) from the hash table.
   - Perform Layout for M1:  This requires the size of a, which
     requires the value of y.  The 'y'  is Bound to the implicit
     declaration in the global scope, which is Bound to the declaration
     of y in M2.  We now require the value of this 'y', which is "x + 5"
     where x is bound to the x in M2 (thanks to our previous Binding
     phase).  So we get that the value of y is 7.
   - Perform layout of M2.  This implies calculating (constant folding)
   the value of y - but we already did that, so we're done.   

   An example illustating the problem with implied names:

   M1: MODULE
     SEIZE y;
     use(e);  -- e is implied by y.
   END M1;
   M2: MODULE
     GRANT y;
     SYNMODE y = x;
     SEIZE x;
   END M2;
   M3: MODULE
     GRANT x;
     SYNMODE x = SET (e);
   END M3;

   This implies that determining the implied name e in M1
   must be done after Binding of y to x in M2.

   Yet another nasty:
   M1: MODULE
     SEIZE v;
     DCL a ARRAY(v:v) int;
   END M1;
   M2: MODULE
     GRANT v;
     SEIZE x;
     SYN v x = e;
   END M2;
   M3: MODULE
     GRANT x;
     SYNMODE x = SET(e);
   END M3;

   This one implies that determining the implied name e in M2,
   must be done before Layout of a in M1.

   These two examples togother indicate the determining implieed
   names requries yet another phase.
   - Bind strong names in M1.
   - Bind strong names in M2.
   - Bind strong names in M3.
   - Determine weak names implied by SEIZEs in M1.
   - Bind the weak names in M1.
   - Determine weak names implied by SEIZEs in M2.
   - Bind the weak names in M2.
   - Determine weak names implied by SEIZEs in M3.
   - Bind the weak names in M3.
   - Layout M1.
   - Layout M2.
   - Layout M3.

   We must bind the strong names in every module before we can determine
   weak names in any module (because of seized/granted synmode/newmodes).
   We must bind the weak names in every module before we can do Layout
   in any module.

   Sigh.

   */

/* ??? not all decl nodes are given the most useful possible
   line numbers.  For example, the CONST_DECLs for enum values.  */

#include "config.h"
#include "system.h"
#include "tree.h"
#include "flags.h"
#include "ch-tree.h"
#include "lex.h"
#include "obstack.h"
#include "input.h"
#include "rtl.h"
#include "toplev.h"

#define IS_UNKNOWN_TYPE(type) (TYPE_SIZE(type)==0)
#define BUILTIN_NESTING_LEVEL (-1)

/* For backward compatibility, we define Chill INT to be the same
   as SHORT (i.e. 16 bits), at least if C INT is the same as LONG.
   This is a lose. */
#define CHILL_INT_IS_SHORT (INT_TYPE_SIZE==LONG_TYPE_SIZE)

extern int  ignore_case;
extern tree process_type;
extern struct obstack *saveable_obstack;
extern tree signal_code;
extern int special_UC;

static tree get_next_decl             PROTO((void));
static tree lookup_name_for_seizing   PROTO((tree));
#if 0
static tree lookup_name_current_level PROTO((tree));
#endif
static void save_decl                 PROTO((tree));

extern struct obstack permanent_obstack;
extern int in_pseudo_module;

struct module *current_module = NULL;
struct module *first_module = NULL;
struct module **next_module = &first_module;

extern int  in_pseudo_module;

int module_number = 0;

/* This is only used internally (by signed_type). */

tree signed_boolean_type_node;

tree global_function_decl = NULL_TREE;

/* This is a temportary used by RESULT to store its value.
   Note we cannot directly use DECL_RESULT for two reasons:
   a) If DECL_RESULT is a register, it may get clobbered by a
   subsequent function call; and
   b) if the function returns a struct, we might (visibly) modify the
   destination before we're supposed to. */
tree chill_result_decl;

int result_never_set;

/* forward declarations */
static void pushdecllist                     PROTO((tree, int));
static int  init_nonvalue_struct             PROTO((tree));
static int  init_nonvalue_array              PROTO((tree));

int current_nesting_level = BUILTIN_NESTING_LEVEL;
int current_module_nesting_level = 0;
\f
/* Lots of declarations copied from c-decl.c. */
/* ??? not all decl nodes are given the most useful possible
   line numbers.  For example, the CONST_DECLs for enum values.  */

#if 0
/* In grokdeclarator, distinguish syntactic contexts of declarators.  */
enum decl_context
{ NORMAL,                       /* Ordinary declaration */
    FUNCDEF,                    /* Function definition */
    PARM,                       /* Declaration of parm before function body */
    FIELD,                      /* Declaration inside struct or union */
    BITFIELD,                   /* Likewise but with specified width */
    TYPENAME};                  /* Typename (inside cast or sizeof)  */
#endif

#ifndef CHAR_TYPE_SIZE
#define CHAR_TYPE_SIZE BITS_PER_UNIT
#endif

#ifndef SHORT_TYPE_SIZE
#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2))
#endif

#ifndef INT_TYPE_SIZE
#define INT_TYPE_SIZE BITS_PER_WORD
#endif

#ifndef LONG_TYPE_SIZE
#define LONG_TYPE_SIZE BITS_PER_WORD
#endif

#ifndef LONG_LONG_TYPE_SIZE
#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2)
#endif

#ifndef WCHAR_UNSIGNED
#define WCHAR_UNSIGNED 0
#endif

#ifndef FLOAT_TYPE_SIZE
#define FLOAT_TYPE_SIZE BITS_PER_WORD
#endif

#ifndef DOUBLE_TYPE_SIZE
#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif

#ifndef LONG_DOUBLE_TYPE_SIZE
#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2)
#endif

/* We let tm.h override the types used here, to handle trivial differences
   such as the choice of unsigned int or long unsigned int for size_t.
   When machines start needing nontrivial differences in the size type,
   it would be best to do something here to figure out automatically
   from other information what type to use.  */

#ifndef PTRDIFF_TYPE
#define PTRDIFF_TYPE "long int"
#endif

#ifndef WCHAR_TYPE
#define WCHAR_TYPE "int"
#endif
\f
/* a node which has tree code ERROR_MARK, and whose type is itself.
   All erroneous expressions are replaced with this node.  All functions
   that accept nodes as arguments should avoid generating error messages
   if this node is one of the arguments, since it is undesirable to get
   multiple error messages from one error in the input.  */

tree error_mark_node;

/* INTEGER_TYPE and REAL_TYPE nodes for the standard data types */

tree short_integer_type_node;
tree integer_type_node;
tree long_integer_type_node;
tree long_long_integer_type_node;

tree short_unsigned_type_node;
tree unsigned_type_node;
tree long_unsigned_type_node;
tree long_long_unsigned_type_node;

tree ptrdiff_type_node;

tree unsigned_char_type_node;
tree signed_char_type_node;
tree char_type_node;
tree wchar_type_node;
tree signed_wchar_type_node;
tree unsigned_wchar_type_node;

tree float_type_node;
tree double_type_node;
tree long_double_type_node;

tree complex_integer_type_node;
tree complex_float_type_node;
tree complex_double_type_node;
tree complex_long_double_type_node;

tree intQI_type_node;
tree intHI_type_node;
tree intSI_type_node;
tree intDI_type_node;
#if HOST_BITS_PER_WIDE_INT >= 64
tree intTI_type_node;
#endif

tree unsigned_intQI_type_node;
tree unsigned_intHI_type_node;
tree unsigned_intSI_type_node;
tree unsigned_intDI_type_node;
#if HOST_BITS_PER_WIDE_INT >= 64
tree unsigned_intTI_type_node;
#endif

/* a VOID_TYPE node.  */

tree void_type_node;
tree void_list_node;

/* Nodes for types `void *' and `const void *'.  */
tree ptr_type_node, const_ptr_type_node;

/* type of initializer structure, which points to
   a module's module-level code, and to the next
   such structure. */
tree initializer_type;

/* type of a CHILL predefined value builtin routine */
tree chill_predefined_function_type;

/* type `int ()' -- used for implicit declaration of functions.  */

tree default_function_type;

#if 0
/* function types `double (double)' and `double (double, double)', etc.  */

tree double_ftype_double, double_ftype_double_double;
tree int_ftype_int, long_ftype_long;

/* Function type `void (void *, void *, int)' and similar ones */

tree void_ftype_ptr_ptr_int, int_ftype_ptr_ptr_int, void_ftype_ptr_int_int;

/* Function type `char *(char *, char *)' and similar ones */
tree string_ftype_ptr_ptr, int_ftype_string_string;

/* Function type `int (const void *, const void *, size_t)' */
tree int_ftype_cptr_cptr_sizet;
#endif

char **boolean_code_name;

/* Two expressions that are constants with value zero.
   The first is of type `int', the second of type `void *'.  */

tree integer_zero_node;
tree null_pointer_node;

/* A node for the integer constant 1.  */
tree integer_one_node;

/* A node for the integer constant -1.  */
tree integer_minus_one_node;

/* Nodes for boolean constants TRUE and FALSE. */
tree boolean_true_node, boolean_false_node;

tree string_one_type_node;  /* The type of CHARS(1). */
tree bitstring_one_type_node;  /* The type of BOOLS(1). */
tree bit_zero_node; /* B'0' */
tree bit_one_node; /* B'1' */

/* Nonzero if we have seen an invalid cross reference
   to a struct, union, or enum, but not yet printed the message.  */

tree pending_invalid_xref;
/* File and line to appear in the eventual error message.  */
char *pending_invalid_xref_file;
int pending_invalid_xref_line;

/* After parsing the declarator that starts a function definition,
   `start_function' puts here the list of parameter names or chain of decls.
   `store_parm_decls' finds it here.  */

static tree current_function_parms;

/* Nonzero when store_parm_decls is called indicates a varargs function.
   Value not meaningful after store_parm_decls.  */

static int c_function_varargs;

/* The FUNCTION_DECL for the function currently being compiled,
   or 0 if between functions.  */
tree current_function_decl;

/* These are irrelevant for Chill, but are referenced from from c-typeck.c. */
int warn_format;
int warn_traditional;
int warn_bad_function_cast;

/* Identifiers that hold VAR_LENGTH and VAR_DATA.  */
tree var_length_id, var_data_id;

tree case_else_node;
\f
/* For each binding contour we allocate a scope structure
 * which records the names defined in that contour.
 * Contours include:
 *  0) the global one
 *  1) one for each function definition,
 *     where internal declarations of the parameters appear.
 *  2) one for each compound statement,
 *     to record its declarations.
 *
 * The current meaning of a name can be found by searching the levels from
 * the current one out to the global one.
 */

/* To communicate between pass 1 and 2, we maintain a list of "scopes".
   Each scope corrresponds to a nested source scope/block that contain 
   that can contain declarations.  The TREE_VALUE of the scope points
   to the list of declarations declared in that scope.
   The TREE_PURPOSE of the scope points to the surrounding scope.
   (We may need to handle nested modules later.  FIXME)
   The TREE_CHAIN field contains a list of scope as they are seen
   in chronological order.  (Reverse order during first pass,
   but it is reverse before pass 2.) */

struct scope
{
  /* The enclosing scope. */
  struct scope *enclosing;
  
  /* The next scope, in chronlogical order. */
  struct scope *next;
  
  /* A chain of DECLs constructed using save_decl during pass 1. */
  tree remembered_decls;
  
  /* A chain of _DECL nodes for all variables, constants, functions,
     and typedef types belong to this scope. */
  tree decls;
  
  /* List of declarations that have been granted into this scope. */
  tree granted_decls;

  /* List of implied (weak) names. */
  tree weak_decls;
  
  /* For each level, a list of shadowed outer-level local definitions
     to be restored when this level is popped.
     Each link is a TREE_LIST whose TREE_PURPOSE is an identifier and
     whose TREE_VALUE is its old definition (a kind of ..._DECL node).  */
  tree shadowed;
  
  /* For each level (except not the global one),
     a chain of BLOCK nodes for all the levels
     that were entered and exited one level down.  */
  tree blocks;
  
  /* The BLOCK node for this level, if one has been preallocated.
     If 0, the BLOCK is allocated (if needed) when the level is popped.  */
  tree this_block;
  
  /* The binding level which this one is contained in (inherits from).  */
  struct scope *level_chain;
  
  /* Nonzero for a level that corresponds to a module. */
  char module_flag;
  
  /* Zero means called from backend code. */
  char two_pass;
  
  /* The modules that are directly enclosed by this scope
     are chained together. */
  struct scope* first_child_module;
  struct scope** tail_child_module;
  struct scope* next_sibling_module;
};

/* The outermost binding level, for pre-defined (builtin) names. */

static struct scope builtin_scope = {
  NULL, NULL, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE,
  NULL_TREE, NULL_TREE, NULL, 0, 0, NULL, NULL, NULL};

struct scope *global_scope;

/* The binding level currently in effect.  */

static struct scope *current_scope = &builtin_scope;

/* The most recently seen scope. */
struct scope *last_scope = &builtin_scope;

/* Binding level structures are initialized by copying this one.  */

static struct scope clear_scope = {
  NULL, NULL, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE,
  NULL_TREE, NULL_TREE, NULL, 0, 0, NULL, NULL, NULL};

/* Chain of decls accessible through IDENTIFIER_OUTER_VALUE.
   Decls with the same DECL_NAME are adjacent in the chain. */

static tree outer_decls = NULL_TREE;
\f
/* C-specific option variables.  */

/* Nonzero means allow type mismatches in conditional expressions;
   just make their values `void'.   */

int flag_cond_mismatch;

/* Nonzero means give `double' the same size as `float'.  */

int flag_short_double;

/* Nonzero means don't recognize the keyword `asm'.  */

int flag_no_asm;

/* Nonzero means don't recognize any builtin functions.  */

int flag_no_builtin;

/* Nonzero means don't recognize the non-ANSI builtin functions.
   -ansi sets this.  */

int flag_no_nonansi_builtin;

/* Nonzero means do some things the same way PCC does.  */

int flag_traditional;

/* Nonzero means to allow single precision math even if we're generally
   being traditional. */
int flag_allow_single_precision = 0;

/* Nonzero means to treat bitfields as signed unless they say `unsigned'.  */

int flag_signed_bitfields = 1;
int explicit_flag_signed_bitfields = 0;

/* Nonzero means warn about implicit declarations.  */

int warn_implicit;

/* Nonzero means give string constants the type `const char *'
   to get extra warnings from them.  These warnings will be too numerous
   to be useful, except in thoroughly ANSIfied programs.  */

int warn_write_strings;

/* Nonzero means warn about pointer casts that can drop a type qualifier
   from the pointer target type.  */

int warn_cast_qual;

/* Nonzero means warn about sizeof(function) or addition/subtraction
   of function pointers.  */

int warn_pointer_arith;

/* Nonzero means warn for non-prototype function decls
   or non-prototyped defs without previous prototype.  */

int warn_strict_prototypes;

/* Nonzero means warn for any global function def
   without separate previous prototype decl.  */

int warn_missing_prototypes;

/* Nonzero means warn about multiple (redundant) decls for the same single
   variable or function.  */

int warn_redundant_decls = 0;

/* Nonzero means warn about extern declarations of objects not at
   file-scope level and about *all* declarations of functions (whether
   extern or static) not at file-scope level.  Note that we exclude
   implicit function declarations.  To get warnings about those, use
   -Wimplicit.  */

int warn_nested_externs = 0;

/* Warn about a subscript that has type char.  */

int warn_char_subscripts = 0;

/* Warn if a type conversion is done that might have confusing results.  */

int warn_conversion;

/* Warn if adding () is suggested.  */

int warn_parentheses;

/* Warn if initializer is not completely bracketed.  */

int warn_missing_braces;

/* Define the special tree codes that we use.  */

/* Table indexed by tree code giving a string containing a character
   classifying the tree code.  Possibilities are
   t, d, s, c, r, <, 1 and 2.  See ch-tree.def for details.  */

#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
  
  char chill_tree_code_type[] = {
    'x',
#include "ch-tree.def"
  };
#undef DEFTREECODE

/* Table indexed by tree code giving number of expression
   operands beyond the fixed part of the node structure.
   Not used for types or decls.  */

#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
  
int chill_tree_code_length[] = {
    0,
#include "ch-tree.def"
  };
#undef DEFTREECODE


/* Names of tree components.
   Used for printing out the tree and error messages.  */
#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
  
char *chill_tree_code_name[] = {
    "@@dummy",
#include "ch-tree.def"
  };
#undef DEFTREECODE

/* Nonzero means `$' can be in an identifier.
   See cccp.c for reasons why this breaks some obscure ANSI C programs.  */

#ifndef DOLLARS_IN_IDENTIFIERS
#define DOLLARS_IN_IDENTIFIERS 0
#endif
int dollars_in_ident = DOLLARS_IN_IDENTIFIERS > 1;

/* An identifier that is used internally to indicate
   an "ALL" prefix for granting or seizing.
   We use "*" rather than the external name "ALL", partly for convenience,
   and partly to avoid case senstivity problems. */

tree ALL_POSTFIX;
\f
void
allocate_lang_decl (t)
     tree t ATTRIBUTE_UNUSED;
{
  /* Nothing needed */
}

void
copy_lang_decl (node)
     tree node ATTRIBUTE_UNUSED;
{
  /* Nothing needed */
}

tree
build_lang_decl (code, name, type)
     enum chill_tree_code code;
     tree name;
     tree type;
{
  return build_decl (code, name, type);
}
\f
/* Decode the string P as a language-specific option for C.
   Return the number of strings consumed for a valid option.
   Return 0 for an invalid option.  */

int
c_decode_option (argc, argv)
     int argc ATTRIBUTE_UNUSED;
     char **argv;
{
  char *p = argv[0];
  if (!strcmp (p, "-ftraditional") || !strcmp (p, "-traditional"))
    {
      flag_traditional = 1;
      flag_writable_strings = 1;
#if DOLLARS_IN_IDENTIFIERS > 0
      dollars_in_ident = 1;
#endif
    }
  else if (!strcmp (p, "-fnotraditional") || !strcmp (p, "-fno-traditional"))
    {
      flag_traditional = 0;
      flag_writable_strings = 0;
      dollars_in_ident = DOLLARS_IN_IDENTIFIERS > 1;
    }
  else if (!strcmp (p, "-fsigned-char"))
    flag_signed_char = 1;
  else if (!strcmp (p, "-funsigned-char"))
    flag_signed_char = 0;
  else if (!strcmp (p, "-fno-signed-char"))
    flag_signed_char = 0;
  else if (!strcmp (p, "-fno-unsigned-char"))
    flag_signed_char = 1;
  else if (!strcmp (p, "-fsigned-bitfields")
           || !strcmp (p, "-fno-unsigned-bitfields"))
    {
      flag_signed_bitfields = 1;
      explicit_flag_signed_bitfields = 1;
    }
  else if (!strcmp (p, "-funsigned-bitfields")
           || !strcmp (p, "-fno-signed-bitfields"))
    {
      flag_signed_bitfields = 0;
      explicit_flag_signed_bitfields = 1;
    }
  else if (!strcmp (p, "-fshort-enums"))
    flag_short_enums = 1;
  else if (!strcmp (p, "-fno-short-enums"))
    flag_short_enums = 0;
  else if (!strcmp (p, "-fcond-mismatch"))
    flag_cond_mismatch = 1;
  else if (!strcmp (p, "-fno-cond-mismatch"))
    flag_cond_mismatch = 0;
  else if (!strcmp (p, "-fshort-double"))
    flag_short_double = 1;
  else if (!strcmp (p, "-fno-short-double"))
    flag_short_double = 0;
  else if (!strcmp (p, "-fasm"))
    flag_no_asm = 0;
  else if (!strcmp (p, "-fno-asm"))
    flag_no_asm = 1;
  else if (!strcmp (p, "-fbuiltin"))
    flag_no_builtin = 0;
  else if (!strcmp (p, "-fno-builtin"))
    flag_no_builtin = 1;
  else if (!strcmp (p, "-ansi"))
    flag_no_asm = 1, flag_no_nonansi_builtin = 1, dollars_in_ident = 0;
  else if (!strcmp (p, "-Wimplicit"))
    warn_implicit = 1;
  else if (!strcmp (p, "-Wno-implicit"))
    warn_implicit = 0;
  else if (!strcmp (p, "-Wwrite-strings"))
    warn_write_strings = 1;
  else if (!strcmp (p, "-Wno-write-strings"))
    warn_write_strings = 0;
  else if (!strcmp (p, "-Wcast-qual"))
    warn_cast_qual = 1;
  else if (!strcmp (p, "-Wno-cast-qual"))
    warn_cast_qual = 0;
  else if (!strcmp (p, "-Wpointer-arith"))
    warn_pointer_arith = 1;
  else if (!strcmp (p, "-Wno-pointer-arith"))
    warn_pointer_arith = 0;
  else if (!strcmp (p, "-Wstrict-prototypes"))
    warn_strict_prototypes = 1;
  else if (!strcmp (p, "-Wno-strict-prototypes"))
    warn_strict_prototypes = 0;
  else if (!strcmp (p, "-Wmissing-prototypes"))
    warn_missing_prototypes = 1;
  else if (!strcmp (p, "-Wno-missing-prototypes"))
    warn_missing_prototypes = 0;
  else if (!strcmp (p, "-Wredundant-decls"))
    warn_redundant_decls = 1;
  else if (!strcmp (p, "-Wno-redundant-decls"))
    warn_redundant_decls = 0;
  else if (!strcmp (p, "-Wnested-externs"))
    warn_nested_externs = 1;
  else if (!strcmp (p, "-Wno-nested-externs"))
    warn_nested_externs = 0;
  else if (!strcmp (p, "-Wchar-subscripts"))
    warn_char_subscripts = 1;
  else if (!strcmp (p, "-Wno-char-subscripts"))
    warn_char_subscripts = 0;
  else if (!strcmp (p, "-Wconversion"))
    warn_conversion = 1;
  else if (!strcmp (p, "-Wno-conversion"))
    warn_conversion = 0;
  else if (!strcmp (p, "-Wparentheses"))
    warn_parentheses = 1;
  else if (!strcmp (p, "-Wno-parentheses"))
    warn_parentheses = 0;
  else if (!strcmp (p, "-Wreturn-type"))
    warn_return_type = 1;
  else if (!strcmp (p, "-Wno-return-type"))
    warn_return_type = 0;
  else if (!strcmp (p, "-Wcomment"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wno-comment"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wcomments"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wno-comments"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wtrigraphs"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wno-trigraphs"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wimport"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wno-import"))
    ; /* cpp handles this one.  */
  else if (!strcmp (p, "-Wmissing-braces"))
    warn_missing_braces = 1;
  else if (!strcmp (p, "-Wno-missing-braces"))
    warn_missing_braces = 0;
  else if (!strcmp (p, "-Wall"))
    {
      extra_warnings = 1;
      /* We save the value of warn_uninitialized, since if they put
         -Wuninitialized on the command line, we need to generate a
         warning about not using it without also specifying -O.  */
      if (warn_uninitialized != 1)
        warn_uninitialized = 2;
      warn_implicit = 1;
      warn_return_type = 1;
      warn_unused = 1;
      warn_char_subscripts = 1;
      warn_parentheses = 1;
      warn_missing_braces = 1;
    }
  else
    return 0;
  
  return 1;
}

/* Hooks for print_node.  */

void
print_lang_decl (file, node, indent)
     FILE *file;
     tree node;
     int  indent;
{
  indent_to (file, indent + 3);
  fputs ("nesting_level ", file);
  fprintf (file, HOST_WIDE_INT_PRINT_DEC, DECL_NESTING_LEVEL (node));
  fputs (" ", file);
  if (DECL_WEAK_NAME (node))
    fprintf (file, "weak_name ");
  if (CH_DECL_SIGNAL (node))
    fprintf (file, "decl_signal ");
  print_node (file, "tasking_code",
              (tree)DECL_TASKING_CODE_DECL (node), indent + 4);
}


void
print_lang_type (file, node, indent)
     FILE *file;
     tree node;
     int  indent;
{
  tree temp;

  indent_to (file, indent + 3);
  if (CH_IS_BUFFER_MODE (node))
    fprintf (file, "buffer_mode ");
  if (CH_IS_EVENT_MODE (node))
    fprintf (file, "event_mode ");

  if (CH_IS_EVENT_MODE (node) || CH_IS_BUFFER_MODE (node))
    {
      temp = max_queue_size (node);
      if (temp)
        print_node_brief (file, "qsize", temp, indent + 4);
    }
}

void
print_lang_identifier (file, node, indent)
     FILE *file;
     tree node;
     int  indent;
{
  print_node (file, "local",       IDENTIFIER_LOCAL_VALUE (node),   indent +  4);
  print_node (file, "outer",       IDENTIFIER_OUTER_VALUE (node),   indent +  4);
  print_node (file, "implicit",    IDENTIFIER_IMPLICIT_DECL (node), indent + 4);
  print_node (file, "error locus", IDENTIFIER_ERROR_LOCUS (node),   indent + 4);
  print_node (file, "signal_dest", IDENTIFIER_SIGNAL_DEST (node),   indent + 4);
  indent_to  (file, indent + 3);
  if (IDENTIFIER_SIGNAL_DATA(node))
    fprintf (file, "signal_data ");
}
\f
/* initialise non-value struct */

static int
init_nonvalue_struct (expr)
     tree expr;
{
  tree type = TREE_TYPE (expr);
  tree field;
  int res = 0;

  if (CH_IS_BUFFER_MODE (type))
    {
      expand_expr_stmt (
        build_chill_modify_expr (
          build_component_ref (expr, get_identifier ("__buffer_data")),
            null_pointer_node));
      return 1;
    }
  else if (CH_IS_EVENT_MODE (type))
    {
      expand_expr_stmt (
        build_chill_modify_expr (
          build_component_ref (expr, get_identifier ("__event_data")),
            null_pointer_node));
      return 1;
    }
  else if (CH_IS_ASSOCIATION_MODE (type))
    {
      expand_expr_stmt (
        build_chill_modify_expr (expr,
          chill_convert_for_assignment (type, association_init_value,
                                        "association")));
      return 1;
    }
  else if (CH_IS_ACCESS_MODE (type))
    {
      init_access_location (expr, type);
      return 1;
    }
  else if (CH_IS_TEXT_MODE (type))
    {
      init_text_location (expr, type);
      return 1;
    }

  for (field = TYPE_FIELDS (type); field != NULL_TREE; field = TREE_CHAIN (field))
    {
      type = TREE_TYPE (field);
      if (CH_TYPE_NONVALUE_P (type))
        {
          tree exp = build_component_ref (expr, DECL_NAME (field));
          if (TREE_CODE (type) == RECORD_TYPE)
            res |= init_nonvalue_struct (exp);
          else if (TREE_CODE (type) == ARRAY_TYPE)
            res |= init_nonvalue_array (exp);
        }
    }
  return res;
}

/* initialize non-value array */
/* do it with DO FOR unique-id IN expr; ... OD; */
static int
init_nonvalue_array (expr)
     tree expr;
{
  tree tmpvar = get_unique_identifier ("NONVALINIT");
  tree type;
  int res = 0;

  push_loop_block ();
  build_loop_iterator (tmpvar, expr, NULL_TREE, NULL_TREE, 0, 1, 0);
  nonvalue_begin_loop_scope ();
  build_loop_start (NULL_TREE);
  tmpvar = lookup_name (tmpvar);
  type = TREE_TYPE (tmpvar);
  if (CH_TYPE_NONVALUE_P (type))
    {
      if (TREE_CODE (type) == RECORD_TYPE)
        res |= init_nonvalue_struct (tmpvar);
      else if (TREE_CODE (type) == ARRAY_TYPE)
        res |= init_nonvalue_array (tmpvar);
    }
  build_loop_end ();
  nonvalue_end_loop_scope ();
  pop_loop_block ();
  return res;
}
\f
/* This excessive piece of code sets DECL_NESTING_LEVEL (DECL) to LEVEL. */

void
set_nesting_level (decl, level)
     tree decl;
     int level;
{
  static tree *small_ints = NULL;
  static int max_small_ints = 0;
  
  if (level < 0)
    decl->decl.vindex = NULL_TREE;
  else
    {
      if (level >= max_small_ints)
        {
          int new_max = level + 20;
          if (small_ints == NULL)
            small_ints = (tree*)xmalloc (new_max * sizeof(tree));
          else
            small_ints = (tree*)xrealloc (small_ints, new_max * sizeof(tree));
          while (max_small_ints < new_max)
            small_ints[max_small_ints++] = NULL_TREE;
        }
      if (small_ints[level] == NULL_TREE)
        {
          push_obstacks (&permanent_obstack, &permanent_obstack);
          small_ints[level] = build_int_2 (level, 0);
          pop_obstacks ();
        }
      /* set DECL_NESTING_LEVEL */
      decl->decl.vindex = small_ints[level];
    }
}
\f
/* OPT_EXTERNAL is non-zero when the declaration is at module level.
 * OPT_EXTERNAL == 2 means implicitly grant it.
 */
void
do_decls (names, type, opt_static, lifetime_bound, opt_init, opt_external)
     tree names;
     tree type;
     int  opt_static;
     int  lifetime_bound;
     tree opt_init;
     int  opt_external;
{
  if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
    {
      for (; names != NULL_TREE; names = TREE_CHAIN (names))
        do_decl (TREE_VALUE (names), type, opt_static, lifetime_bound,
                 opt_init, opt_external);
    }
  else if (TREE_CODE (names) != ERROR_MARK)
    do_decl (names, type, opt_static, lifetime_bound, opt_init, opt_external);
}

tree
do_decl (name, type, is_static, lifetime_bound, opt_init, opt_external)
     tree name, type;
     int  is_static;
     int  lifetime_bound;
     tree opt_init;
     int  opt_external;
{
  tree decl;

  if (current_function_decl == global_function_decl
      && ! lifetime_bound /*&& opt_init != NULL_TREE*/)
    seen_action = 1;

  if (pass < 2)
    {
      push_obstacks (&permanent_obstack, &permanent_obstack);
      decl = make_node (VAR_DECL);
      DECL_NAME (decl) = name;
      TREE_TYPE (decl) = type;
      DECL_ASSEMBLER_NAME (decl) = name;

      /* Try to put things in common when possible.
         Tasking variables must go into common.  */
      DECL_COMMON (decl) = 1;
      DECL_EXTERNAL (decl) = opt_external > 0;
      TREE_PUBLIC (decl)   = opt_external > 0;
      TREE_STATIC (decl)   = is_static;

      if (pass == 0)
        {
          /* We have to set this here, since we build the decl w/o
             calling `build_decl'.  */
          DECL_INITIAL (decl) = opt_init;
          pushdecl (decl);
          finish_decl (decl);
        }
      else
        {
          save_decl (decl);
          pop_obstacks ();
        }
      DECL_INITIAL (decl) = opt_init;
      if (opt_external > 1 || in_pseudo_module)
        push_granted (DECL_NAME (decl), decl);
    }
  else /* pass == 2 */
    {
      tree temp = NULL_TREE;
      int init_it = 0;

      decl = get_next_decl ();
      
      if (name != DECL_NAME (decl))
        abort ();
      
      type = TREE_TYPE (decl);
      
      push_obstacks_nochange ();
      if (TYPE_READONLY_PROPERTY (type))
        {
          if (CH_TYPE_NONVALUE_P (type))
            {
              error_with_decl (decl, "`%s' must not be declared readonly");
              opt_init = NULL_TREE; /* prevent subsequent errors */
            }
          else if (opt_init == NULL_TREE && !opt_external)
            error("declaration of readonly variable without initialization");
        }
      TREE_READONLY (decl) = TYPE_READONLY (type);
      
      if (!opt_init && chill_varying_type_p (type))
        {
          tree fixed_part_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
          if (fixed_part_type != NULL_TREE && TREE_CODE (fixed_part_type) != ERROR_MARK)
            {
              if (CH_CHARS_TYPE_P (fixed_part_type))
                opt_init = build_chill_string (0, "");
              else
                opt_init = build_nt (CONSTRUCTOR, NULL_TREE, NULL_TREE);
              lifetime_bound = 1;
            }
        }

      if (opt_init)
        {
          if (CH_TYPE_NONVALUE_P (type))
            {
              error_with_decl (decl,
                               "no initialisation allowed for `%s'");
              temp = NULL_TREE;
            }
          else if (TREE_CODE (type) == REFERENCE_TYPE)
            { /* A loc-identity declaration */
              if (! CH_LOCATION_P (opt_init))
                {
                  error_with_decl (decl,
                        "value for loc-identity `%s' is not a location");
                  temp = NULL_TREE;
                }
              else if (! CH_READ_COMPATIBLE (TREE_TYPE (type),
                                             TREE_TYPE (opt_init)))
                {
                  error_with_decl (decl,
                                   "location for `%s' not read-compatible");
                  temp = NULL_TREE;
                }
              else
                temp = convert (type, opt_init);
            }
          else
            { /* Normal location declaration */
              char place[80];
              sprintf (place, "`%.60s' initializer",
                       IDENTIFIER_POINTER (DECL_NAME (decl)));
              temp = chill_convert_for_assignment (type, opt_init, place);
            }
        }
      else if (CH_TYPE_NONVALUE_P (type))
        {
          temp = NULL_TREE;
          init_it = 1;
        }
      DECL_INITIAL (decl) = NULL_TREE;

      if (temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK)
        {
          /* The same for stack variables (assuming no nested modules). */
          if (lifetime_bound || !is_static)
            {
              if (is_static && ! TREE_CONSTANT (temp))
                error_with_decl (decl, "nonconstant initializer for `%s'");
              else
                DECL_INITIAL (decl) = temp;
            }
        }
      finish_decl (decl);
      /* Initialize the variable unless initialized statically. */
      if ((!is_static || ! lifetime_bound) &&
          temp != NULL_TREE && TREE_CODE (temp) != ERROR_MARK)
        {
          int was_used = TREE_USED (decl);
          emit_line_note (input_filename, lineno);
          expand_expr_stmt (build_chill_modify_expr (decl, temp));
          /* Don't let the initialization count as "using" the variable.  */
          TREE_USED (decl) = was_used;
          if (current_function_decl == global_function_decl)
            build_constructor = 1;
        }
      else if (init_it && TREE_CODE (type) != ERROR_MARK)
        {
          /* Initialize variables with non-value type */
          int was_used = TREE_USED (decl);
          int something_initialised = 0;

          emit_line_note (input_filename, lineno);
          if (TREE_CODE (type) == RECORD_TYPE)
            something_initialised = init_nonvalue_struct (decl);
          else if (TREE_CODE (type) == ARRAY_TYPE)
            something_initialised = init_nonvalue_array (decl);
          if (! something_initialised)
            {
              error ("do_decl: internal error: don't know what to initialize");
              abort ();
            }
          /* Don't let the initialization count as "using" the variable.  */
          TREE_USED (decl) = was_used;
          if (current_function_decl == global_function_decl)
            build_constructor = 1;
        }
    }
  return decl;
}
\f
/*
 * ARGTYPES is a tree_list of formal argument types.  TREE_VALUE
 * is the type tree for each argument, while the attribute is in
 * TREE_PURPOSE.
 */
tree
build_chill_function_type (return_type, argtypes, exceptions, recurse_p)
     tree return_type, argtypes, exceptions, recurse_p;
{
  tree ftype, arg;

  if (exceptions != NULL_TREE)
    {
      /* if we have exceptions we add 2 arguments, callers filename
         and linenumber. These arguments will be added automatically
         when calling a function which may raise exceptions. */
      argtypes = chainon (argtypes,
                          build_tree_list (NULL_TREE, ridpointers[(int) RID_PTR]));
      argtypes = chainon (argtypes,
                          build_tree_list (NULL_TREE, ridpointers[(int) RID_LONG]));
}

  /* Indicate the argument list is complete. */
  argtypes = chainon (argtypes,
                      build_tree_list (NULL_TREE, void_type_node));
  
  /* INOUT and OUT parameters must be a REFERENCE_TYPE since
     we'll be passing a temporary's address at call time. */
  for (arg = argtypes; arg; arg = TREE_CHAIN (arg))
    if (TREE_PURPOSE (arg) == ridpointers[(int) RID_LOC]
        || TREE_PURPOSE (arg) == ridpointers[(int) RID_OUT]
        || TREE_PURPOSE (arg) == ridpointers[(int) RID_INOUT]
        )
      TREE_VALUE (arg) = 
        build_chill_reference_type (TREE_VALUE (arg));
  
  /* Cannot use build_function_type, because if does hash-canonlicalization. */
  ftype = make_node (FUNCTION_TYPE);
  TREE_TYPE (ftype) = return_type ? return_type : void_type_node ;
  TYPE_ARG_TYPES (ftype) = argtypes;
  
  if (exceptions)
    ftype = build_exception_variant (ftype, exceptions);
  
  if (recurse_p)
    sorry ("RECURSIVE PROCs");
  
  return ftype;
}
\f
/*
 * ARGTYPES is a tree_list of formal argument types.
 */
tree
push_extern_function (name, typespec, argtypes, exceptions, granting)
  tree name, typespec, argtypes, exceptions;
  int granting ATTRIBUTE_UNUSED;/*If 0 do pushdecl(); if 1 do push_granted()*/
{
  tree ftype, fndecl;
  
  push_obstacks_nochange ();
  end_temporary_allocation ();
  
  if (pass < 2)
    {
      ftype = build_chill_function_type (typespec, argtypes,
                                         exceptions, NULL_TREE);
      
      fndecl = build_decl (FUNCTION_DECL, name, ftype);
      
      DECL_EXTERNAL(fndecl) = 1;
      TREE_STATIC (fndecl) = 1;
      TREE_PUBLIC (fndecl) = 1;
      if (pass == 0)
        {
          pushdecl (fndecl);
          finish_decl (fndecl);
        }
      else
        {
          save_decl (fndecl);
          pop_obstacks ();
        }
      make_function_rtl (fndecl);
    }
  else
    {
      fndecl = get_next_decl (); 
      finish_decl (fndecl);
    }
#if 0
  
  if (granting)
    push_granted (name, decl);
  else
    pushdecl(decl);
#endif
  return fndecl;
}


\f
void
push_extern_process (name, argtypes, exceptions, granting)
     tree name, argtypes, exceptions;
     int  granting;
{
  tree decl, func, arglist;
  
  push_obstacks_nochange ();
  end_temporary_allocation ();
  
  if (pass < 2)
    {
      tree proc_struct = make_process_struct (name, argtypes);
      arglist = (argtypes == NULL_TREE) ? NULL_TREE :
        tree_cons (NULL_TREE,
                   build_chill_pointer_type (proc_struct), NULL_TREE);
    }
  else
    arglist = NULL_TREE;

  func = push_extern_function (name, NULL_TREE, arglist,
                               exceptions, granting);

  /* declare the code variable */
  decl = generate_tasking_code_variable (name, &process_type, 1);
  CH_DECL_PROCESS (func) = 1;
  /* remember the code variable in the function decl */
  DECL_TASKING_CODE_DECL (func) = (struct lang_decl *)decl;

  add_taskstuff_to_list (decl, "_TT_Process", NULL_TREE, func, NULL_TREE);
}
\f
void
push_extern_signal (signame, sigmodelist, optsigdest)
     tree signame, sigmodelist, optsigdest;
{
  tree decl, sigtype;

  push_obstacks_nochange ();
  end_temporary_allocation ();
  
  sigtype = 
    build_signal_struct_type (signame, sigmodelist, optsigdest);
  
  /* declare the code variable outside the process */
  decl = generate_tasking_code_variable (signame, &signal_code, 1);
  add_taskstuff_to_list (decl, "_TT_Signal", NULL_TREE, sigtype, NULL_TREE);
}
\f
void
print_mode (mode)
     tree mode;
{
  while (mode != NULL_TREE)
    {
      switch (TREE_CODE (mode))
        {
        case POINTER_TYPE:
          printf (" REF ");
          mode = TREE_TYPE (mode);
          break;
        case INTEGER_TYPE:
        case REAL_TYPE:
          printf (" %s ", IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (mode))));
          mode = NULL_TREE;
          break;
        case ARRAY_TYPE:
          {
            tree itype = TYPE_DOMAIN (mode);
            if (CH_STRING_TYPE_P (mode))
              {
                fputs (" STRING (", stdout);
                printf (HOST_WIDE_INT_PRINT_DEC,
                        TREE_INT_CST_LOW (TYPE_MAX_VALUE (itype)));
                fputs (") OF ", stdout);
              }
            else
              {
                fputs (" ARRAY (", stdout);
                printf (HOST_WIDE_INT_PRINT_DEC,
                        TREE_INT_CST_LOW (TYPE_MIN_VALUE (itype)));
                fputs (":", stdout);
                printf (HOST_WIDE_INT_PRINT_DEC,
                        TREE_INT_CST_LOW (TYPE_MAX_VALUE (itype)));
                fputs (") OF ", stdout);
              }
            mode = TREE_TYPE (mode);
            break;
          }
        case RECORD_TYPE:
          {
            tree fields = TYPE_FIELDS (mode);
            printf (" RECORD (");
            while (fields != NULL_TREE)
              {
                printf (" %s:", IDENTIFIER_POINTER (DECL_NAME (fields)));
                print_mode (TREE_TYPE (fields));
                if (TREE_CHAIN (fields))
                  printf (",");
                fields = TREE_CHAIN (fields);
              }
            printf (")");
            mode = NULL_TREE;
            break;
          }
        default:
          abort ();
        }
    }
}
\f
tree
chill_munge_params (nodes, type, attr)
     tree nodes, type, attr;
{
  tree node;
  if (pass == 1)
    {
      /* Convert the list of identifiers to a list of types. */
      for (node = nodes; node != NULL_TREE; node = TREE_CHAIN (node))
        {
          TREE_VALUE (node) = type;  /* this was the identifier node */
          TREE_PURPOSE (node) = attr;
        }
    }
  return nodes;
}

/* Push the declarations described by SYN_DEFS into the current scope.  */
void
push_syndecl (name, mode, value)
     tree name, mode, value;
{
  if (pass == 1)
    {
      tree decl = make_node (CONST_DECL);
      DECL_NAME (decl) = name;
      DECL_ASSEMBLER_NAME (decl) = name;
      TREE_TYPE (decl) = mode;
      DECL_INITIAL (decl) = value;
      TREE_READONLY (decl) = 1;
      save_decl (decl);
      if (in_pseudo_module)
        push_granted (DECL_NAME (decl), decl);
    }
  else /* pass == 2 */
    get_next_decl ();
}


\f
/* Push the declarations described by (MODENAME,MODE) into the current scope.
   MAKE_NEWMODE is 1 for NEWMODE, 0 for SYNMODE, and
   -1 for internal use (in which case the mode does not need to be copied). */

tree
push_modedef (modename, mode, make_newmode)
     tree modename;
     tree mode;  /* ignored if pass==2. */
     int make_newmode;
{
  tree newdecl, newmode;
  
  if (pass == 1)
    {
      /* FIXME: need to check here for SYNMODE fred fred; */
      push_obstacks (&permanent_obstack, &permanent_obstack);

      newdecl = build_lang_decl (TYPE_DECL, modename, mode);

      if (make_newmode >= 0)
        {
          newmode = make_node (LANG_TYPE);
          TREE_TYPE (newmode) = mode;
          TREE_TYPE (newdecl) = newmode;
          TYPE_NAME (newmode) = newdecl;
          if (make_newmode > 0)
            CH_NOVELTY (newmode) = newdecl;
        }

      save_decl (newdecl);
      pop_obstacks ();
          
    }
  else /* pass == 2 */
    {
      /* FIXME: need to check here for SYNMODE fred fred; */
      newdecl = get_next_decl ();
      if (DECL_NAME (newdecl) != modename)
        abort ();
      if (TREE_CODE (TREE_TYPE (newdecl)) != ERROR_MARK)
        {
          /* ASSOCIATION, ACCESS, TEXT, BUFFER, and EVENT must not be READOnly */
          if (TREE_READONLY (TREE_TYPE (newdecl)) &&
              (CH_IS_ASSOCIATION_MODE (TREE_TYPE (newdecl)) ||
               CH_IS_ACCESS_MODE (TREE_TYPE (newdecl)) ||
               CH_IS_TEXT_MODE (TREE_TYPE (newdecl)) ||
               CH_IS_BUFFER_MODE (TREE_TYPE (newdecl)) ||
               CH_IS_EVENT_MODE (TREE_TYPE (newdecl))))
            error_with_decl (newdecl, "`%s' must not be READonly");
          rest_of_decl_compilation (newdecl, NULL_PTR,
                                    global_bindings_p (), 0);
        }
    }
  return newdecl;
}
\f
/* Return a chain of FIELD_DECLs for the names in NAMELIST.  All of
   of type TYPE.  When NAMELIST is passed in from the parser, it is
   in reverse order.
   LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list),
   meaning (default, pack, nopack, POS (...) ).  */

tree
grok_chill_fixedfields (namelist, type, layout)
     tree namelist, type;
     tree layout;
{
  tree decls = NULL_TREE;
  
  if (layout != NULL_TREE && TREE_CHAIN (namelist) != NULL_TREE)
    {
      if (layout != integer_one_node && layout != integer_zero_node)
        {
          layout = NULL_TREE;
          error ("POS may not be specified for a list of field declarations");
        }
    }

  /* we build the chain of FIELD_DECLs backwards, effectively
     unreversing the reversed names in NAMELIST.  */
  for (; namelist; namelist = TREE_CHAIN (namelist))
    {
      tree decl = build_decl (FIELD_DECL, 
                              TREE_VALUE (namelist), type);
      DECL_INITIAL (decl) = layout;
      TREE_CHAIN (decl) = decls;
      decls = decl;
    }
  
  return decls;
}
\f
struct tree_pair
{
  tree value;
  tree decl;
};


/* Function to help qsort sort variant labels by value order.  */
static int
label_value_cmp (x, y)
     struct tree_pair *x, *y;
{
  return TREE_INT_CST_LOW (x->value) - TREE_INT_CST_LOW (y->value);
}
\f
tree
make_chill_variants (tagfields, body, variantelse)
     tree tagfields;
     tree body;
     tree variantelse;
{
  tree utype;
  tree first = NULL_TREE;
  for (; body; body = TREE_CHAIN (body))
    {
      tree decls = TREE_VALUE (body);
      tree labellist = TREE_PURPOSE (body);

      if (labellist != NULL_TREE
          && TREE_CODE (TREE_VALUE (labellist)) == TREE_LIST
          && TREE_VALUE (TREE_VALUE (labellist)) == case_else_node
          && TREE_CHAIN (labellist) == NULL_TREE)
        {
          if (variantelse)
            error ("(ELSE) case label as well as ELSE variant");
          variantelse = decls;
        }
      else
        {
          tree rtype = start_struct (RECORD_TYPE, NULL_TREE);
          rtype = finish_struct (rtype, decls);

          first = chainon (first, build_decl (FIELD_DECL, NULL_TREE, rtype));
      
          TYPE_TAG_VALUES (rtype) = labellist;
        }
    }
  
  if (variantelse != NULL_TREE)
    {
      tree rtype = start_struct (RECORD_TYPE, NULL_TREE);
      rtype = finish_struct (rtype, variantelse);
      first = chainon (first,
                       build_decl (FIELD_DECL,
                                   ELSE_VARIANT_NAME, rtype));
    }
  
  utype = start_struct (UNION_TYPE, NULL_TREE);
  utype = finish_struct (utype, first);
  TYPE_TAGFIELDS (utype) = tagfields;
  return utype;
}
\f
tree
layout_chill_variants (utype)
     tree utype;
{
  tree first = TYPE_FIELDS (utype);
  int nlabels, label_index = 0;
  struct tree_pair *label_value_array;
  tree decl;
  extern int errorcount;
  
  if (TYPE_SIZE (utype))
    return utype;
  
  for (decl = first; decl; decl = TREE_CHAIN (decl))
    {
      tree tagfields = TYPE_TAGFIELDS (utype);
      tree t = TREE_TYPE (decl);
      tree taglist = TYPE_TAG_VALUES (t);
      if (DECL_NAME (decl) == ELSE_VARIANT_NAME)
        continue;
      if (tagfields == NULL_TREE)
        continue;
      for ( ; tagfields != NULL_TREE && taglist != NULL_TREE;
           tagfields = TREE_CHAIN (tagfields), taglist = TREE_CHAIN (taglist))
        {
          tree labellist = TREE_VALUE (taglist);
          for (; labellist; labellist = TREE_CHAIN (labellist))
            {
              int compat_error = 0;
              tree label_value = TREE_VALUE (labellist);
              if (TREE_CODE (label_value) == RANGE_EXPR)
                {
                  if (TREE_OPERAND (label_value, 0) != NULL_TREE)
                    {
                      if (!CH_COMPATIBLE (TREE_OPERAND (label_value, 0),
                                          TREE_TYPE (TREE_VALUE (tagfields)))
                          || !CH_COMPATIBLE (TREE_OPERAND (label_value, 1),
                                             TREE_TYPE (TREE_VALUE (tagfields))))
                        compat_error = 1;
                    }
                }
              else if (TREE_CODE (label_value) == TYPE_DECL)
                {
                  if (!CH_COMPATIBLE (label_value,
                                      TREE_TYPE (TREE_VALUE (tagfields))))
                    compat_error = 1;
                }
              else if (TREE_CODE (label_value) == INTEGER_CST)
                {
                  if (!CH_COMPATIBLE (label_value,
                                      TREE_TYPE (TREE_VALUE (tagfields))))
                    compat_error = 1;
                }
              if (compat_error)
                {
                  if (TYPE_FIELDS (t) == NULL_TREE)
                    error ("inconsistent modes between labels and tag field");
                  else 
                    error_with_decl (TYPE_FIELDS (t),
                                     "inconsistent modes between labels and tag field");
                }
            }
        }
      if (tagfields != NULL_TREE)
        error ("too few tag labels");
      if (taglist != NULL_TREE)
        error ("too many tag labels");
    }

  /* Compute the number of labels to be checked for duplicates.  */
  nlabels = 0;
  for (decl = first; decl; decl = TREE_CHAIN (decl))
    {
      tree t = TREE_TYPE (decl);
       /* Only one tag (first case_label_list) supported, for now. */
      tree labellist = TYPE_TAG_VALUES (t);
      if (labellist)
        labellist = TREE_VALUE (labellist);
      
      for (; labellist != NULL_TREE; labellist = TREE_CHAIN (labellist))
        if (TREE_CODE (TREE_VALUE (labellist)) == INTEGER_CST)
          nlabels++;
    }

  /* Check for duplicate label values.  */
  label_value_array = (struct tree_pair *)alloca (nlabels * sizeof (struct tree_pair));
  for (decl = first; decl; decl = TREE_CHAIN (decl))
    {
      tree t = TREE_TYPE (decl);
       /* Only one tag (first case_label_list) supported, for now. */
      tree labellist = TYPE_TAG_VALUES (t);
      if (labellist)
        labellist = TREE_VALUE (labellist);
      
      for (; labellist != NULL_TREE; labellist = TREE_CHAIN (labellist))
        {
          struct tree_pair p;
          
          tree x = TREE_VALUE (labellist);
          if (TREE_CODE (x) == RANGE_EXPR)
            {
              if (TREE_OPERAND (x, 0) != NULL_TREE)
                {
                  if (TREE_CODE (TREE_OPERAND (x, 0)) != INTEGER_CST)
                    error ("case label lower limit is not a discrete constant expression");
                  if (TREE_CODE (TREE_OPERAND (x, 1)) != INTEGER_CST)
                    error ("case label upper limit is not a discrete constant expression");
                }
              continue;
            }
          else if (TREE_CODE (x) == TYPE_DECL)
            continue;
          else if (TREE_CODE (x) == ERROR_MARK)
            continue;
          else if (TREE_CODE (x) != INTEGER_CST) /* <-- FIXME: what about CONST_DECLs? */
            {
              error ("case label must be a discrete constant expression");
              continue;
            }
          
          if (TREE_CODE (x) == CONST_DECL)
            x = DECL_INITIAL (x);
          if (TREE_CODE (x) != INTEGER_CST) abort ();
          p.value = x;
          p.decl = decl;
          if (p.decl == NULL_TREE)
            p.decl = TREE_VALUE (labellist);
          label_value_array[label_index++] = p;
        }
    }
  if (errorcount == 0)
    {
      int limit;
      qsort (label_value_array,
             label_index, sizeof (struct tree_pair), label_value_cmp);
      limit = label_index - 1;
      for (label_index = 0; label_index < limit; label_index++)
        {
          if (tree_int_cst_equal (label_value_array[label_index].value, 
                                  label_value_array[label_index+1].value))
            {
              error_with_decl (label_value_array[label_index].decl,
                               "variant label declared here...");
              error_with_decl (label_value_array[label_index+1].decl,
                               "...is duplicated here");
            }
        }
    }
  layout_type (utype);
  return utype;
}
\f
/* Convert a TREE_LIST of tag field names into a list of
   field decls, found from FIXED_FIELDS, re-using the input list. */

tree
lookup_tag_fields (tag_field_names, fixed_fields)
     tree tag_field_names;
     tree fixed_fields;
{
  tree list;
  for (list = tag_field_names; list != NULL_TREE; list = TREE_CHAIN (list))
    {
      tree decl = fixed_fields;
      for ( ; decl != NULL_TREE; decl = TREE_CHAIN (decl))
        {
          if (DECL_NAME (decl) == TREE_VALUE (list))
            {
              TREE_VALUE (list) = decl;
              break;
            }
        }
      if (decl == NULL_TREE)
        {
          error ("no field (yet) for tag %s",
                 IDENTIFIER_POINTER (TREE_VALUE (list)));
          TREE_VALUE (list) = error_mark_node;
        }
    }
  return tag_field_names;
}

/* If non-NULL, TAGFIELDS is the tag fields for this variant record.
   BODY is a TREE_LIST of (optlabels, fixed fields).
   If non-null, VARIANTELSE is a fixed field for the else part of the
   variant record.  */

tree
grok_chill_variantdefs (tagfields, body, variantelse)
     tree tagfields, body, variantelse;
{
  tree t;
  
  t = make_chill_variants (tagfields, body, variantelse);
  if (pass != 1)
    t = layout_chill_variants (t);
  return build_decl (FIELD_DECL, NULL_TREE, t);
}
\f
/*
  In pass 1, PARMS is a list of types (with attributes).
  In pass 2, PARMS is a chain of PARM_DECLs.
  */

int
start_chill_function (label, rtype, parms, exceptlist, attrs)
     tree label, rtype, parms, exceptlist, attrs;
{
  tree decl, fndecl, type, result_type, func_type;
  int nested = current_function_decl != 0;
  if (pass == 1)
    {
      func_type
        = build_chill_function_type (rtype, parms, exceptlist, 0);
      fndecl = build_decl (FUNCTION_DECL, label, func_type);

      save_decl (fndecl);
      
      /* Make the init_value nonzero so pushdecl knows this is not tentative.
         error_mark_node is replaced below (in poplevel) with the BLOCK.  */
      DECL_INITIAL (fndecl) = error_mark_node;
      
      DECL_EXTERNAL (fndecl) = 0;
      
      /* This function exists in static storage.
         (This does not mean `static' in the C sense!)  */
      TREE_STATIC (fndecl) = 1;

      for (; attrs != NULL_TREE; attrs = TREE_CHAIN (attrs))
        {
          if (TREE_VALUE (attrs) == ridpointers[RID_GENERAL])
            CH_DECL_GENERAL (fndecl) = 1;
          else if (TREE_VALUE (attrs) == ridpointers[RID_SIMPLE])
            CH_DECL_SIMPLE (fndecl) = 1;
          else if (TREE_VALUE (attrs) == ridpointers[RID_RECURSIVE])
            CH_DECL_RECURSIVE (fndecl) = 1;
          else if (TREE_VALUE (attrs) == ridpointers[RID_INLINE])
            DECL_INLINE (fndecl) = 1;
          else
            abort ();
        }
    }
  else /* pass == 2 */
    {
      fndecl = get_next_decl (); 
      if (DECL_NAME (fndecl) != label)
        abort ();           /* outta sync - got wrong decl */
      func_type = TREE_TYPE (fndecl);
      if (TYPE_RAISES_EXCEPTIONS (func_type) != NULL_TREE)
        {
          /* In this case we have to add 2 parameters. 
             See build_chill_function_type (pass == 1). */
          tree arg;
        
          arg = make_node (PARM_DECL);
          DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_FILE);
          DECL_IGNORED_P (arg) = 1;
          parms = chainon (parms, arg);
        
          arg = make_node (PARM_DECL);
          DECL_ASSEMBLER_NAME (arg) = DECL_NAME (arg) = get_identifier (CALLER_LINE);
          DECL_IGNORED_P (arg) = 1;
          parms = chainon (parms, arg);
        }
    }

  current_function_decl = fndecl;
  result_type = TREE_TYPE (func_type);
  if (CH_TYPE_NONVALUE_P (result_type))
    error ("non-value mode may only returned by LOC");

  pushlevel (1); /* Push parameters. */

  if (pass == 2)
    {
      DECL_ARGUMENTS (fndecl) = parms;
      for (decl = DECL_ARGUMENTS (fndecl), type = TYPE_ARG_TYPES (func_type);
           decl != NULL_TREE;
           decl = TREE_CHAIN (decl), type = TREE_CHAIN (type))
        {
          /* check here that modes with the non-value property (like
             BUFFER's, EVENT's, ASSOCIATION's, ACCESS's, or TEXT's) only
             gets passed by LOC */
          tree argtype = TREE_VALUE (type);
          tree argattr = TREE_PURPOSE (type);

          if (TREE_CODE (argtype) == REFERENCE_TYPE)
            argtype = TREE_TYPE (argtype);

          if (TREE_CODE (argtype) != ERROR_MARK &&
              TREE_CODE_CLASS (TREE_CODE (argtype)) != 't')
            {
              error_with_decl (decl, "mode of `%s' is not a mode");
              TREE_VALUE (type) = error_mark_node;
            }

          if (CH_TYPE_NONVALUE_P (argtype) &&
              argattr != ridpointers[(int) RID_LOC])
            error_with_decl (decl, "`%s' may only be passed by LOC");
          TREE_TYPE (decl) = TREE_VALUE (type);
          DECL_ARG_TYPE (decl) = TREE_TYPE (decl);
          DECL_CONTEXT (decl) = fndecl;
          TREE_READONLY (decl) = TYPE_READONLY (argtype);
          layout_decl (decl, 0);
        }

      pushdecllist (DECL_ARGUMENTS (fndecl), 0);

      DECL_RESULT (current_function_decl)
        = build_decl (RESULT_DECL, NULL_TREE, result_type);

#if 0
      /* Write a record describing this function definition to the prototypes
         file (if requested).  */
      gen_aux_info_record (fndecl, 1, 0, prototype);
#endif

      if (fndecl != global_function_decl || seen_action)
        {
          /* Initialize the RTL code for the function.  */
          init_function_start (fndecl, input_filename, lineno);

          /* Set up parameters and prepare for return, for the function.  */
          expand_function_start (fndecl, 0);
        }

      if (!nested)
        /* Allocate further tree nodes temporarily during compilation
           of this function only.  */
        temporary_allocation ();

      /* If this fcn was already referenced via a block-scope `extern' decl (or
         an implicit decl), propagate certain information about the usage. */
      if (TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (current_function_decl)))
        TREE_ADDRESSABLE (current_function_decl) = 1;
    }
      
  /* Z.200 requires that formal parameter names be defined in
     the same block as the procedure body.
     We could do this by keeping boths sets of DECLs in the same
     scope, but we would have to be careful to not merge the
     two chains (e.g. DECL_ARGUEMENTS musr not contains locals).
     Instead, we just make sure they have the same nesting_level. */
  current_nesting_level--;
  pushlevel (1); /* Push local variables. */

  if (pass == 2 && (fndecl != global_function_decl || seen_action))
    {
      /* generate label for possible 'exit' */
      expand_start_bindings (1);

      result_never_set = 1;
    }

  if (TREE_CODE (result_type) == VOID_TYPE)
    chill_result_decl = NULL_TREE;
  else
    {
      /* We use the same name as the keyword.
         This makes it easy to print and change the RESULT from gdb. */
      char *result_str = (ignore_case || ! special_UC) ? "result" : "RESULT";
      if (pass == 2 && TREE_CODE (result_type) == ERROR_MARK)
        TREE_TYPE (current_scope->remembered_decls) = result_type;
      chill_result_decl = do_decl (get_identifier (result_str),
                                   result_type, 0, 0, 0, 0);
      DECL_CONTEXT (chill_result_decl) = fndecl;
    }

  return 1;
}
\f
/* For checking purpose added pname as new argument
   MW Wed Oct 14 14:22:10 1992 */
void
finish_chill_function ()
{
  register tree fndecl = current_function_decl;
  tree outer_function = decl_function_context (fndecl);
  int nested;
  if (outer_function == NULL_TREE && fndecl != global_function_decl)
    outer_function = global_function_decl;
  nested = current_function_decl != global_function_decl;
  if (pass == 2 && (fndecl != global_function_decl || seen_action))
    expand_end_bindings (getdecls (), 1, 0);
    
  /* pop out of function */
  poplevel (1, 1, 0);
  current_nesting_level++;
  /* pop out of its parameters */
  poplevel (1, 0, 1);

  if (pass == 2)
    {
      /*  TREE_READONLY (fndecl) = 1;
          This caused &foo to be of type ptr-to-const-function which
          then got a warning when stored in a ptr-to-function variable. */

      BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;

      /* Must mark the RESULT_DECL as being in this function.  */

      DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;

      if (fndecl != global_function_decl || seen_action)
        {
          /* Generate rtl for function exit.  */
          expand_function_end (input_filename, lineno, 0);

          /* So we can tell if jump_optimize sets it to 1.  */
          can_reach_end = 0;

          /* Run the optimizers and output assembler code for this function. */
          rest_of_compilation (fndecl);
        }

      if (DECL_SAVED_INSNS (fndecl) == 0 && ! nested)
        {
          /* Stop pointing to the local nodes about to be freed.  */
          /* But DECL_INITIAL must remain nonzero so we know this
             was an actual function definition.  */
          /* For a nested function, this is done in pop_chill_function_context.  */
          DECL_INITIAL (fndecl) = error_mark_node;
          DECL_ARGUMENTS (fndecl) = 0;
        }
    }
  current_function_decl = outer_function;
}
\f
/* process SEIZE */

/* Points to the head of the _DECLs read from seize files.  */
#if 0
static tree seized_decls;

static tree processed_seize_files = 0;
#endif

void
chill_seize (old_prefix, new_prefix, postfix)
     tree old_prefix, new_prefix, postfix;
{
  if (pass == 1)
    {
      tree decl = build_alias_decl (old_prefix, new_prefix, postfix);
      DECL_SEIZEFILE(decl) = use_seizefile_name;
      save_decl (decl);
    }
  else /* pass == 2 */
    {
      /* Do nothing - get_next_decl automatically ignores ALIAS_DECLs */
    }
}
#if 0
\f
/*
 * output a debug dump of a scope structure
 */
void
debug_scope (sp)
     struct scope *sp;
{
  if (sp == (struct scope *)NULL)
    {
      fprintf (stderr, "null scope ptr\n");
      return;
    }
  fprintf (stderr, "enclosing 0x%x ",           sp->enclosing);
  fprintf (stderr, "next 0x%x ",                sp->next); 
  fprintf (stderr, "remembered_decls 0x%x ",    sp->remembered_decls);
  fprintf (stderr, "decls 0x%x\n",              sp->decls); 
  fprintf (stderr, "shadowed 0x%x ",            sp->shadowed); 
  fprintf (stderr, "blocks 0x%x ",              sp->blocks); 
  fprintf (stderr, "this_block 0x%x ",          sp->this_block); 
  fprintf (stderr, "level_chain 0x%x\n",        sp->level_chain);
  fprintf (stderr, "module_flag %c ",           sp->module_flag ? 'T' : 'F');
  fprintf (stderr, "first_child_module 0x%x ",  sp->first_child_module);
  fprintf (stderr, "next_sibling_module 0x%x\n", sp->next_sibling_module);
  if (sp->remembered_decls != NULL_TREE)
    {
      tree temp;
      fprintf (stderr, "remembered_decl chain:\n");
      for (temp = sp->remembered_decls; temp; temp = TREE_CHAIN (temp))
        debug_tree (temp);
    }
}
#endif
\f
static void
save_decl (decl)
     tree decl;
{
  if (current_function_decl != global_function_decl)
    DECL_CONTEXT (decl) = current_function_decl;

  TREE_CHAIN (decl) = current_scope->remembered_decls;
  current_scope->remembered_decls = decl;
#if 0
  fprintf (stderr, "\n\nsave_decl 0x%x\n", decl);
  debug_scope (current_scope);  /* ************* */
#endif
  set_nesting_level (decl, current_nesting_level);
}

static tree
get_next_decl ()
{
  tree decl;
  do
    {
      decl = current_scope->remembered_decls;
      current_scope->remembered_decls = TREE_CHAIN (decl);
      /* We ignore ALIAS_DECLs, because push_scope_decls
         can convert a single ALIAS_DECL representing 'SEIZE ALL'
         into one ALIAS_DECL for each seizeable name.
         This means we lose the nice one-to-one mapping
         between pass 1 decls and pass 2 decls.
         (Perhaps ALIAS_DECLs should not be on the remembered_decls list.) */
    } while (decl && TREE_CODE (decl) == ALIAS_DECL);
  return decl;
}

/* At the end of pass 1, we reverse the chronological chain of scopes. */

void
switch_to_pass_2 ()
{
#if 0
  extern int errorcount, sorrycount;
#endif
  if (current_scope != &builtin_scope)
    abort ();
  last_scope = &builtin_scope;
  builtin_scope.remembered_decls = nreverse (builtin_scope.remembered_decls);
  write_grant_file ();

#if 0
  if (errorcount || sorrycount)
    exit (FATAL_EXIT_CODE);
  else
#endif
  if (grant_only_flag)
    exit (SUCCESS_EXIT_CODE);

  pass = 2;
  module_number = 0;
  next_module = &first_module;
}
\f
/*
 * Called during pass 2, when we're processing actions, to
 * generate a temporary variable.  These don't need satisfying
 * because they're compiler-generated and always declared
 * before they're used.
 */
tree
decl_temp1 (name, type, opt_static, opt_init, 
            opt_external, opt_public)
     tree name, type;
     int  opt_static;
     tree opt_init;
     int  opt_external, opt_public;
{
  int orig_pass = pass;           /* be cautious */
  tree mydecl;

  pass = 1;
  mydecl = do_decl (name, type, opt_static, opt_static,
                    opt_init, opt_external);

  if (opt_public)
    TREE_PUBLIC (mydecl) = 1;
  pass = 2;
  do_decl (name, type, opt_static, opt_static, opt_init, opt_external);

  pass = orig_pass;
  return mydecl;
}
\f
/* True if we're reading a seizefile, but we haven't seen a SPEC MODULE yet.
   For backwards compatibility, we treat declarations in such a context
   as implicity granted. */

tree
set_module_name (name)
     tree name;
{
  module_number++;
  if (name == NULL_TREE)
    {
      /* NOTE: build_prefix_clause assumes a generated
         module starts with a '_'. */
      char buf[20];
      sprintf (buf, "_MODULE_%d", module_number);
      name = get_identifier (buf);
    }
  return name;
}

tree
push_module (name, is_spec_module)
     tree name;
     int is_spec_module;
{ 
  struct module *new_module;
  if (pass == 1)
    {
      new_module = (struct module*) permalloc (sizeof (struct module));
      new_module->prev_module = current_module;

      *next_module = new_module;
    }
  else
    {
      new_module = *next_module;
    }
  next_module = &new_module->next_module;

  new_module->procedure_seen = 0;
  new_module->is_spec_module = is_spec_module;
  new_module->name = name;
  if (current_module)
    new_module->prefix_name
      = get_identifier3 (IDENTIFIER_POINTER (current_module->prefix_name),
                         "__", IDENTIFIER_POINTER (name));
  else
    new_module->prefix_name = name;

  new_module->granted_decls = NULL_TREE;
  new_module->nesting_level = current_nesting_level + 1;

  current_module = new_module;
  current_module_nesting_level = new_module->nesting_level;
  in_pseudo_module = name ? 0 : 1;

  pushlevel (1);

  current_scope->module_flag = 1;

  *current_scope->enclosing->tail_child_module = current_scope;
  current_scope->enclosing->tail_child_module
    = &current_scope->next_sibling_module;

  /* Rename the global function to have the same name as
     the first named non-spec module. */
  if (!is_spec_module
      && IDENTIFIER_POINTER (name)[0] != '_'
      && IDENTIFIER_POINTER (DECL_NAME (global_function_decl))[0] == '_')
    {
      tree fname = get_identifier3 ("", IDENTIFIER_POINTER (name), "_");
      DECL_NAME (global_function_decl) = fname;
      DECL_ASSEMBLER_NAME (global_function_decl) = fname;
    }

  return name;   /* may have generated a name */
}
/* Make a copy of the identifier NAME, replacing each '!' by '__'. */
tree
fix_identifier (name)
     tree name;
{
  char *buf = (char*)alloca (2 * IDENTIFIER_LENGTH (name) + 1);
  int fixed = 0;
  register char *dptr = buf;
  register char *sptr = IDENTIFIER_POINTER (name);
  for (; *sptr; sptr++)
    {
      if (*sptr == '!')
        {
          *dptr++ = '_';
          *dptr++ = '_';
          fixed++;
        }
      else
        *dptr++ = *sptr;
    }
  *dptr = '\0';
  return fixed ? get_identifier (buf) : name;
}
\f
void
find_granted_decls ()
{
  if (pass == 1)
    {
      /* Match each granted name to a granted decl. */

      tree alias = current_module->granted_decls;
      tree next_alias, decl;
      /* This is an O(M*N) algorithm.  FIXME! */
      for (; alias; alias = next_alias)
        {
          int found = 0;
          next_alias = TREE_CHAIN (alias);
          for (decl = current_scope->remembered_decls;
               decl; decl = TREE_CHAIN (decl))
            {
              tree new_name = (! DECL_NAME (decl)) ? NULL_TREE :
                              decl_check_rename (alias, 
                                                 DECL_NAME (decl));

              if (!new_name)
                continue;
              /* A Seized declaration is not grantable. */
              if (TREE_CODE (decl) == ALIAS_DECL && !CH_DECL_GRANTED (decl))
                continue;
              found = 1;
              if (global_bindings_p ())
                TREE_PUBLIC (decl) = 1;
              if (DECL_ASSEMBLER_NAME (decl) == NULL_TREE)
                DECL_ASSEMBLER_NAME (decl) = fix_identifier (new_name);
              if (DECL_POSTFIX_ALL (alias))
                {
                  tree new_alias
                    = build_alias_decl (NULL_TREE, NULL_TREE, new_name);
                  TREE_CHAIN (new_alias) = TREE_CHAIN (alias);
                  TREE_CHAIN (alias) = new_alias;
                  DECL_ABSTRACT_ORIGIN (new_alias) = decl;
                  DECL_SOURCE_LINE (new_alias) = 0;
                  DECL_SEIZEFILE (new_alias) = DECL_SEIZEFILE (alias);
                }
              else
                {
                  DECL_ABSTRACT_ORIGIN (alias) = decl;
                  break;
                }
            }
          if (!found)
            {
              error_with_decl (alias, "Nothing named `%s' to grant.");
              DECL_ABSTRACT_ORIGIN (alias) = error_mark_node;
            }
        }
    }
}

void
pop_module ()
{
  tree decl;
  struct scope *module_scope = current_scope;

  poplevel (0, 0, 0);

  if (pass == 1)
    {
      /* Write out the grant file. */
      if (!current_module->is_spec_module)
        {
          /* After reversal, TREE_CHAIN (last_old_decl) is the oldest
             decl of the current module. */
          write_spec_module (module_scope->remembered_decls,
                             current_module->granted_decls);
        }

      /* Move the granted decls into the enclosing scope. */
      if (current_scope == global_scope)
        {
          tree next_decl;
          for (decl = current_module->granted_decls; decl; decl = next_decl)
            {
              tree name = DECL_NAME (decl);
              next_decl = TREE_CHAIN (decl);
              if (name != NULL_TREE)
                {
                  tree old_decl = IDENTIFIER_OUTER_VALUE (name);
                  set_nesting_level (decl, current_nesting_level);
                  if (old_decl != NULL_TREE)
                    {
                      pedwarn_with_decl (decl, "duplicate grant for `%s'");
                      pedwarn_with_decl (old_decl, "previous grant for `%s'");
                      TREE_CHAIN (decl) = TREE_CHAIN (old_decl);
                      TREE_CHAIN (old_decl) = decl;
                    }
                  else
                    {
                      TREE_CHAIN (decl) = outer_decls;
                      outer_decls = decl;
                      IDENTIFIER_OUTER_VALUE (name) = decl;
                    }
                }
            }
        }
      else
        current_scope->granted_decls = chainon (current_module->granted_decls,
                                                current_scope->granted_decls);
    }

  chill_check_no_handlers (); /* Sanity test */
  current_module = current_module->prev_module;
  current_module_nesting_level = current_module ?
    current_module->nesting_level : 0;
  in_pseudo_module = 0;
}
\f
/* Nonzero if we are currently in the global binding level.  */

int
global_bindings_p ()
{
  /* We return -1 here for the sake of variable_size() in ../stor-layout.c. */
  return (current_function_decl == NULL_TREE 
          || current_function_decl == global_function_decl) ? -1 : 0;
}

/* Nonzero if the current level needs to have a BLOCK made.  */

int
kept_level_p ()
{
  return current_scope->decls != 0;
}

/* Make DECL visible.
   Save any existing definition.
   Check redefinitions at the same level.
   Suppress error messages if QUIET is true. */

void
proclaim_decl (decl, quiet)
     tree decl;
     int quiet;
{
  tree name = DECL_NAME (decl);
  if (name)
    {
      tree old_decl = IDENTIFIER_LOCAL_VALUE (name);
      if (old_decl == NULL) ; /* No duplication */
      else if (DECL_NESTING_LEVEL (old_decl) != current_nesting_level)
        {
          /* Record for restoration when this binding level ends.  */
          current_scope->shadowed
            = tree_cons (name, old_decl, current_scope->shadowed);
        }
      else if (DECL_WEAK_NAME (decl))
        return;
      else if (!DECL_WEAK_NAME (old_decl))
        {
          tree base_decl = decl, base_old_decl = old_decl;
          while (TREE_CODE (base_decl) == ALIAS_DECL)
            base_decl = DECL_ABSTRACT_ORIGIN (base_decl);
          while (TREE_CODE (base_old_decl) == ALIAS_DECL)
            base_old_decl = DECL_ABSTRACT_ORIGIN (base_old_decl);
          /* Note that duplicate definitions are allowed for set elements
             of similar set modes.  See Z200 (1988) 12.2.2.
             However, if the types are identical, we are defining the
             same name multiple times in the same SET, which is naughty. */
          if (!quiet && base_decl != base_old_decl)
            {
              if (TREE_CODE (base_decl) != CONST_DECL
                  || TREE_CODE (base_old_decl) != CONST_DECL
                  || !CH_DECL_ENUM (base_decl)
                  || !CH_DECL_ENUM (base_old_decl)
                  || TREE_TYPE (base_decl) == TREE_TYPE (base_old_decl)
                  || !CH_SIMILAR (TREE_TYPE (base_decl),
                                  TREE_TYPE(base_old_decl)))
                {
                  error_with_decl (decl, "duplicate definition `%s'");
                  error_with_decl (old_decl, "previous definition of `%s'");
                }
            }
        }
      IDENTIFIER_LOCAL_VALUE (name) = decl;
    }
  /* Should be redundant most of the time ... */
  set_nesting_level (decl, current_nesting_level);
}

/* Return tree_cons (NULL_TREE, ELEMENT, LIST) unless ELEMENT
   is already in LIST, in which case return LIST. */

static tree
maybe_acons (element, list)
     tree element, list;
{
  tree pair;
  for (pair = list; pair; pair = TREE_CHAIN (pair))
    if (element == TREE_VALUE (pair))
      return list;
  return tree_cons (NULL_TREE, element, list);
}

struct path
{
  struct path *prev;
  tree node;
};
\f
/* Look for implied types (enumeral types) implied by TYPE (a decl or type).
   Add these to list.
   Use old_path to guard against cycles. */

tree
find_implied_types (type, old_path, list)
     tree type;
     struct path *old_path;
     tree list;
{
  struct path path[1], *link;
  if (type == NULL_TREE)
    return list;
  path[0].prev = old_path;
  path[0].node = type;

  /* Check for a cycle.  Something more clever might be appropriate.  FIXME? */
  for (link = old_path; link; link = link->prev)
    if (link->node == type)
      return list;

  switch (TREE_CODE (type))
    {
    case ENUMERAL_TYPE:
      return maybe_acons (type, list);
    case LANG_TYPE:
    case POINTER_TYPE:
    case REFERENCE_TYPE:
    case INTEGER_TYPE:
      return find_implied_types (TREE_TYPE (type), path, list);
    case SET_TYPE:
      return find_implied_types (TYPE_DOMAIN (type), path, list);
    case FUNCTION_TYPE:
#if 0
    case PROCESS_TYPE:
#endif
      { tree t;
        list = find_implied_types (TREE_TYPE (type), path, list);
        for (t = TYPE_ARG_TYPES (type); t != NULL_TREE; t = TREE_CHAIN (t))
          list = find_implied_types (TREE_VALUE (t), path, list);
        return list;
      }
    case ARRAY_TYPE:
      list = find_implied_types (TYPE_DOMAIN (type), path, list);
      return find_implied_types (TREE_TYPE (type), path, list);
    case RECORD_TYPE:
    case UNION_TYPE:
      { tree fields;
        for (fields = TYPE_FIELDS (type); fields != NULL_TREE;
             fields = TREE_CHAIN (fields))
          list = find_implied_types (TREE_TYPE (fields), path, list);
        return list;
      }

    case IDENTIFIER_NODE:
      return find_implied_types (lookup_name (type), path, list);
      break;
    case ALIAS_DECL:
      return find_implied_types (DECL_ABSTRACT_ORIGIN (type), path, list);
    case VAR_DECL:
    case FUNCTION_DECL:
    case TYPE_DECL:
      return find_implied_types (TREE_TYPE (type), path, list);
    default:
      return list;
    }
}
\f
/* Make declarations in current scope visible.
   Also, expand SEIZEs, and make correspondong ALIAS_DECLs visible. */

static void
push_scope_decls (quiet)
     int quiet;  /* If 1, we're pre-scanning, so suppress errors. */
{
  tree decl;

  /* First make everything except 'SEIZE ALL' names visible, before
     handling 'SEIZE ALL'.  (This makes it easier to check 'seizable'). */
  for (decl = current_scope->remembered_decls; decl; decl = TREE_CHAIN (decl))
    {
      if (TREE_CODE (decl) == ALIAS_DECL)
        {
          if (DECL_POSTFIX_ALL (decl))
            continue;
          if (DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE)
            {
              tree val = lookup_name_for_seizing (decl);
              if (val == NULL_TREE)
                {
                  error_with_file_and_line
                    (DECL_SOURCE_FILE (decl), DECL_SOURCE_LINE (decl),
                     "cannot SEIZE `%s'",
                     IDENTIFIER_POINTER (DECL_OLD_NAME (decl)));
                  val = error_mark_node;
                }
              DECL_ABSTRACT_ORIGIN (decl) = val;
            }
        }
      proclaim_decl (decl, quiet);
    }

  pushdecllist (current_scope->granted_decls, quiet);

  /* Now handle SEIZE ALLs. */
  for (decl = current_scope->remembered_decls; decl; )
    {
      tree next_decl = TREE_CHAIN (decl);
      if (TREE_CODE (decl) == ALIAS_DECL
          && DECL_ABSTRACT_ORIGIN (decl) == NULL_TREE
          && DECL_POSTFIX_ALL (decl))
        {
          /* We saw a "SEIZE ALL".  Replace it be a SEIZE for each
             declaration visible in the surrounding scope.
             Note that this complicates get_next_decl(). */
          tree candidate;
          tree last_new_alias = decl;
          DECL_ABSTRACT_ORIGIN (decl) = error_mark_node;
          if (current_scope->enclosing == global_scope)
            candidate = outer_decls;
          else
            candidate = current_scope->enclosing->decls;
          for ( ; candidate; candidate = TREE_CHAIN (candidate))
            {
              tree seizename = DECL_NAME (candidate);
              tree new_name;
              tree new_alias;
              if (!seizename)
                continue;
              new_name = decl_check_rename (decl, seizename);
              if (!new_name)
                continue;

              /* Check if candidate is seizable. */
              if (lookup_name (new_name) != NULL_TREE)
                continue;

              new_alias = build_alias_decl (NULL_TREE,NULL_TREE, new_name);
              TREE_CHAIN (new_alias) = TREE_CHAIN (last_new_alias);
              TREE_CHAIN (last_new_alias) = new_alias;
              last_new_alias = new_alias;
              DECL_ABSTRACT_ORIGIN (new_alias) = candidate;
              DECL_SOURCE_LINE (new_alias) = 0;

              proclaim_decl (new_alias, quiet);
            }
        }
      decl = next_decl;
    }

  /* Link current_scope->remembered_decls at the head of the
     current_scope->decls list (just like pushdecllist, but
     without calling proclaim_decl, since we've already done that). */
  if ((decl = current_scope->remembered_decls) != NULL_TREE)
    {
      while (TREE_CHAIN (decl) != NULL_TREE)
        decl = TREE_CHAIN (decl);
      TREE_CHAIN (decl) = current_scope->decls;
      current_scope->decls = current_scope->remembered_decls;
    }
}

static void
pop_scope_decls (decls_limit, shadowed_limit)
     tree decls_limit, shadowed_limit;
{
  /* Remove the temporary bindings we made. */
  tree link = current_scope->shadowed;
  tree decl = current_scope->decls;
  if (decl != decls_limit)
    {
      while (decl != decls_limit)
        {
          tree next = TREE_CHAIN (decl);
          if (DECL_NAME (decl))
            {
              /* If the ident. was used or addressed via a local extern decl,
                 don't forget that fact.  */
              if (DECL_EXTERNAL (decl))
                {
                  if (TREE_USED (decl))
                    TREE_USED (DECL_NAME (decl)) = 1;
                  if (TREE_ADDRESSABLE (decl))
                    TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (decl)) = 1;
                }
              IDENTIFIER_LOCAL_VALUE (DECL_NAME (decl)) = 0;
            }
          if (next == decls_limit)
            {
              TREE_CHAIN (decl) = NULL_TREE;
              break;
            }
          decl = next;
        }
      current_scope->decls = decls_limit;
    }
  
  /* Restore all name-meanings of the outer levels
     that were shadowed by this level.  */
  for ( ; link != shadowed_limit; link = TREE_CHAIN (link))
    IDENTIFIER_LOCAL_VALUE (TREE_PURPOSE (link)) = TREE_VALUE (link);
  current_scope->shadowed = shadowed_limit;
}

/* Return list of weak names (as ALIAS_DECLs) implied by IMPLIED_TYPES. */

static tree
build_implied_names (implied_types)
     tree implied_types;
{
  tree aliases = NULL_TREE;

  for ( ; implied_types; implied_types = TREE_CHAIN (implied_types))
    {
      tree enum_type = TREE_VALUE (implied_types);
      tree link = TYPE_VALUES (enum_type);
      if (TREE_CODE (enum_type) != ENUMERAL_TYPE)
        abort ();
      
      for ( ; link; link = TREE_CHAIN (link))
        {
          /* We don't handle renaming/prefixes (Blue Book p 163) FIXME */
          /* Note that before enum_type is laid out, TREE_VALUE (link)
             is a CONST_DECL, while after it is laid out,
             TREE_VALUE (link) is an INTEGER_CST.  Either works. */
          tree alias
            = build_alias_decl (NULL_TREE, NULL_TREE, TREE_PURPOSE (link));
          DECL_ABSTRACT_ORIGIN (alias) = TREE_VALUE (link);
          DECL_WEAK_NAME (alias) = 1;
          TREE_CHAIN (alias) = aliases;
          aliases = alias;
          /* Strictlt speaking, we should have a pointer from the alias
             to the decl, so we can make sure that the alias is only
             visible when the decl is.  FIXME */
        }
    }
  return aliases;
}

static void
bind_sub_modules (do_weak)
     int do_weak;
{
  tree decl;
  int save_module_nesting_level = current_module_nesting_level;
  struct scope *saved_scope = current_scope;
  struct scope *nested_module = current_scope->first_child_module;

  while (nested_module != NULL)
    {
      tree saved_shadowed = nested_module->shadowed;
      tree saved_decls = nested_module->decls;
      current_nesting_level++;
      current_scope = nested_module;
      current_module_nesting_level = current_nesting_level;
      if (do_weak == 0)
        push_scope_decls (1);
      else
        {
          tree implied_types = NULL_TREE;
          /* Push weak names implied by decls in current_scope. */
          for (decl = current_scope->remembered_decls;
               decl; decl = TREE_CHAIN (decl))
            if (TREE_CODE (decl) == ALIAS_DECL)
              implied_types = find_implied_types (decl, NULL, implied_types);
          for (decl = current_scope->granted_decls;
               decl; decl = TREE_CHAIN (decl))
            implied_types = find_implied_types (decl, NULL, implied_types);
          current_scope->weak_decls = build_implied_names (implied_types);
          pushdecllist (current_scope->weak_decls, 1);
        }

      bind_sub_modules (do_weak);
      for (decl = current_scope->remembered_decls;
           decl; decl = TREE_CHAIN (decl))
        satisfy_decl (decl, 1);
      pop_scope_decls (saved_decls, saved_shadowed);
      current_nesting_level--;
      nested_module = nested_module->next_sibling_module;
    }

  current_scope = saved_scope;
  current_module_nesting_level = save_module_nesting_level;
}
\f
/* Enter a new binding level.
   If two_pass==0, assume we are called from non-Chill-specific parts
   of the compiler.  These parts assume a single pass.
   If two_pass==1,  we're called from Chill parts of the compiler.
*/

void
pushlevel (two_pass)
     int two_pass;
{
  register struct scope *newlevel;

  current_nesting_level++;
  if (!two_pass)
    {
      newlevel = (struct scope *)xmalloc (sizeof(struct scope));
      *newlevel = clear_scope;
      newlevel->enclosing = current_scope;
      current_scope = newlevel;
    }
  else if (pass < 2)
    {
      newlevel = (struct scope *)permalloc (sizeof(struct scope));
      *newlevel = clear_scope;
      newlevel->tail_child_module = &newlevel->first_child_module;
      newlevel->enclosing = current_scope;
      current_scope = newlevel;
      last_scope->next = newlevel;
      last_scope = newlevel;
    }
  else /* pass == 2 */
    {
      tree decl;
      newlevel = current_scope = last_scope = last_scope->next;

      push_scope_decls (0);
      pushdecllist (current_scope->weak_decls, 0);

      /* If this is not a module scope, scan ahead for locally nested
         modules.  (If this is a module, that's already done.) */
      if (!current_scope->module_flag)
        {
          bind_sub_modules (0);
          bind_sub_modules (1);
        }

      for (decl = current_scope->remembered_decls;
           decl; decl = TREE_CHAIN (decl))
        satisfy_decl (decl, 0);
    }

  /* Add this level to the front of the chain (stack) of levels that
     are active.  */

  newlevel->level_chain = current_scope;
  current_scope = newlevel;

  newlevel->two_pass = two_pass;
}
\f
/* Exit a binding level.
   Pop the level off, and restore the state of the identifier-decl mappings
   that were in effect when this level was entered.

   If KEEP is nonzero, this level had explicit declarations, so
   and create a "block" (a BLOCK node) for the level
   to record its declarations and subblocks for symbol table output.

   If FUNCTIONBODY is nonzero, this level is the body of a function,
   so create a block as if KEEP were set and also clear out all
   label names.

   If REVERSE is nonzero, reverse the order of decls before putting
   them into the BLOCK.  */

tree
poplevel (keep, reverse, functionbody)
     int keep;
     int reverse;
     int functionbody;
{
  register tree link;
  /* The chain of decls was accumulated in reverse order.
     Put it into forward order, just for cleanliness.  */
  tree decls;
  tree subblocks;
  tree block = 0;
  tree decl;
  int block_previously_created = 0;

  if (current_scope == NULL)
    return error_mark_node;

  subblocks = current_scope->blocks;

  /* Get the decls in the order they were written.
     Usually current_scope->decls is in reverse order.
     But parameter decls were previously put in forward order.  */

  if (reverse)
    current_scope->decls
      = decls = nreverse (current_scope->decls);
  else
    decls = current_scope->decls;

  if (pass == 2)
    {
      /* Output any nested inline functions within this block
         if they weren't already output.  */

      for (decl = decls; decl; decl = TREE_CHAIN (decl))
        if (TREE_CODE (decl) == FUNCTION_DECL
            && ! TREE_ASM_WRITTEN (decl)
            && DECL_INITIAL (decl) != 0
            && TREE_ADDRESSABLE (decl))
          {
            /* If this decl was copied from a file-scope decl
               on account of a block-scope extern decl,
               propagate TREE_ADDRESSABLE to the file-scope decl.  */
            if (DECL_ABSTRACT_ORIGIN (decl) != 0)
              TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
            else
              {
                push_function_context ();
                output_inline_function (decl);
                pop_function_context ();
              }
          }

      /* Clear out the meanings of the local variables of this level.  */
      pop_scope_decls (NULL_TREE, NULL_TREE);

      /* If there were any declarations or structure tags in that level,
         or if this level is a function body,
         create a BLOCK to record them for the life of this function.  */

      block = 0;
      block_previously_created = (current_scope->this_block != 0);
      if (block_previously_created)
        block = current_scope->this_block;
      else if (keep || functionbody)
        block = make_node (BLOCK);
      if (block != 0)
        {
          tree *ptr;
          BLOCK_VARS (block) = decls;

          /* Splice out ALIAS_DECL and LABEL_DECLs,
             since instantiate_decls can't handle them. */
          for (ptr = &BLOCK_VARS (block); *ptr; )
            {
              decl = *ptr;
              if (TREE_CODE (decl) == ALIAS_DECL
                  || TREE_CODE (decl) == LABEL_DECL)
                *ptr = TREE_CHAIN (decl);
              else
                ptr = &TREE_CHAIN(*ptr);
            }

          BLOCK_SUBBLOCKS (block) = subblocks;
          remember_end_note (block);
        }

      /* In each subblock, record that this is its superior.  */

      for (link = subblocks; link; link = TREE_CHAIN (link))
        BLOCK_SUPERCONTEXT (link) = block;

    }

  /* If the level being exited is the top level of a function,
     check over all the labels, and clear out the current
     (function local) meanings of their names.  */

  if (pass == 2 && functionbody)
    {
      /* If this is the top level block of a function,
         the vars are the function's parameters.
         Don't leave them in the BLOCK because they are
         found in the FUNCTION_DECL instead.  */

      BLOCK_VARS (block) = 0;

#if 0
      /* Clear out the definitions of all label names,
         since their scopes end here,
         and add them to BLOCK_VARS.  */

      for (link = named_labels; link; link = TREE_CHAIN (link))
        {
          register tree label = TREE_VALUE (link);

          if (DECL_INITIAL (label) == 0)
            {
              error_with_decl (label, "label `%s' used but not defined");
              /* Avoid crashing later.  */
              define_label (input_filename, lineno,
                            DECL_NAME (label));
            }
          else if (warn_unused && !TREE_USED (label))
            warning_with_decl (label, "label `%s' defined but not used");
          IDENTIFIER_LABEL_VALUE (DECL_NAME (label)) = 0;

          /* Put the labels into the "variables" of the
             top-level block, so debugger can see them.  */
          TREE_CHAIN (label) = BLOCK_VARS (block);
          BLOCK_VARS (block) = label;
        }
#endif
    }

  if (pass < 2)
    {
      current_scope->remembered_decls
        = nreverse (current_scope->remembered_decls);
      current_scope->granted_decls = nreverse (current_scope->granted_decls);
    }

  current_scope = current_scope->enclosing;
  current_nesting_level--;

  if (pass < 2)
    {
      return NULL_TREE;
    }

  /* Dispose of the block that we just made inside some higher level.  */
  if (functionbody)
    DECL_INITIAL (current_function_decl) = block;
  else if (block)
    {
      if (!block_previously_created)
        current_scope->blocks
          = chainon (current_scope->blocks, block);
    }
  /* If we did not make a block for the level just exited,
     any blocks made for inner levels
     (since they cannot be recorded as subblocks in that level)
     must be carried forward so they will later become subblocks
     of something else.  */
  else if (subblocks)
    current_scope->blocks
      = chainon (current_scope->blocks, subblocks);

  if (block)
    TREE_USED (block) = 1;
  return block;
}
\f
/* Delete the node BLOCK from the current binding level.
   This is used for the block inside a stmt expr ({...})
   so that the block can be reinserted where appropriate.  */

void
delete_block (block)
     tree block;
{
  tree t;
  if (current_scope->blocks == block)
    current_scope->blocks = TREE_CHAIN (block);
  for (t = current_scope->blocks; t;)
    {
      if (TREE_CHAIN (t) == block)
        TREE_CHAIN (t) = TREE_CHAIN (block);
      else
        t = TREE_CHAIN (t);
    }
  TREE_CHAIN (block) = NULL;
  /* Clear TREE_USED which is always set by poplevel.
     The flag is set again if insert_block is called.  */
  TREE_USED (block) = 0;
}

/* Insert BLOCK at the end of the list of subblocks of the
   current binding level.  This is used when a BIND_EXPR is expanded,
   to handle the BLOCK node inside teh BIND_EXPR.  */

void
insert_block (block)
     tree block;
{
  TREE_USED (block) = 1;
  current_scope->blocks
    = chainon (current_scope->blocks, block);
}

/* Set the BLOCK node for the innermost scope
   (the one we are currently in).  */

void
set_block (block)
     register tree block;
{
  current_scope->this_block = block;
}
\f
/* Record a decl-node X as belonging to the current lexical scope.
   Check for errors (such as an incompatible declaration for the same
   name already seen in the same scope).

   Returns either X or an old decl for the same name.
   If an old decl is returned, it may have been smashed
   to agree with what X says. */

tree
pushdecl (x)
     tree x;
{
  register tree name = DECL_NAME (x);
  register struct scope *b = current_scope;

  DECL_CONTEXT (x) = current_function_decl;
  /* A local extern declaration for a function doesn't constitute nesting.
     A local auto declaration does, since it's a forward decl
     for a nested function coming later.  */
  if (TREE_CODE (x) == FUNCTION_DECL && DECL_INITIAL (x) == 0
      && DECL_EXTERNAL (x))
    DECL_CONTEXT (x) = 0;

  if (name)
    proclaim_decl (x, 0);

  if (TREE_CODE (x) == TYPE_DECL && DECL_SOURCE_LINE (x) == 0
      && TYPE_NAME (TREE_TYPE (x)) == 0)
    TYPE_NAME (TREE_TYPE (x)) = x;

  /* Put decls on list in reverse order.
     We will reverse them later if necessary.  */
  TREE_CHAIN (x) = b->decls;
  b->decls = x;

  return x;
}
\f
/* Make DECLS (a chain of decls) visible in the current_scope. */

static void
pushdecllist (decls, quiet)
     tree decls;
     int quiet;
{
  tree last = NULL_TREE, decl;

  for (decl = decls; decl != NULL_TREE; 
       last = decl, decl = TREE_CHAIN (decl))
    {
      proclaim_decl (decl, quiet);
    }

  if (last)
    {
      TREE_CHAIN (last) = current_scope->decls;
      current_scope->decls = decls;
    }
}

/* Like pushdecl, only it places X in GLOBAL_SCOPE, if appropriate.  */

tree
pushdecl_top_level (x)
     tree x;
{
  register tree t;
  register struct scope *b = current_scope;

  current_scope = global_scope;
  t = pushdecl (x);
  current_scope = b;
  return t;
}
\f
/* Define a label, specifying the location in the source file.
   Return the LABEL_DECL node for the label, if the definition is valid.
   Otherwise return 0.  */

tree
define_label (filename, line, name)
     char *filename;
     int line;
     tree name;
{
  tree decl;

  if (pass == 1)
    {
      decl = build_decl (LABEL_DECL, name, void_type_node);

      /* A label not explicitly declared must be local to where it's ref'd.  */
      DECL_CONTEXT (decl) = current_function_decl;

      DECL_MODE (decl) = VOIDmode;

      /* Say where one reference is to the label,
         for the sake of the error if it is not defined.  */
      DECL_SOURCE_LINE (decl) = line;
      DECL_SOURCE_FILE (decl) = filename;

      /* Mark label as having been defined.  */
      DECL_INITIAL (decl) = error_mark_node;

      DECL_ACTION_NESTING_LEVEL (decl) = action_nesting_level;

      save_decl (decl);
    }
  else
    {
      decl = get_next_decl ();
      /* Make sure every label has an rtx.  */

      label_rtx (decl);
      expand_label (decl);
    }
  return decl;
}
\f
/* Return the list of declarations of the current level.
   Note that this list is in reverse order unless/until
   you nreverse it; and when you do nreverse it, you must
   store the result back using `storedecls' or you will lose.  */

tree
getdecls ()
{
  /* This is a kludge, so that dbxout_init can get the predefined types,
     which are in the builtin_scope, though when it is called,
     the current_scope is the global_scope.. */
  if (current_scope == global_scope)
    return builtin_scope.decls;
  return current_scope->decls;
}

#if 0
/* Store the list of declarations of the current level.
   This is done for the parameter declarations of a function being defined,
   after they are modified in the light of any missing parameters.  */

static void
storedecls (decls)
     tree decls;
{
  current_scope->decls = decls;
}
#endif
\f
/* Look up NAME in the current binding level and its superiors
   in the namespace of variables, functions and typedefs.
   Return a ..._DECL node of some kind representing its definition,
   or return 0 if it is undefined.  */

tree
lookup_name (name)
     tree name;
{
  register tree val = IDENTIFIER_LOCAL_VALUE (name);

  if (val == NULL_TREE)
    return NULL_TREE;
  if (TREE_CODE_CLASS (TREE_CODE (val)) == 'c')
    return val;
  if (DECL_NESTING_LEVEL (val) > BUILTIN_NESTING_LEVEL
      && DECL_NESTING_LEVEL (val) < current_module_nesting_level)
    {
      return NULL_TREE;
    }
  while (TREE_CODE (val) == ALIAS_DECL)
    {
      val = DECL_ABSTRACT_ORIGIN (val);
      if (TREE_CODE (val) == ERROR_MARK)
        return NULL_TREE;
    }
  if (TREE_CODE (val) == BASED_DECL)
    {
      return build_chill_indirect_ref (DECL_ABSTRACT_ORIGIN (val),
                                       TREE_TYPE (val), 1);
    }
  if (TREE_CODE (val) == WITH_DECL)
    return build_component_ref (DECL_ABSTRACT_ORIGIN (val), DECL_NAME (val));
  return val;
}

#if 0
/* Similar to `lookup_name' but look only at current binding level.  */

static tree
lookup_name_current_level (name)
     tree name;
{
  register tree val = IDENTIFIER_LOCAL_VALUE (name);
  if (val && DECL_NESTING_LEVEL (val) == current_nesting_level)
    return val;
  return NULL_TREE;
}
#endif

static tree
lookup_name_for_seizing (seize_decl)
     tree seize_decl;
{
  tree name = DECL_OLD_NAME (seize_decl);
  register tree val;
  val = IDENTIFIER_LOCAL_VALUE (name);
  if (val == NULL_TREE || DECL_NESTING_LEVEL (val) == BUILTIN_NESTING_LEVEL)
    {
      val = IDENTIFIER_OUTER_VALUE (name);
      if (val == NULL_TREE)
        return NULL_TREE;
      if (TREE_CHAIN (val) && DECL_NAME (TREE_CHAIN (val)) == name)
        { /* More than one decl with the same name has been granted
             into the same global scope.  Pick the one (we hope) that
             came from a seizefile the matches the most recent
             seizefile (as given by DECL_SEIZEFILE (seize_decl).) */
          tree d, best = NULL_TREE;
          for (d = val; d != NULL_TREE && DECL_NAME (d) == name;
               d = TREE_CHAIN (d))
            if (DECL_SEIZEFILE (d) == DECL_SEIZEFILE (seize_decl))
              {
                if (best)
                  {
                    error_with_decl (seize_decl,
                                     "ambiguous choice for seize `%s' -");
                    error_with_decl (best, " - can seize this `%s' -");
                    error_with_decl (d, " - or this granted decl `%s'");
                    return NULL_TREE;
                  }
                best = d;
              }
          if (best == NULL_TREE)
            {
              error_with_decl (seize_decl,
                               "ambiguous choice for seize `%s' -");
              error_with_decl (val, " - can seize this `%s' -");
              error_with_decl (TREE_CHAIN (val),
                               " - or this granted decl `%s'");
              return NULL_TREE;
            }
          val = best;
        }
    }
#if 0
  /* We don't need to handle this, as long as we
     resolve the seize targets before pushing them. */
  if (DECL_NESTING_LEVEL (val) >= current_module_nesting_level)
    {
      /* VAL was declared inside current module.  We need something
         from the scope *enclosing* the current module, so search
         through the shadowed declarations. */
      /* TODO - FIXME */
    }
#endif
  if (current_module && current_module->prev_module
      && DECL_NESTING_LEVEL (val)
      < current_module->prev_module->nesting_level)
    {

      /* It's declared in a scope enclosing the module enclosing
         the current module.  Hence it's not visible. */
      return NULL_TREE;
    }
  while (TREE_CODE (val) == ALIAS_DECL)
    {
      val = DECL_ABSTRACT_ORIGIN (val);
      if (TREE_CODE (val) == ERROR_MARK)
        return NULL_TREE;
    }
  return val;
}
\f
/* Create the predefined scalar types of C,
   and some nodes representing standard constants (0, 1, (void *)0).
   Initialize the global binding level.
   Make definitions for built-in primitive functions.  */

void
init_decl_processing ()
{
  int  wchar_type_size;
  tree bool_ftype_int_ptr_int;
  tree bool_ftype_int_ptr_int_int;
  tree bool_ftype_luns_ptr_luns_long;
  tree bool_ftype_luns_ptr_luns_long_ptr_int;
  tree bool_ftype_ptr_int_ptr_int;
  tree bool_ftype_ptr_int_ptr_int_int;
  tree find_bit_ftype;
  tree bool_ftype_ptr_ptr_int;
  tree bool_ftype_ptr_ptr_luns;
  tree bool_ftype_ptr_ptr_ptr_luns;
  tree endlink;
  tree int_ftype_int;
  tree int_ftype_int_int;
  tree int_ftype_int_ptr_int;
  tree int_ftype_ptr;
  tree int_ftype_ptr_int;
  tree int_ftype_ptr_int_int_ptr_int;
  tree int_ftype_ptr_luns_long_ptr_int;
  tree int_ftype_ptr_ptr_int;
  tree int_ftype_ptr_ptr_luns;
  tree long_ftype_ptr_luns;
  tree memcpy_ftype;
  tree memcmp_ftype;
  tree ptr_ftype_ptr_int_int;
  tree ptr_ftype_ptr_ptr_int;
  tree ptr_ftype_ptr_ptr_int_ptr_int;
  tree real_ftype_real;
  tree temp;
  tree void_ftype_cptr_cptr_int;
  tree void_ftype_long_int_ptr_int_ptr_int;
  tree void_ftype_ptr;
  tree void_ftype_ptr_int_int_int_int;
  tree void_ftype_ptr_int_ptr_int_int_int;
  tree void_ftype_ptr_int_ptr_int_ptr_int;
  tree void_ftype_ptr_luns_long_long_bool_ptr_int;
  tree void_ftype_ptr_luns_ptr_luns_luns_luns;
  tree void_ftype_ptr_ptr_ptr_int;
  tree void_ftype_ptr_ptr_ptr_luns;
  tree void_ftype_refptr_int_ptr_int;
  tree void_ftype_void;
  tree void_ftype_ptr_ptr_int;
  tree void_ftype_ptr_luns_luns_cptr_luns_luns_luns;
  tree ptr_ftype_luns_ptr_int;
  tree double_ftype_double;

  extern int set_alignment;

  /* allow 0-255 enums to occupy only a byte */
  flag_short_enums = 1;

  current_function_decl = NULL;

  set_alignment = BITS_PER_UNIT;

  ALL_POSTFIX = get_identifier ("*");
  string_index_type_dummy = get_identifier("%string-index%");

  var_length_id = get_identifier (VAR_LENGTH);
  var_data_id = get_identifier (VAR_DATA);

  /* This is the *C* int type. */
  integer_type_node = make_signed_type (INT_TYPE_SIZE);

  if (CHILL_INT_IS_SHORT)
    long_integer_type_node = integer_type_node;
  else
    long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);

  unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
  long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
  long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
  long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);

  /* `unsigned long' is the standard type for sizeof.
     Note that stddef.h uses `unsigned long',
     and this must agree, even of long and int are the same size.  */
#ifndef SIZE_TYPE
    sizetype = long_unsigned_type_node;
#else
  {
    char *size_type_c_name = SIZE_TYPE;
    if (strncmp (size_type_c_name, "long long ", 10) == 0)
      sizetype = long_long_unsigned_type_node;
    else if (strncmp (size_type_c_name, "long ", 5) == 0)
      sizetype = long_unsigned_type_node;
    else
      sizetype = unsigned_type_node;
  }
#endif

  TREE_TYPE (TYPE_SIZE (integer_type_node)) = sizetype;
  TREE_TYPE (TYPE_SIZE (unsigned_type_node)) = sizetype;
  TREE_TYPE (TYPE_SIZE (long_unsigned_type_node)) = sizetype;
  TREE_TYPE (TYPE_SIZE (long_integer_type_node)) = sizetype;
  TREE_TYPE (TYPE_SIZE (long_long_integer_type_node)) = sizetype;
  TREE_TYPE (TYPE_SIZE (long_long_unsigned_type_node)) = sizetype;

  error_mark_node = make_node (ERROR_MARK);
  TREE_TYPE (error_mark_node) = error_mark_node;

  short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
  short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
  signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
  unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
  intQI_type_node = make_signed_type (GET_MODE_BITSIZE (QImode));
  intHI_type_node = make_signed_type (GET_MODE_BITSIZE (HImode));
  intSI_type_node = make_signed_type (GET_MODE_BITSIZE (SImode));
  intDI_type_node = make_signed_type (GET_MODE_BITSIZE (DImode));
#if HOST_BITS_PER_WIDE_INT >= 64
  intTI_type_node = make_signed_type (GET_MODE_BITSIZE (TImode));
#endif
  unsigned_intQI_type_node = make_unsigned_type (GET_MODE_BITSIZE (QImode));
  unsigned_intHI_type_node = make_unsigned_type (GET_MODE_BITSIZE (HImode));
  unsigned_intSI_type_node = make_unsigned_type (GET_MODE_BITSIZE (SImode));
  unsigned_intDI_type_node = make_unsigned_type (GET_MODE_BITSIZE (DImode));
#if HOST_BITS_PER_WIDE_INT >= 64
  unsigned_intTI_type_node = make_unsigned_type (GET_MODE_BITSIZE (TImode));
#endif

  float_type_node = make_node (REAL_TYPE);
  TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int) RID_FLOAT],
                        float_type_node));
  layout_type (float_type_node);

  double_type_node = make_node (REAL_TYPE);
  if (flag_short_double)
    TYPE_PRECISION (double_type_node) = FLOAT_TYPE_SIZE;
  else
    TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int) RID_DOUBLE],
                        double_type_node));
  layout_type (double_type_node);

  long_double_type_node = make_node (REAL_TYPE);
  TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
  layout_type (long_double_type_node);

  complex_integer_type_node = make_node (COMPLEX_TYPE);
  TREE_TYPE (complex_integer_type_node) = integer_type_node;
  layout_type (complex_integer_type_node);

  complex_float_type_node = make_node (COMPLEX_TYPE);
  TREE_TYPE (complex_float_type_node) = float_type_node;
  layout_type (complex_float_type_node);

  complex_double_type_node = make_node (COMPLEX_TYPE);
  TREE_TYPE (complex_double_type_node) = double_type_node;
  layout_type (complex_double_type_node);

  complex_long_double_type_node = make_node (COMPLEX_TYPE);
  TREE_TYPE (complex_long_double_type_node) = long_double_type_node;
  layout_type (complex_long_double_type_node);

  integer_zero_node = build_int_2 (0, 0);
  TREE_TYPE (integer_zero_node) = integer_type_node;
  integer_one_node = build_int_2 (1, 0);
  TREE_TYPE (integer_one_node) = integer_type_node;
  integer_minus_one_node = build_int_2 (-1, -1);
  TREE_TYPE (integer_minus_one_node) = integer_type_node;

  size_zero_node = build_int_2 (0, 0);
  TREE_TYPE (size_zero_node) = sizetype;
  size_one_node = build_int_2 (1, 0);
  TREE_TYPE (size_one_node) = sizetype;

  void_type_node = make_node (VOID_TYPE);
  pushdecl (build_decl (TYPE_DECL,
                        ridpointers[(int) RID_VOID], void_type_node));
  layout_type (void_type_node); /* Uses integer_zero_node */
  /* We are not going to have real types in C with less than byte alignment,
     so we might as well not have any types that claim to have it.  */
  TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;

  null_pointer_node = build_int_2 (0, 0);
  TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
  layout_type (TREE_TYPE (null_pointer_node));

  /* This is for wide string constants.  */
  wchar_type_node = short_unsigned_type_node;
  wchar_type_size = TYPE_PRECISION (wchar_type_node);
  signed_wchar_type_node = type_for_size (wchar_type_size, 0);
  unsigned_wchar_type_node = type_for_size (wchar_type_size, 1);

  default_function_type
    = build_function_type (integer_type_node, NULL_TREE);

  ptr_type_node = build_pointer_type (void_type_node);
  const_ptr_type_node
    = build_pointer_type (build_type_variant (void_type_node, 1, 0));

  void_list_node = build_tree_list (NULL_TREE, void_type_node);

  boolean_type_node = make_node (BOOLEAN_TYPE);
  TYPE_PRECISION (boolean_type_node) = 1;
  fixup_unsigned_type (boolean_type_node);
  boolean_false_node = TYPE_MIN_VALUE (boolean_type_node);
  boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_BOOL],
                        boolean_type_node));

  /* TRUE and FALSE have the BOOL derived class */
  CH_DERIVED_FLAG (boolean_true_node) = 1;
  CH_DERIVED_FLAG (boolean_false_node) = 1;

  signed_boolean_type_node = make_node (BOOLEAN_TYPE);
  temp = build_int_2 (-1, -1);
  TREE_TYPE (temp) = signed_boolean_type_node;
  TYPE_MIN_VALUE (signed_boolean_type_node) = temp;
  temp = build_int_2 (0, 0);
  TREE_TYPE (temp) = signed_boolean_type_node;
  TYPE_MAX_VALUE (signed_boolean_type_node) = temp;
  layout_type (signed_boolean_type_node);

 
  bitstring_one_type_node = build_bitstring_type (integer_one_node);
  bit_zero_node = build (CONSTRUCTOR, bitstring_one_type_node, NULL_TREE,
                         NULL_TREE);
  bit_one_node = build (CONSTRUCTOR, bitstring_one_type_node, NULL_TREE,
                        build_tree_list (NULL_TREE, integer_zero_node));

  char_type_node = make_node (CHAR_TYPE);
  TYPE_PRECISION (char_type_node) = CHAR_TYPE_SIZE;
  fixup_unsigned_type (char_type_node);
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_CHAR],
                        char_type_node));

  if (CHILL_INT_IS_SHORT)
    {
      chill_integer_type_node = short_integer_type_node;
      chill_unsigned_type_node = short_unsigned_type_node;
    }
  else
    {
      chill_integer_type_node = integer_type_node;
      chill_unsigned_type_node = unsigned_type_node;
    }

  string_one_type_node = build_string_type (char_type_node, integer_one_node);

  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_BYTE],
                        signed_char_type_node));
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_UBYTE],
                        unsigned_char_type_node));

  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_INT],
                        chill_integer_type_node));

  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_UINT],
                        chill_unsigned_type_node));

  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_LONG],
                        long_integer_type_node));

  sizetype = long_integer_type_node;
#if 0
  ptrdiff_type_node
    = TREE_TYPE (IDENTIFIER_LOCAL_VALUE (get_identifier (PTRDIFF_TYPE)));
#endif
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_ULONG],
                        long_unsigned_type_node));
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_REAL],
                        float_type_node));
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_LONG_REAL],
                        double_type_node));
  pushdecl (build_decl (TYPE_DECL, ridpointers[(int)RID_PTR],
                        ptr_type_node));

  IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_TRUE]) =
    boolean_true_node;    
  IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_FALSE]) =
    boolean_false_node;    
  IDENTIFIER_LOCAL_VALUE (ridpointers[(int)RID_NULL]) =
    null_pointer_node;    

  /* The second operand is set to non-NULL to distinguish
     (ELSE) from (*).  Used when writing grant files.  */
  case_else_node = build (RANGE_EXPR,
                          NULL_TREE, NULL_TREE, boolean_false_node);

  pushdecl (temp = build_decl (TYPE_DECL,
                     get_identifier ("__tmp_initializer"),
                       build_init_struct ()));
  DECL_SOURCE_LINE (temp) = 0;
  initializer_type = TREE_TYPE (temp);

  bcopy (chill_tree_code_type,
         tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE,
         (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
          * sizeof (char)));
  bcopy ((char *) chill_tree_code_length,
         (char *) (tree_code_length + (int) LAST_AND_UNUSED_TREE_CODE),
         (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
          * sizeof (int)));
  bcopy ((char *) chill_tree_code_name,
         (char *) (tree_code_name + (int) LAST_AND_UNUSED_TREE_CODE),
         (((int) LAST_CHILL_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE)
          * sizeof (char *)));
  boolean_code_name = (char **) xmalloc (sizeof (char *) * (int) LAST_CHILL_TREE_CODE);
  bzero ((char *) boolean_code_name, sizeof (char *) * (int) LAST_CHILL_TREE_CODE);

  boolean_code_name[EQ_EXPR] = "=";
  boolean_code_name[NE_EXPR] = "/=";
  boolean_code_name[LT_EXPR] = "<";
  boolean_code_name[GT_EXPR] = ">";
  boolean_code_name[LE_EXPR] = "<=";
  boolean_code_name[GE_EXPR] = ">=";
  boolean_code_name[SET_IN_EXPR] = "in";
  boolean_code_name[TRUTH_ANDIF_EXPR] = "andif";
  boolean_code_name[TRUTH_ORIF_EXPR] = "orif";
  boolean_code_name[TRUTH_AND_EXPR] = "and";
  boolean_code_name[TRUTH_OR_EXPR] = "or";
  boolean_code_name[BIT_AND_EXPR] = "and";
  boolean_code_name[BIT_IOR_EXPR] = "or";
  boolean_code_name[BIT_XOR_EXPR] = "xor";

  endlink = void_list_node;

  chill_predefined_function_type
    = build_function_type (integer_type_node,
       tree_cons (NULL_TREE, integer_type_node,
         endlink));

  bool_ftype_int_ptr_int
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, integer_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                      endlink))));
  bool_ftype_int_ptr_int
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, integer_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                      tree_cons (NULL_TREE, integer_type_node,
                          endlink)))));
  bool_ftype_int_ptr_int_int
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, integer_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, integer_type_node,
                          tree_cons (NULL_TREE, integer_type_node,
                              endlink)))));
  bool_ftype_luns_ptr_luns_long
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, long_unsigned_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, long_unsigned_type_node,
                          tree_cons (NULL_TREE, long_integer_type_node,
                              endlink)))));
  bool_ftype_luns_ptr_luns_long_ptr_int
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, long_unsigned_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, long_unsigned_type_node,
                          tree_cons (NULL_TREE, long_integer_type_node,
                              tree_cons (NULL_TREE, ptr_type_node,
                                  tree_cons (NULL_TREE, integer_type_node,
                                      endlink)))))));
  bool_ftype_ptr_ptr_int
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, integer_type_node, 
                      endlink))));
  bool_ftype_ptr_ptr_luns
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, long_unsigned_type_node, 
                      endlink))));
  bool_ftype_ptr_ptr_ptr_luns
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, long_unsigned_type_node, 
                          endlink)))));
  bool_ftype_ptr_int_ptr_int
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, ptr_type_node, 
                      tree_cons (NULL_TREE, integer_type_node, 
                          endlink)))));
  bool_ftype_ptr_int_ptr_int_int
    = build_function_type (boolean_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, ptr_type_node, 
                      tree_cons (NULL_TREE, integer_type_node, 
                          tree_cons (NULL_TREE, integer_type_node, 
                                     endlink))))));
  find_bit_ftype
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, long_unsigned_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                                     endlink))));
  int_ftype_int
    = build_function_type (integer_type_node,
         tree_cons (NULL_TREE, integer_type_node, 
             endlink));
  int_ftype_int_int
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, integer_type_node,
              tree_cons (NULL_TREE, integer_type_node, 
                  endlink)));
  int_ftype_int_ptr_int
    = build_function_type (integer_type_node,
           tree_cons (NULL_TREE, integer_type_node,
               tree_cons (NULL_TREE, ptr_type_node,
                   tree_cons (NULL_TREE, integer_type_node,
                       endlink))));
  int_ftype_ptr
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node, 
              endlink));
  int_ftype_ptr_int
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node, 
              tree_cons (NULL_TREE, integer_type_node,
                  endlink)));

  long_ftype_ptr_luns
    = build_function_type (long_integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node, 
              tree_cons (NULL_TREE, long_unsigned_type_node,
                  endlink)));

  int_ftype_ptr_int_int_ptr_int
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                      tree_cons (NULL_TREE, ptr_type_node,
                          tree_cons (NULL_TREE, integer_type_node,
                              endlink))))));

  int_ftype_ptr_luns_long_ptr_int
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, long_unsigned_type_node,
                  tree_cons (NULL_TREE, long_integer_type_node,
                      tree_cons (NULL_TREE, ptr_type_node,
                          tree_cons (NULL_TREE, integer_type_node,
                              endlink))))));

  int_ftype_ptr_ptr_int
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                      endlink))));
  int_ftype_ptr_ptr_luns
    = build_function_type (integer_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, long_unsigned_type_node,
                      endlink))));
  memcpy_ftype  /* memcpy/memmove prototype */
    = build_function_type (ptr_type_node,
        tree_cons (NULL_TREE, ptr_type_node,
          tree_cons (NULL_TREE, const_ptr_type_node,
            tree_cons (NULL_TREE, sizetype,
              endlink))));
  memcmp_ftype  /* memcmp prototype */
    = build_function_type (integer_type_node,
        tree_cons (NULL_TREE, ptr_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
            tree_cons (NULL_TREE, sizetype,
              endlink)))); 

  ptr_ftype_ptr_int_int
    = build_function_type (ptr_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, integer_type_node, 
                      endlink))));
  ptr_ftype_ptr_ptr_int
    = build_function_type (ptr_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, integer_type_node, 
                      endlink))));
  ptr_ftype_ptr_ptr_int_ptr_int
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                      tree_cons (NULL_TREE, ptr_type_node,
                          tree_cons (NULL_TREE, integer_type_node,
                              endlink))))));
  real_ftype_real
    = build_function_type (float_type_node,
          tree_cons (NULL_TREE, float_type_node, 
              endlink));

  void_ftype_ptr
     = build_function_type (void_type_node,
           tree_cons (NULL_TREE, ptr_type_node, endlink));

  void_ftype_cptr_cptr_int
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, const_ptr_type_node,
              tree_cons (NULL_TREE, const_ptr_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                      endlink))));

  void_ftype_refptr_int_ptr_int
    = build_function_type (void_type_node,
              tree_cons (NULL_TREE, build_reference_type(ptr_type_node),
                tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                    tree_cons (NULL_TREE, integer_type_node,
                      endlink)))));

  void_ftype_ptr_ptr_ptr_int
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, integer_type_node,
                          endlink)))));
  void_ftype_ptr_ptr_ptr_luns
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, ptr_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, long_unsigned_type_node,
                          endlink)))));
  void_ftype_ptr_int_int_int_int
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, integer_type_node,
                      tree_cons (NULL_TREE, integer_type_node,
                        tree_cons (NULL_TREE, integer_type_node,
                          endlink))))));
  void_ftype_ptr_luns_long_long_bool_ptr_int
    = build_function_type (void_type_node,
        tree_cons (NULL_TREE, ptr_type_node,
          tree_cons (NULL_TREE, long_unsigned_type_node,
            tree_cons (NULL_TREE, long_integer_type_node,
              tree_cons (NULL_TREE, long_integer_type_node,
                tree_cons (NULL_TREE, boolean_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                    tree_cons (NULL_TREE, integer_type_node,
                      endlink))))))));
  void_ftype_ptr_int_ptr_int_int_int
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, integer_type_node,
                        tree_cons (NULL_TREE, integer_type_node,
                          tree_cons (NULL_TREE, integer_type_node,
                            endlink)))))));
  void_ftype_ptr_luns_ptr_luns_luns_luns
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, long_unsigned_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, long_unsigned_type_node,
                          tree_cons (NULL_TREE, long_unsigned_type_node,
                              tree_cons (NULL_TREE, long_unsigned_type_node,
                                  endlink)))))));
  void_ftype_ptr_int_ptr_int_ptr_int
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, integer_type_node,
                        tree_cons (NULL_TREE, ptr_type_node,
                          tree_cons (NULL_TREE, integer_type_node,
                            endlink)))))));
  void_ftype_long_int_ptr_int_ptr_int
    = build_function_type (void_type_node,
          tree_cons (NULL_TREE, long_integer_type_node,
              tree_cons (NULL_TREE, integer_type_node,
                  tree_cons (NULL_TREE, ptr_type_node,
                      tree_cons (NULL_TREE, integer_type_node,
                        tree_cons (NULL_TREE, ptr_type_node,
                          tree_cons (NULL_TREE, integer_type_node,
                            endlink)))))));
   void_ftype_void
     = build_function_type (void_type_node,
           tree_cons (NULL_TREE, void_type_node,
               endlink));

  void_ftype_ptr_ptr_int
     = build_function_type (void_type_node,
           tree_cons (NULL_TREE, ptr_type_node,
               tree_cons (NULL_TREE, ptr_type_node,
                   tree_cons (NULL_TREE, integer_type_node,
                       endlink))));

  void_ftype_ptr_luns_luns_cptr_luns_luns_luns
    = build_function_type (void_type_node,
        tree_cons (NULL_TREE, ptr_type_node,
          tree_cons (NULL_TREE, long_unsigned_type_node,
            tree_cons (NULL_TREE, long_unsigned_type_node,
              tree_cons (NULL_TREE, const_ptr_type_node,
                tree_cons (NULL_TREE, long_unsigned_type_node,
                  tree_cons (NULL_TREE, long_unsigned_type_node,
                    tree_cons (NULL_TREE, long_unsigned_type_node,
                               endlink))))))));

  ptr_ftype_luns_ptr_int
    = build_function_type (ptr_type_node,
        tree_cons (NULL_TREE, long_unsigned_type_node,
          tree_cons (NULL_TREE, ptr_type_node,
            tree_cons (NULL_TREE, integer_type_node,
                       endlink))));

  double_ftype_double
    = build_function_type (double_type_node,
        tree_cons (NULL_TREE, double_type_node,
                   endlink));

/* These are compiler-internal function calls, not intended
   to be directly called by user code */
  builtin_function ("__allocate", ptr_ftype_luns_ptr_int,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("_allocate_global_memory", void_ftype_refptr_int_ptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("_allocate_memory", void_ftype_refptr_int_ptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__andpowerset", bool_ftype_ptr_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__bitsetpowerset", void_ftype_ptr_int_int_int_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__cardpowerset", long_ftype_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__cause_ex1", void_ftype_cptr_cptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__concatstring", ptr_ftype_ptr_ptr_int_ptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__continue", void_ftype_ptr_ptr_int,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__diffpowerset", void_ftype_ptr_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__eqpowerset", bool_ftype_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__ffsetclrpowerset", find_bit_ftype,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__flsetclrpowerset", find_bit_ftype,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__flsetpowerset", int_ftype_ptr_luns_long_ptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__ffsetpowerset", int_ftype_ptr_luns_long_ptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__inbitstring", bool_ftype_luns_ptr_luns_long_ptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__inpowerset", bool_ftype_luns_ptr_luns_long, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__lepowerset", bool_ftype_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__ltpowerset", bool_ftype_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  /* Currently under experimentation.  */
  builtin_function ("memmove", memcpy_ftype,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("memcmp", memcmp_ftype,
                    NOT_BUILT_IN, NULL_PTR);

  /* this comes from c-decl.c (init_decl_processing) */
  builtin_function ("__builtin_alloca",
                    build_function_type (ptr_type_node,
                                         tree_cons (NULL_TREE,
                                                    sizetype,
                                                    endlink)),
                    BUILT_IN_ALLOCA, "alloca");

  builtin_function ("memset", ptr_ftype_ptr_int_int,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__notpowerset", bool_ftype_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__orpowerset", bool_ftype_ptr_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__psslice", void_ftype_ptr_int_ptr_int_int_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__pscpy", void_ftype_ptr_luns_luns_cptr_luns_luns_luns,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("_return_memory", void_ftype_ptr_ptr_int,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__setbitpowerset", void_ftype_ptr_luns_long_long_bool_ptr_int,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__terminate", void_ftype_ptr_ptr_int,
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__unhandled_ex", void_ftype_cptr_cptr_int, 
                    NOT_BUILT_IN, NULL_PTR);
  builtin_function ("__xorpowerset", bool_ftype_ptr_ptr_ptr_luns, 
                    NOT_BUILT_IN, NULL_PTR);

  /* declare floating point functions */
  builtin_function ("__sin", double_ftype_double, NOT_BUILT_IN, "sin");
  builtin_function ("__cos", double_ftype_double, NOT_BUILT_IN, "cos");
  builtin_function ("__tan", double_ftype_double, NOT_BUILT_IN, "tan");
  builtin_function ("__asin", double_ftype_double, NOT_BUILT_IN, "asin");
  builtin_function ("__acos", double_ftype_double, NOT_BUILT_IN, "acos");
  builtin_function ("__atan", double_ftype_double, NOT_BUILT_IN, "atan");
  builtin_function ("__exp", double_ftype_double, NOT_BUILT_IN, "exp");
  builtin_function ("__log", double_ftype_double, NOT_BUILT_IN, "log");
  builtin_function ("__log10", double_ftype_double, NOT_BUILT_IN, "log10");
  builtin_function ("__sqrt", double_ftype_double, NOT_BUILT_IN, "sqrt");

  tasking_init ();
  timing_init ();
  inout_init ();

  /* These are predefined value builtin routine calls, built
     by the compiler, but over-ridable by user procedures of
     the same names.  Note the lack of a leading underscore. */
  builtin_function ((ignore_case || ! special_UC) ?  "abs" : "ABS",
                    chill_predefined_function_type,
                    BUILT_IN_CH_ABS, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "abstime" : "ABSTIME",
                    chill_predefined_function_type,
                    BUILT_IN_ABSTIME, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "allocate" : "ALLOCATE",
                    chill_predefined_function_type,
                    BUILT_IN_ALLOCATE, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "allocate_memory" : "ALLOCATE_MEMORY",
                    chill_predefined_function_type,
                    BUILT_IN_ALLOCATE_MEMORY, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "addr" : "ADDR",
                    chill_predefined_function_type,
                    BUILT_IN_ADDR, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "allocate_global_memory" : "ALLOCATE_GLOBAL_MEMORY",
                    chill_predefined_function_type,
                    BUILT_IN_ALLOCATE_GLOBAL_MEMORY, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "arccos" : "ARCCOS",
                    chill_predefined_function_type,
                    BUILT_IN_ARCCOS, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "arcsin" : "ARCSIN",
                    chill_predefined_function_type,
                    BUILT_IN_ARCSIN, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "arctan" : "ARCTAN",
                    chill_predefined_function_type,
                    BUILT_IN_ARCTAN, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "card" : "CARD",
                    chill_predefined_function_type,
                    BUILT_IN_CARD, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "cos" : "COS",
                    chill_predefined_function_type,
                    BUILT_IN_CH_COS, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "days" : "DAYS",
                    chill_predefined_function_type,
                    BUILT_IN_DAYS, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "descr" : "DESCR",
                    chill_predefined_function_type,
                    BUILT_IN_DESCR, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "getstack" : "GETSTACK",
                    chill_predefined_function_type,
                    BUILT_IN_GETSTACK, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "exp" : "EXP",
                    chill_predefined_function_type,
                    BUILT_IN_EXP, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "hours" : "HOURS",
                    chill_predefined_function_type,
                    BUILT_IN_HOURS, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "inttime" : "INTTIME",
                    chill_predefined_function_type,
                    BUILT_IN_INTTIME, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "length" : "LENGTH",
                    chill_predefined_function_type,
                    BUILT_IN_LENGTH, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "log" : "LOG",
                    chill_predefined_function_type,
                    BUILT_IN_LOG, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "lower" : "LOWER",
                    chill_predefined_function_type,
                    BUILT_IN_LOWER, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "ln" : "LN",
                    chill_predefined_function_type,
                    BUILT_IN_LN, NULL_PTR);
  /* Note: these are *not* the C integer MAX and MIN.  They're
     for powerset arguments. */
  builtin_function ((ignore_case || ! special_UC) ?  "max" : "MAX",
                    chill_predefined_function_type,
                    BUILT_IN_MAX, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "millisecs" : "MILLISECS",
                    chill_predefined_function_type,
                    BUILT_IN_MILLISECS, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "min" : "MIN",
                    chill_predefined_function_type,
                    BUILT_IN_MIN, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "minutes" : "MINUTES",
                    chill_predefined_function_type,
                    BUILT_IN_MINUTES, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "num" : "NUM",
                    chill_predefined_function_type,
                    BUILT_IN_NUM, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "pred" : "PRED",
                    chill_predefined_function_type,
                    BUILT_IN_PRED, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "return_memory" : "RETURN_MEMORY",
                    chill_predefined_function_type,
                    BUILT_IN_RETURN_MEMORY, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "secs" : "SECS",
                    chill_predefined_function_type,
                    BUILT_IN_SECS, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "sin" : "SIN",
                    chill_predefined_function_type,
                    BUILT_IN_CH_SIN, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "size" : "SIZE",
                    chill_predefined_function_type,
                    BUILT_IN_SIZE, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "sqrt" : "SQRT",
                    chill_predefined_function_type,
                    BUILT_IN_SQRT, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "succ" : "SUCC",
                    chill_predefined_function_type,
                    BUILT_IN_SUCC, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "tan" : "TAN",
                    chill_predefined_function_type,
                    BUILT_IN_TAN, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ? "terminate" : "TERMINATE",
                    chill_predefined_function_type,
                    BUILT_IN_TERMINATE, NULL_PTR);
  builtin_function ((ignore_case || ! special_UC) ?  "upper" : "UPPER",
                    chill_predefined_function_type,
                    BUILT_IN_UPPER, NULL_PTR);

  build_chill_descr_type ();
  build_chill_inttime_type ();
  
  endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);

  start_identifier_warnings ();

  pass = 1;
}
\f
/* Return a definition for a builtin function named NAME and whose data type
   is TYPE.  TYPE should be a function type with argument types.
   FUNCTION_CODE tells later passes how to compile calls to this function.
   See tree.h for its possible values.

   If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
   the name to be called if we can't opencode the function.  */

tree
builtin_function (name, type, function_code, library_name)
     char *name;
     tree type;
     enum built_in_function function_code;
     char *library_name;
{
  tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
  DECL_EXTERNAL (decl) = 1;
  TREE_PUBLIC (decl) = 1;
  /* If -traditional, permit redefining a builtin function any way you like.
     (Though really, if the program redefines these functions,
     it probably won't work right unless compiled with -fno-builtin.)  */
  if (flag_traditional && name[0] != '_')
    DECL_BUILT_IN_NONANSI (decl) = 1;
  if (library_name)
    DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
  make_decl_rtl (decl, NULL_PTR, 1);
  pushdecl (decl);
  if (function_code != NOT_BUILT_IN)
    {
      DECL_BUILT_IN (decl) = 1;
      DECL_SET_FUNCTION_CODE (decl, function_code);
    }

  return decl;
}
\f
/* Print a warning if a constant expression had overflow in folding.
   Invoke this function on every expression that the language
   requires to be a constant expression. */

void
constant_expression_warning (value)
     tree value;
{
  if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST
       || TREE_CODE (value) == COMPLEX_CST)
      && TREE_CONSTANT_OVERFLOW (value) && pedantic)
    pedwarn ("overflow in constant expression");
}

\f
/* Finish processing of a declaration;
   If the length of an array type is not known before,
   it must be determined now, from the initial value, or it is an error.  */

void
finish_decl (decl)
     tree decl;
{
  int was_incomplete = (DECL_SIZE (decl) == 0);
  int temporary = allocation_temporary_p ();

  /* 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 ();
#if 0 /* pop_obstacks was near the end; this is what was here.  */
  if (current_scope == global_scope && temporary)
    end_temporary_allocation ();
#endif

  if (TREE_CODE (decl) == VAR_DECL)
    {
      if (DECL_SIZE (decl) == 0
          && TYPE_SIZE (TREE_TYPE (decl)) != 0)
        layout_decl (decl, 0);

      if (DECL_SIZE (decl) == 0 && TREE_CODE (TREE_TYPE (decl)) != ERROR_MARK)
        {
          error_with_decl (decl, "storage size of `%s' isn't known");
          TREE_TYPE (decl) = error_mark_node;
        }

      if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
          && DECL_SIZE (decl) != 0)
        {
          if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST)
            constant_expression_warning (DECL_SIZE (decl));
        }
    }

  /* Output the assembler code and/or RTL code for variables and functions,
     unless the type is an undefined structure or union.
     If not, it will get done when the type is completed.  */

  if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
    {
      /* The last argument (at_end) is set to 1 as a kludge to force
         assemble_variable to be called. */
      if (TREE_CODE (TREE_TYPE (decl)) != ERROR_MARK)
        rest_of_decl_compilation (decl, (char*) 0, global_bindings_p (), 1);

      /* Compute the RTL of a decl if not yet set.
         (For normal user variables, satisfy_decl sets it.) */
      if (! TREE_STATIC (decl) && ! DECL_EXTERNAL (decl))
        {
          if (was_incomplete)
            {
              /* If we used it already as memory, it must stay in memory.  */
              TREE_ADDRESSABLE (decl) = TREE_USED (decl);
              /* If it's still incomplete now, no init will save it.  */
              if (DECL_SIZE (decl) == 0)
                DECL_INITIAL (decl) = 0;
              expand_decl (decl);
            }
        }
    }

  if (TREE_CODE (decl) == TYPE_DECL)
    {
      rest_of_decl_compilation (decl, NULL_PTR,
                                global_bindings_p (), 0);
    }

  /* ??? After 2.3, test (init != 0) instead of TREE_CODE.  */
  if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
      && temporary && TREE_PERMANENT (decl))
    {
      /* We need to remember that this array HAD an initialization,
         but discard the actual temporary nodes,
         since we can't have a permanent node keep pointing to them.  */
      /* We make an exception for inline functions, since it's
         normal for a local extern redeclaration of an inline function
         to have a copy of the top-level decl's DECL_INLINE.  */
      if (DECL_INITIAL (decl) != 0)
        DECL_INITIAL (decl) = error_mark_node;
    }

#if 0
  /* Resume permanent allocation, if not within a function.  */
  /* The corresponding push_obstacks_nochange is in start_decl,
     and in push_parm_decl and in grokfield.  */
  pop_obstacks ();
#endif

  /* If we have gone back from temporary to permanent allocation,
     actually free the temporary space that we no longer need.  */
  if (temporary && !allocation_temporary_p ())
    permanent_allocation (0);

  /* At the end of a declaration, throw away any variable type sizes
     of types defined inside that declaration.  There is no use
     computing them in the following function definition.  */
  if (current_scope == global_scope)
    get_pending_sizes ();
}

/* If DECL has a cleanup, build and return that cleanup here.
   This is a callback called by expand_expr.  */

tree
maybe_build_cleanup (decl)
     tree decl ATTRIBUTE_UNUSED;
{
  /* There are no cleanups in C.  */
  return NULL_TREE;
}
\f
/* Make TYPE a complete type based on INITIAL_VALUE.
   Return 0 if successful, 1 if INITIAL_VALUE can't be deciphered,
   2 if there was no information (in which case assume 1 if DO_DEFAULT).  */

int
complete_array_type (type, initial_value, do_default)
     tree type ATTRIBUTE_UNUSED, initial_value ATTRIBUTE_UNUSED;
     int do_default ATTRIBUTE_UNUSED;
{
  /* Only needed so we can link with ../c-typeck.c. */
  abort ();
}
\f
/* Make sure that the tag NAME is defined *in the current binding level*
   at least as a forward reference.
   CODE says which kind of tag NAME ought to be.

   We also do a push_obstacks_nochange
   whose matching pop is in finish_struct.  */

tree
start_struct (code, name)
     enum chill_tree_code code;
     tree name ATTRIBUTE_UNUSED;
{
  /* If there is already a tag defined at this binding level
     (as a forward reference), just return it.  */

  register tree ref = 0;

  push_obstacks_nochange ();
  if (current_scope == global_scope)
    end_temporary_allocation ();

  /* Otherwise create a forward-reference just so the tag is in scope.  */

  ref = make_node (code);
/*  pushtag (name, ref); */
  return ref;
}
\f
#if 0
/* Function to help qsort sort FIELD_DECLs by name order.  */

static int
field_decl_cmp (x, y)
     tree *x, *y;
{
  return (long)DECL_NAME (*x) - (long)DECL_NAME (*y);
}
#endif
/* Fill in the fields of a RECORD_TYPE or UNION_TYPE node, T.
   FIELDLIST is a chain of FIELD_DECL nodes for the fields.

   We also do a pop_obstacks to match the push in start_struct.  */

tree
finish_struct (t, fieldlist)
     register tree t, fieldlist;
{
  register tree x;

  /* Install struct as DECL_CONTEXT of each field decl.
     Also process specified field sizes.
     Set DECL_FIELD_SIZE to the specified size, or 0 if none specified.
     The specified size is found in the DECL_INITIAL.
     Store 0 there, except for ": 0" fields (so we can find them
     and delete them, below).  */

  for (x = fieldlist; x; x = TREE_CHAIN (x))
    {
      DECL_CONTEXT (x) = t;
      DECL_FIELD_SIZE (x) = 0;
    }

  TYPE_FIELDS (t) = fieldlist;

  if (pass != 1)
    t = layout_chill_struct_type (t);

  /* The matching push is in start_struct.  */
  pop_obstacks ();

  return t;
}

/* Lay out the type T, and its element type, and so on.  */

static void
layout_array_type (t)
     tree t;
{
  if (TYPE_SIZE (t) != 0)
    return;
  if (TREE_CODE (TREE_TYPE (t)) == ARRAY_TYPE)
    layout_array_type (TREE_TYPE (t));
  layout_type (t);
}
\f
/* Begin compiling the definition of an enumeration type.
   NAME is its name (or null if anonymous).
   Returns the type object, as yet incomplete.
   Also records info about it so that build_enumerator
   may be used to declare the individual values as they are read.  */

tree
start_enum (name)
     tree name ATTRIBUTE_UNUSED;
{
  register tree enumtype;

  /* If this is the real definition for a previous forward reference,
     fill in the contents in the same object that used to be the
     forward reference.  */

#if 0
  /* The corresponding pop_obstacks is in finish_enum.  */
  push_obstacks_nochange ();
  /* If these symbols and types are global, make them permanent.  */
  if (current_scope == global_scope)
    end_temporary_allocation ();
#endif

  enumtype = make_node (ENUMERAL_TYPE);
/*  pushtag (name, enumtype); */
  return enumtype;
}
\f
/* Determine the precision this type needs.  */
unsigned
get_type_precision (minnode, maxnode)
     tree minnode, maxnode;
{
  unsigned precision = 0;

  if (TREE_INT_CST_HIGH (minnode) >= 0
      ? tree_int_cst_lt (TYPE_MAX_VALUE (unsigned_type_node), maxnode)
      : (tree_int_cst_lt (minnode, TYPE_MIN_VALUE (integer_type_node))
         || tree_int_cst_lt (TYPE_MAX_VALUE (integer_type_node), maxnode)))
    precision = TYPE_PRECISION (long_long_integer_type_node);
  else
    {
      HOST_WIDE_INT maxvalue = TREE_INT_CST_LOW (maxnode);
      HOST_WIDE_INT minvalue = TREE_INT_CST_LOW (minnode);

      if (maxvalue > 0)
        precision = floor_log2 (maxvalue) + 1;
      if (minvalue < 0)
        {
          /* Compute number of bits to represent magnitude of a negative value.
             Add one to MINVALUE since range of negative numbers
             includes the power of two.  */
          unsigned negprecision = floor_log2 (-minvalue - 1) + 1;
          if (negprecision > precision)
            precision = negprecision;
          precision += 1;       /* room for sign bit */
        }

      if (!precision)
        precision = 1;
    }
  return precision;
}
\f
void
layout_enum (enumtype)
     tree enumtype;
{
  register tree pair, tem;
  tree minnode = 0, maxnode = 0;
  unsigned precision = 0;

  /* Do arithmetic using double integers, but don't use fold/build. */
  union tree_node enum_next_node;
  /* This is 1 plus the last enumerator constant value.  */
  tree enum_next_value = &enum_next_node;

  /* Nonzero means that there was overflow computing enum_next_value.  */
  int enum_overflow = 0;

  tree values = TYPE_VALUES (enumtype);

  if (TYPE_SIZE (enumtype) != NULL_TREE)
    return;

  /* Initialize enum_next_value to zero. */
  TREE_TYPE (enum_next_value) = integer_type_node;
  TREE_INT_CST_LOW (enum_next_value) = TREE_INT_CST_LOW (integer_zero_node);
  TREE_INT_CST_HIGH (enum_next_value) = TREE_INT_CST_HIGH (integer_zero_node);

  /* After processing and defining all the values of an enumeration type,
     install their decls in the enumeration type and finish it off.

     TYPE_VALUES currently contains a list of (purpose: NAME, value: DECL).
     This gets converted to a list of (purpose: NAME, value: VALUE). */


  /* For each enumerator, calculate values, if defaulted.
     Convert to correct type (the enumtype).
     Also, calculate the minimum and maximum values.  */

  for (pair = values; pair; pair = TREE_CHAIN (pair))
    {
      tree decl = TREE_VALUE (pair);
      tree value = DECL_INITIAL (decl);

      /* Remove no-op casts from the value.  */
      if (value != NULL_TREE)
        STRIP_TYPE_NOPS (value);

      if (value != NULL_TREE)
        {
          if (TREE_CODE (value) == INTEGER_CST)
            {
              constant_expression_warning (value);
              if (tree_int_cst_lt (value, integer_zero_node))
                {
                  error ("enumerator value for `%s' is less then 0",
                         IDENTIFIER_POINTER (DECL_NAME (decl)));
                  value = error_mark_node;
                }
            }
          else
            {
              error ("enumerator value for `%s' not integer constant",
                     IDENTIFIER_POINTER (DECL_NAME (decl)));
              value = error_mark_node;
            }
        }

      if (value != error_mark_node)
        {
          if (value == NULL_TREE) /* Default based on previous value.  */
            {
              value = enum_next_value;
              if (enum_overflow)
                error ("overflow in enumeration values");
            }
          value = build_int_2 (TREE_INT_CST_LOW (value),
                               TREE_INT_CST_HIGH (value));
          TREE_TYPE (value) = enumtype;
          DECL_INITIAL (decl) = value;
          CH_DERIVED_FLAG (value) = 1;
      
          if (pair == values)
            minnode = maxnode = value;
          else
            {
              if (tree_int_cst_lt (maxnode, value))
                maxnode = value;
              if (tree_int_cst_lt (value, minnode))
                minnode = value;
            }

          /* Set basis for default for next value.  */
          add_double (TREE_INT_CST_LOW (value), TREE_INT_CST_HIGH (value), 1, 0,
                      &TREE_INT_CST_LOW (enum_next_value),
                      &TREE_INT_CST_HIGH (enum_next_value));
          enum_overflow = tree_int_cst_lt (enum_next_value, value);
        }
      else
        DECL_INITIAL (decl) = value; /* error_mark_node */
    }

  /* Fix all error_mark_nodes in enum. Increment maxnode and assign value.
     This is neccessary to make a duplicate value check in the enum */
  for (pair = values; pair; pair = TREE_CHAIN (pair))
    {
      tree decl = TREE_VALUE (pair);
      if (DECL_INITIAL (decl) == error_mark_node)
        {
          tree value;
          add_double (TREE_INT_CST_LOW (maxnode), TREE_INT_CST_HIGH (maxnode), 1, 0,
                      &TREE_INT_CST_LOW (enum_next_value),
                      &TREE_INT_CST_HIGH (enum_next_value));
          value = build_int_2 (TREE_INT_CST_LOW (enum_next_value),
                               TREE_INT_CST_HIGH (enum_next_value));
          TREE_TYPE (value) = enumtype;
          CH_DERIVED_FLAG (value) = 1;
          DECL_INITIAL (decl) = value;

          maxnode = value;
        }
    }

  /* Now check if we have duplicate values within the enum */
  for (pair = values; pair; pair = TREE_CHAIN (pair))
    {
      tree succ;
      tree decl1 = TREE_VALUE (pair);
      tree val1 = DECL_INITIAL (decl1);

      for (succ = TREE_CHAIN (pair); succ; succ = TREE_CHAIN (succ))
        {
          if (pair != succ)
            {
              tree decl2 = TREE_VALUE (succ);
              tree val2 = DECL_INITIAL (decl2);
              if (tree_int_cst_equal (val1, val2))
                error ("enumerators `%s' and `%s' have equal values",
                       IDENTIFIER_POINTER (DECL_NAME (decl1)),
                       IDENTIFIER_POINTER (DECL_NAME (decl2)));
            }
        }
    }

  TYPE_MIN_VALUE (enumtype) = minnode;
  TYPE_MAX_VALUE (enumtype) = maxnode;

  precision = get_type_precision (minnode, maxnode);

  if (flag_short_enums || precision > TYPE_PRECISION (integer_type_node))
    /* Use the width of the narrowest normal C type which is wide enough.  */
    TYPE_PRECISION (enumtype) = TYPE_PRECISION (type_for_size (precision, 1));
  else
    TYPE_PRECISION (enumtype) = TYPE_PRECISION (integer_type_node);

  layout_type (enumtype);

#if 0
  /* An enum can have some negative values; then it is signed.  */
  TREE_UNSIGNED (enumtype) = ! tree_int_cst_lt (minnode, integer_zero_node);
#else
  /* Z200/1988 page 19 says:
     For each pair of integer literal expression e1, e2 in the set list NUM (e1)
     and NUM (e2) must deliver different non-negative results */
  TREE_UNSIGNED (enumtype) = 1;
#endif

  for (pair = values; pair; pair = TREE_CHAIN (pair))
    {
      tree decl = TREE_VALUE (pair);
      DECL_SIZE (decl) = TYPE_SIZE (enumtype);
      DECL_ALIGN (decl) = TYPE_ALIGN (enumtype);

      /* Set the TREE_VALUE to the name, rather than the decl,
         since that is what the rest of the compiler expects. */
      TREE_VALUE (pair) = DECL_INITIAL (decl);
    }

  /* Fix up all variant types of this enum type.  */
  for (tem = TYPE_MAIN_VARIANT (enumtype); tem; tem = TYPE_NEXT_VARIANT (tem))
    {
      TYPE_VALUES (tem) = TYPE_VALUES (enumtype);
      TYPE_MIN_VALUE (tem) = TYPE_MIN_VALUE (enumtype);
      TYPE_MAX_VALUE (tem) = TYPE_MAX_VALUE (enumtype);
      TYPE_SIZE (tem) = TYPE_SIZE (enumtype);
      TYPE_MODE (tem) = TYPE_MODE (enumtype);
      TYPE_PRECISION (tem) = TYPE_PRECISION (enumtype);
      TYPE_ALIGN (tem) = TYPE_ALIGN (enumtype);
      TREE_UNSIGNED (tem) = TREE_UNSIGNED (enumtype);
    }

#if 0
  /* This matches a push in start_enum.  */
  pop_obstacks ();
#endif
}
\f
tree
finish_enum (enumtype, values)
     register tree enumtype, values;
{
  TYPE_VALUES (enumtype) = values = nreverse (values);

  /* If satisfy_decl is called on one of the enum CONST_DECLs,
     this will make sure that the enumtype gets laid out then. */
  for ( ; values; values = TREE_CHAIN (values))
    TREE_TYPE (TREE_VALUE (values)) = enumtype;

  return enumtype;
}


/* Build and install a CONST_DECL for one value of the
   current enumeration type (one that was begun with start_enum).
   Return a tree-list containing the CONST_DECL and its value.
   Assignment of sequential values by default is handled here.  */

tree
build_enumerator (name, value)
     tree name, value;
{
  register tree decl;
  int named = name != NULL_TREE;

  if (pass == 2)
    {
      if (name)
        (void) get_next_decl ();
      return NULL_TREE;
    }

  if (name == NULL_TREE)
    {
      static int unnamed_value_warned = 0;
      static int next_dummy_enum_value = 0;
      char buf[20];
      if (!unnamed_value_warned)
        {
          unnamed_value_warned = 1;
          warning ("undefined value in SET mode is obsolete and deprecated.");
        }
      sprintf (buf, "__star_%d", next_dummy_enum_value++);
      name = get_identifier (buf);
    }

  decl = build_decl (CONST_DECL, name, integer_type_node);
  CH_DECL_ENUM (decl) = 1;
  DECL_INITIAL (decl) = value;
  if (named)
    {
      if (pass == 0)
        {
          push_obstacks_nochange ();
          pushdecl (decl);
          finish_decl (decl);
        }
      else
        save_decl (decl);
    }
  return build_tree_list (name, decl);

#if 0
  tree old_value = lookup_name_current_level (name);

  if (old_value != NULL_TREE
      && TREE_CODE (old_value)=!= CONST_DECL
      && (value == NULL_TREE || operand_equal_p (value, old_value, 1)))
    {
      if (value == NULL_TREE)
        {
          if (TREE_CODE (old_value) == CONST_DECL)
            value = DECL_INITIAL (old_value);
          else
            abort ();
        }
      return saveable_tree_cons (old_value, value, NULL_TREE);
    }
#endif
}
\f
/* Record that this function is going to be a varargs function.
   This is called before store_parm_decls, which is too early
   to call mark_varargs directly.  */

void
c_mark_varargs ()
{
  c_function_varargs = 1;
}
\f
/* Function needed for CHILL interface.  */
tree
get_parm_decls ()
{
  return current_function_parms;
}
\f
/* Save and restore the variables in this file and elsewhere
   that keep track of the progress of compilation of the current function.
   Used for nested functions.  */

struct c_function
{
  struct c_function *next;
  struct scope *scope;
  tree chill_result_decl;
  int result_never_set;
};

struct c_function *c_function_chain;

/* Save and reinitialize the variables
   used during compilation of a C function.  */

void
push_chill_function_context ()
{
  struct c_function *p
    = (struct c_function *) xmalloc (sizeof (struct c_function));

  push_function_context ();

  p->next = c_function_chain;
  c_function_chain = p;

  p->scope = current_scope;
  p->chill_result_decl = chill_result_decl;
  p->result_never_set = result_never_set;
}

/* Restore the variables used during compilation of a C function.  */

void
pop_chill_function_context ()
{
  struct c_function *p = c_function_chain;
#if 0
  tree link;
  /* Bring back all the labels that were shadowed.  */
  for (link = shadowed_labels; link; link = TREE_CHAIN (link))
    if (DECL_NAME (TREE_VALUE (link)) != 0)
      IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
        = TREE_VALUE (link);
#endif

  pop_function_context ();

  c_function_chain = p->next;

  current_scope = p->scope;
  chill_result_decl = p->chill_result_decl;
  result_never_set = p->result_never_set;

  free (p);
}
\f
/* Following from Jukka Virtanen's GNU Pascal */
/* To implement WITH statement:

   1) Call shadow_record_fields for each record_type element in the WITH
      element list. Each call creates a new binding level.
   
   2) construct a component_ref for EACH field in the record,
      and store it to the IDENTIFIER_LOCAL_VALUE after adding
      the old value to the shadow list

   3) let lookup_name do the rest

   4) pop all of the binding levels after the WITH statement ends.
      (restoring old local values) You have to keep track of the number
      of times you called it.
*/
\f
/*
 * Save an arbitrary tree-expression as the IDENTIFIER_LOCAL_VALUE
 * of a name.  Save the name's previous value.  Check for name 
 * collisions with another value under the same name at the same
 * nesting level.  This is used to implement the DO WITH construct
 * and the temporary for the location iteration loop.
 */
void
save_expr_under_name (name, expr)
     tree name, expr;
{
  tree alias = build_alias_decl (NULL_TREE, NULL_TREE, name);

  DECL_ABSTRACT_ORIGIN (alias) = expr;
  TREE_CHAIN (alias) = NULL_TREE;
  pushdecllist (alias, 0);
}

void
do_based_decl (name, mode, base_var)
     tree name, mode, base_var;
{
  tree decl;
  if (pass == 1)
    {
      push_obstacks (&permanent_obstack, &permanent_obstack);
      decl = make_node (BASED_DECL);
      DECL_NAME (decl) = name;
      TREE_TYPE (decl) = mode;
      DECL_ABSTRACT_ORIGIN (decl) = base_var;
      save_decl (decl);
      pop_obstacks ();
    }
  else
    {
      tree base_decl;
      decl = get_next_decl ();
      if (name != DECL_NAME (decl))
        abort();
      /* FIXME: This isn't a complete test */
      base_decl = lookup_name (base_var);
      if (base_decl == NULL_TREE)
        error ("BASE variable never declared");
      else if (TREE_CODE (base_decl) == FUNCTION_DECL)
        error ("cannot BASE a variable on a PROC/PROCESS name");
    }
}

void
do_based_decls (names, mode, base_var)
     tree names, mode, base_var;
{
  if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
    {
      for (; names != NULL_TREE; names = TREE_CHAIN (names))
        do_based_decl (names, mode, base_var);
    }
  else if (TREE_CODE (names) != ERROR_MARK)
    do_based_decl (names, mode, base_var);
}

/*
 * Declare the fields so that lookup_name() will find them as
 * component refs for Pascal WITH or CHILL DO WITH.
 *
 * Proceeds to the inner layers of Pascal/CHILL variant record
 *
 * Internal routine of shadow_record_fields ()
 */
static void
handle_one_level (parent, fields)
     tree parent, fields;
{
  tree field, name;

  switch (TREE_CODE (TREE_TYPE (parent))) 
    {
    case RECORD_TYPE:
    case UNION_TYPE:
      for (field = fields; field; field = TREE_CHAIN (field)) {
        name = DECL_NAME (field);
        if (name == NULL_TREE || name == ELSE_VARIANT_NAME)
          /* proceed through variant part */
          handle_one_level (parent, TYPE_FIELDS (TREE_TYPE (field)));
        else 
          {
            tree field_alias = make_node (WITH_DECL);
            DECL_NAME (field_alias) = name;
            TREE_TYPE (field_alias) = TREE_TYPE (field);
            DECL_ABSTRACT_ORIGIN (field_alias) = parent;
            TREE_CHAIN (field_alias) = NULL_TREE;
            pushdecllist (field_alias, 0);
          }
      }
      break;
    default:
      error ("INTERNAL ERROR: handle_one_level is broken");
    }
}
\f
/*
 * For each FIELD_DECL node in a RECORD_TYPE, we have to declare
 * a name so that lookup_name will find a COMPONENT_REF node
 * when the name is referenced. This happens in Pascal WITH statement.
 */
void
shadow_record_fields (struct_val)
     tree struct_val;
{
    if (pass == 1 || struct_val == NULL_TREE)
      return;

    handle_one_level (struct_val, TYPE_FIELDS (TREE_TYPE (struct_val)));
}
\f
static char exception_prefix [] = "__Ex_";

tree
build_chill_exception_decl (name)
     char *name;
{
  tree decl, ex_name, ex_init, ex_type;
  int  name_len = strlen (name);
  char *ex_string = (char *)
          alloca (strlen (exception_prefix) + name_len + 1);

  sprintf(ex_string, "%s%s", exception_prefix, name);
  ex_name = get_identifier (ex_string);
  decl = IDENTIFIER_LOCAL_VALUE (ex_name);
  if (decl)
    return decl;

  /* finish_decl is too eager about switching back to the
     ambient context.  This decl's rtl must live in the permanent_obstack.  */
  push_obstacks (&permanent_obstack, &permanent_obstack);
  push_obstacks_nochange ();
  ex_type = build_array_type (char_type_node,
                              build_index_2_type (integer_zero_node,
                                                  build_int_2 (name_len, 0)));
  decl = build_lang_decl (VAR_DECL, ex_name, ex_type);
  ex_init = build_string (name_len, name);
  TREE_TYPE (ex_init) = ex_type;
  DECL_INITIAL (decl) = ex_init;
  TREE_READONLY (decl) = 1;
  TREE_STATIC (decl) = 1;
  pushdecl_top_level (decl);
  finish_decl (decl);
  pop_obstacks ();              /* Return to the ambient context.  */
  return decl;
}

extern tree      module_init_list;

/*
 * This function is called from the parser to preface the entire
 * compilation.  It contains module-level actions and reach-bound
 * initialization.
 */
void
start_outer_function ()
{
  start_chill_function (pass < 2 ? get_identifier ("_GLOBAL_")
                        : DECL_NAME (global_function_decl),
                        void_type_node, NULL_TREE, NULL_TREE, NULL_TREE);
  global_function_decl = current_function_decl;
  global_scope = current_scope;
  chill_at_module_level = 1;
}
\f
/* This function finishes the global_function_decl, and if it is non-empty
 * (as indiacted by seen_action), adds it to module_init_list.
 */
void
finish_outer_function ()
{
  /* If there was module-level code in this module (not just function
     declarations), we allocate space for this module's init list entry,
     and fill in the module's function's address. */

  extern tree initializer_type;
  char *fname_str = IDENTIFIER_POINTER (DECL_NAME (current_function_decl));
  char *init_entry_name = (char *)xmalloc ((unsigned)(strlen (fname_str) + 20));
  tree  init_entry_id;
  tree  init_entry_decl;
  tree  initializer;
      
  finish_chill_function ();

  chill_at_module_level = 0;


  if (!seen_action)
    return;

  sprintf (init_entry_name, "__tmp_%s_init_entry",  fname_str);
  init_entry_id = get_identifier (init_entry_name);

  init_entry_decl = build1 (ADDR_EXPR,
                            TREE_TYPE (TYPE_FIELDS (initializer_type)),
                            global_function_decl);
  TREE_CONSTANT (init_entry_decl) = 1;
  initializer = build (CONSTRUCTOR, initializer_type, NULL_TREE,
                       tree_cons (NULL_TREE, init_entry_decl,
                                  build_tree_list (NULL_TREE,
                                                   null_pointer_node)));
  TREE_CONSTANT (initializer) = 1;
  init_entry_decl
    = do_decl (init_entry_id, initializer_type, 1, 1, initializer, 0);
  DECL_SOURCE_LINE (init_entry_decl) = 0;
  if (pass == 1)
    /* tell chill_finish_compile that there's 
       module-level code to be processed. */
    module_init_list = integer_one_node;
  else if (build_constructor)
    module_init_list = tree_cons (global_function_decl,
                                  init_entry_decl,
                                  module_init_list);

  make_decl_rtl (global_function_decl, NULL, 0);
}