Copyright fixes.

[gcc.git] / gcc / ch / parse.c

/* Parser for GNU CHILL (CCITT High-Level Language)  -*- C -*-
   Copyright (C) 1992, 1993 Free Software Foundation, Inc.

This file is part of GNU CC.

GNU CC is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU CC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU CC; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */          

/*
 * This is a two-pass parser.  In pass 1, we collect declarations,
 * ignoring actions and most expressions.  We store only the
 * declarations and close, open and re-lex the input file to save
 * main memory.  We anticipate that the compiler will be processing
 * *very* large single programs which are mechanically generated,
 * and so we want to store a minimum of information between passes.
 *
 * yylex detects the end of the main input file and returns the
 * END_PASS_1 token.  We then re-initialize each CHILL compiler 
 * module's global variables and re-process the input file. The 
 * grant file is output.  If the user has requested it, GNU CHILL 
 * exits at this time - its only purpose was to generate the grant
 * file. Optionally, the compiler may exit if errors were detected 
 * in pass 1.
 *
 * As each symbol scope is entered, we install its declarations into
 * the symbol table. Undeclared types and variables are announced
 * now.
 *
 * Then code is generated.
 */

#include "config.h"
#include "system.h"
#include "tree.h"
#include "ch-tree.h"
#include "lex.h"
#include "actions.h"
#include "tasking.h"
#include "parse.h"
#include "toplev.h"

/* Since parsers are distinct for each language, put the 
   language string definition here.  (fnf) */
char *language_string = "GNU CHILL";

/* Common code to be done before expanding any action. */
#define INIT_ACTION { \
	if (! ignoring) emit_line_note (input_filename, lineno); }

/* Pop a scope for an ON handler. */
#define POP_USED_ON_CONTEXT pop_handler(1)

/* Pop a scope for an ON handler that wasn't there. */
#define POP_UNUSED_ON_CONTEXT pop_handler(0)

#define PUSH_ACTION push_action()

/* Cause the `yydebug' variable to be defined.  */
#define YYDEBUG 1

extern struct rtx_def* gen_label_rtx	      PROTO((void));
extern void emit_jump                         PROTO((struct rtx_def *));
extern struct rtx_def* emit_label             PROTO((struct rtx_def *));

static int parse_action				PROTO((void));

extern int  lineno;
extern char *input_filename;
extern tree generic_signal_type_node;
extern tree signal_code;
extern int all_static_flag;
extern int ignore_case;
     
#if 0
static int  quasi_signal = 0;  /* 1 if processing a quasi signal decl */
#endif

int parsing_newmode;                       /* 0 while parsing SYNMODE; 
					      1 while parsing NEWMODE. */
int expand_exit_needed = 0;

/* Gets incremented if we see errors such that we don't want to run pass 2. */

int serious_errors = 0;

static tree current_fieldlist;

/* We don't care about expressions during pass 1, except while we're
   parsing the RHS of a SYN definition, or while parsing a mode that
   we need.  NOTE:  This also causes mode expressions to be ignored. */
int  ignoring = 1;              /* 1 to ignore expressions */

/* True if we have seen an action not in a (user) function. */
int seen_action = 0;
int build_constructor = 0;

/* The action_nesting_level of the current procedure body. */ 
int proc_action_level = 0;

/* This is the identifier of the label that prefixes the current action,
   or NULL if there was none.  It is cleared at the end of an action,
   or when starting a nested action list, so get it while you can! */
static tree label      = NULL_TREE;        /* for statement labels */

#if 0
static tree current_block;
#endif

int in_pseudo_module = 0;
int pass = 0;                           /* 0 for init_decl_processing,
					   1 for pass 1, 2 for pass 2 */
\f
/* re-initialize global variables for pass 2 */
static void
ch_parse_init ()
{
  expand_exit_needed = 0;
  label = NULL_TREE;             /* for statement labels */
  current_module = NULL;
  in_pseudo_module = 0;
}

static void
check_end_label (start, end)
     tree start, end;
{
  if (end != NULL_TREE)
    {
      if (start == NULL_TREE && pass == 1)
	error ("there was no start label to match the end label '%s'",
	       IDENTIFIER_POINTER(end));
      else if (start != end && pass == 1)
	error ("start label '%s' does not match end label '%s'",
	       IDENTIFIER_POINTER(start),
	       IDENTIFIER_POINTER(end));
    }
}


/*
 * given a tree which is an id, a type or a decl, 
 * return the associated type, or issue an error and
 * return error_mark_node.
 */
tree
get_type_of (id_or_decl)
     tree id_or_decl;
{
  tree type = id_or_decl;

  if (id_or_decl == NULL_TREE
      || TREE_CODE (id_or_decl) == ERROR_MARK)
    return error_mark_node;

  if (pass == 1 || ignoring == 1)
    return id_or_decl;

  if (TREE_CODE (type) == IDENTIFIER_NODE)
    {
      type = lookup_name (id_or_decl);
      if (type == NULL_TREE)
	{
	  error ("`%s' not declared", IDENTIFIER_POINTER (id_or_decl));
	  type = error_mark_node;
	}
    }
  if (TREE_CODE (type) == TYPE_DECL)
    type = TREE_TYPE (type);
  return type;           /* was a type all along */
}


static void
end_function ()
{
  if (CH_DECL_PROCESS (current_function_decl))
    { 
      /* finishing a process */
      if (! ignoring)
	{
	  tree result = 
	    build_chill_function_call
	      (lookup_name (get_identifier ("__stop_process")),
	       NULL_TREE);
	  expand_expr_stmt (result);
	  emit_line_note (input_filename, lineno);
	}
    }
  else
    {
      /* finishing a procedure.. */
      if (! ignoring)
	{
	  if (result_never_set
	      && TREE_CODE (TREE_TYPE (TREE_TYPE (current_function_decl)))
	      != VOID_TYPE)
	    warning ("No RETURN or RESULT in procedure");
	  chill_expand_return (NULL_TREE, 1);
	}
    }
  finish_chill_function ();
  pop_chill_function_context (); 
}

static tree
build_prefix_clause (id)
     tree id;
{
  if (!id)
    {
      if (current_module && current_module->name)
	{ char *module_name = IDENTIFIER_POINTER (current_module->name);
	  if (module_name[0] && module_name[0] != '_')
	    return current_module->name;
	}
      error ("PREFIXED clause with no prelix in unlabeled module");
    }
  return id;
}

void
possibly_define_exit_label (label)
     tree label;
{
  if (label)
    define_label (input_filename, lineno, munge_exit_label (label));
}

#define MAX_LOOK_AHEAD 2
static enum terminal terminal_buffer[MAX_LOOK_AHEAD+1];
YYSTYPE yylval;
static YYSTYPE val_buffer[MAX_LOOK_AHEAD+1];

/*enum terminal current_token, lookahead_token;*/

#define TOKEN_NOT_READ dummy_last_terminal

#ifdef __GNUC__
__inline__
#endif
static enum terminal
PEEK_TOKEN()
{
  if (terminal_buffer[0] == TOKEN_NOT_READ)
    {
      terminal_buffer[0] = yylex();
      val_buffer[0] = yylval;
    }
  return terminal_buffer[0];
}
#define PEEK_TREE() val_buffer[0].ttype
#define PEEK_TOKEN1() peek_token_(1)
#define PEEK_TOKEN2() peek_token_(2)
static int
peek_token_ (i)
     int i;
{
  if (i > MAX_LOOK_AHEAD)
    fatal ("internal error - too much lookahead");
  if (terminal_buffer[i] == TOKEN_NOT_READ)
    {
      terminal_buffer[i] = yylex();
      val_buffer[i] = yylval;
    }
  return terminal_buffer[i];
}

static void
pushback_token (code, node)
     int code;
     tree node;
{
  int i;
  if (terminal_buffer[MAX_LOOK_AHEAD] != TOKEN_NOT_READ)
    fatal ("internal error - cannot pushback token");
  for (i = MAX_LOOK_AHEAD; i > 0; i--)
    { 
      terminal_buffer[i] = terminal_buffer[i - 1]; 
      val_buffer[i] = val_buffer[i - 1];
  }
  terminal_buffer[0] = code;
  val_buffer[0].ttype = node;
}

static void
forward_token_()
{
  int i;
  for (i = 0; i < MAX_LOOK_AHEAD; i++)
    {
      terminal_buffer[i] = terminal_buffer[i+1];
      val_buffer[i] = val_buffer[i+1];
    }
  terminal_buffer[MAX_LOOK_AHEAD] = TOKEN_NOT_READ;
}
#define FORWARD_TOKEN() forward_token_()

/* Skip the next token.
   if it isn't TOKEN, the parser is broken. */

void
require(token)
     enum terminal token;
{
  if (PEEK_TOKEN() != token)
    {
      char buf[80];
      sprintf (buf, "internal parser error - expected token %d", (int)token);
      fatal(buf);
    }
  FORWARD_TOKEN();
}

int
check_token (token)
     enum terminal token;
{
  if (PEEK_TOKEN() != token)
    return 0;
  FORWARD_TOKEN ();
  return 1;
}

/* return 0 if expected token was not found,
   else return 1.
*/
int
expect(token, message)
     enum terminal token;
     char *message;
{
  if (PEEK_TOKEN() != token)
    {
      if (pass == 1)
	error(message ? message : "syntax error");
      return 0;
    }
  else
    FORWARD_TOKEN();
  return 1;
}

/* define a SYNONYM __PROCNAME__ (__procname__) which holds
   the name of the current procedure.
   This should be quit the same as __FUNCTION__ in C */
static void
define__PROCNAME__ ()
{
  char *fname;
  tree string;
  tree procname;

  if (current_function_decl == NULL_TREE)
    fname = "toplevel";
  else
    fname = IDENTIFIER_POINTER (DECL_NAME (current_function_decl));

  string = build_chill_string (strlen (fname), fname);
  procname = get_identifier (ignore_case ? "__procname__" : "__PROCNAME__");
  push_syndecl (procname, NULL_TREE, string);
}

/* Forward declarations. */
static tree parse_expression ();
static tree parse_primval ();
static tree parse_mode PROTO((void));
static tree parse_opt_mode PROTO((void));
static tree parse_untyped_expr ();
static tree parse_opt_untyped_expr ();
static int parse_definition PROTO((int));
static void parse_opt_actions ();
static void parse_body PROTO((void));
static tree parse_if_expression_body PROTO((void));
static tree parse_opt_handler PROTO((void));

static tree
parse_opt_name_string (allow_all)
     int allow_all; /* 1 if ALL is allowed as a postfix */
{
  enum terminal token = PEEK_TOKEN();
  tree name;
  if (token != NAME)
    {
      if (token == ALL && allow_all)
	{
	  FORWARD_TOKEN ();
	  return ALL_POSTFIX;
	}
      return NULL_TREE;
    }
  name = PEEK_TREE();
  for (;;)
    {
      FORWARD_TOKEN ();
      token = PEEK_TOKEN();
      if (token != '!')
	return name;
      FORWARD_TOKEN();
      token = PEEK_TOKEN();
      if (token == ALL && allow_all)
	return get_identifier3(IDENTIFIER_POINTER (name), "!", "*");
      if (token != NAME)
	{
	  if (pass == 1)
	    error ("'%s!' is not followed by an identifier",
		   IDENTIFIER_POINTER (name));
	  return name;
	}
      name = get_identifier3(IDENTIFIER_POINTER(name),
			     "!", IDENTIFIER_POINTER(PEEK_TREE()));
    }
}

static tree
parse_simple_name_string ()
{
  enum terminal token = PEEK_TOKEN();
  tree name;
  if (token != NAME)
    {
      error ("expected a name here");
      return error_mark_node;
    }
  name = PEEK_TREE ();
  FORWARD_TOKEN ();
  return name;
}

static tree
parse_name_string ()
{
  tree name = parse_opt_name_string (0);
  if (name)
    return name;
  if (pass == 1)
    error ("expected a name string here");
  return error_mark_node;
}

static tree
parse_defining_occurrence ()
{
  if (PEEK_TOKEN () == NAME)
    {
      tree id = PEEK_TREE();
      FORWARD_TOKEN ();
      return id;
    }
  return NULL;
}

/* Matches: <name_string>
   Returns if pass 1: the identifier.
   Returns if pass 2: a decl or value for identifier. */

static tree
parse_name ()
{
  tree name = parse_name_string ();
  if (pass == 1 || ignoring)
    return name;
  else
    {
      tree decl = lookup_name (name);
      if (decl == NULL_TREE)
	{
	  error ("`%s' undeclared", IDENTIFIER_POINTER (name));
	  return error_mark_node;
	}
      else if (TREE_CODE (TREE_TYPE (decl)) == ERROR_MARK)
	return error_mark_node;
      else if (TREE_CODE (decl) == CONST_DECL)
	return DECL_INITIAL (decl);
      else if (TREE_CODE (TREE_TYPE (decl)) == REFERENCE_TYPE)
	return convert_from_reference (decl);
      else
	return decl;
    } 
}

static tree
parse_optlabel()
{
  tree label = parse_defining_occurrence();
  if (label != NULL)
    expect(COLON, "expected a ':' here");
  return label;
}

static void
parse_semi_colon ()
{
  enum terminal token = PEEK_TOKEN ();
  if (token == SC)
    FORWARD_TOKEN ();
  else if (pass == 1)
    (token == END ? pedwarn : error) ("expected ';' here");
  label = NULL_TREE;
}

static void
parse_opt_end_label_semi_colon (start_label)
     tree start_label;
{
  if (PEEK_TOKEN() == NAME)
    {
      tree end_label = parse_name_string ();
      check_end_label (start_label, end_label);
    }
  parse_semi_colon ();
}

static void
parse_modulion (label)
     tree label;
{
  tree module_name;

  label = set_module_name (label);
  module_name = push_module (label, 0);
  FORWARD_TOKEN();

  push_action ();
  parse_body();
  expect(END, "expected END here");
  parse_opt_handler ();
  parse_opt_end_label_semi_colon (label);
  find_granted_decls ();
  pop_module ();
}

static void
parse_spec_module (label)
     tree label;
{
  int save_ignoring = ignoring;

  push_module (set_module_name (label), 1);
  ignoring = pass == 2;
  FORWARD_TOKEN(); /* SKIP SPEC */
  expect (MODULE, "expected 'MODULE' here");

  while (parse_definition (1)) { }
  if (parse_action ())
    error ("action not allowed in SPEC MODULE");
  expect(END, "expected END here");
  parse_opt_end_label_semi_colon (label);
  find_granted_decls ();
  pop_module ();
  ignoring = save_ignoring;
}

/* Matches:  <name_string> ( "," <name_string> )*
   Returns either a single IDENTIFIER_NODE,
   or a chain (TREE_LIST) of IDENTIFIER_NODES.
   (Since a single identifier is the common case, we avoid wasting space
   (twice, once for each pass) with extra TREE_LIST nodes in that case.)
   (Will not return NULL_TREE even if ignoring is true.) */

static tree
parse_defining_occurrence_list ()
{
  tree chain = NULL_TREE;
  tree name = parse_defining_occurrence ();
  if (name == NULL_TREE)
    {
      error("missing defining occurrence");
      return NULL_TREE;
    }
  if (! check_token (COMMA))
    return name;
  chain = build_tree_list (NULL_TREE, name);
  for (;;)
    {
      name = parse_defining_occurrence ();
      if (name == NULL)
	{
	  error ("bad defining occurrence following ','");
	  break;
	}
      chain = tree_cons (NULL_TREE, name, chain);
      if (! check_token (COMMA))
	break;
    }
  return nreverse (chain);
}

static void
parse_mode_definition (is_newmode)
     int is_newmode;
{
  tree mode, names;
  int save_ignoring = ignoring;
  ignoring = pass == 2;
  names = parse_defining_occurrence_list ();
  expect (EQL, "missing '=' in mode definition");
  mode = parse_mode ();
  if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
    {
      for ( ; names != NULL_TREE; names = TREE_CHAIN (names))
	push_modedef (names, mode, is_newmode);
    }
  else
    push_modedef (names, mode, is_newmode);
  ignoring = save_ignoring;
}

void
parse_mode_definition_statement (is_newmode)
     int is_newmode;
{
  FORWARD_TOKEN (); /* skip SYNMODE or NEWMODE */
  parse_mode_definition (is_newmode);
  while (PEEK_TOKEN () == COMMA)
    {
      FORWARD_TOKEN ();
      parse_mode_definition (is_newmode);
    }
  parse_semi_colon ();
}

static void
parse_synonym_definition ()
{ tree expr = NULL_TREE;
  tree names = parse_defining_occurrence_list ();
  tree mode = parse_opt_mode ();
  if (! expect (EQL, "missing '=' in synonym definition"))
    mode = error_mark_node;
  else
    {
      if (mode)
	expr = parse_untyped_expr ();
      else
	expr = parse_expression ();
    }
  if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
    {
      for ( ; names != NULL_TREE; names = TREE_CHAIN (names))
	push_syndecl (names, mode, expr);
    }
  else
    push_syndecl (names, mode, expr);
}

static void
parse_synonym_definition_statement()
{
  int save_ignoring= ignoring;
  ignoring = pass == 2;
  require (SYN);
  parse_synonym_definition ();
  while (PEEK_TOKEN () == COMMA)
    {
      FORWARD_TOKEN ();
      parse_synonym_definition ();
    }
  ignoring = save_ignoring;
  parse_semi_colon ();
}

/* Attempts to match: "(" <exception list> ")" ":".
   Return NULL_TREE on failure, and non-NULL on success.
   On success, if pass 1, return a TREE_LIST of IDENTIFIER_NODEs. */

static tree
parse_on_exception_list ()
{
  tree name;
  tree list = NULL_TREE;
  int tok1 = PEEK_TOKEN ();
  int tok2 = PEEK_TOKEN1 ();

  /* This requires a lot of look-ahead, because we cannot
     easily a priori distinguish an exception-list from an expression. */
  if (tok1 != LPRN || tok2 != NAME)
    {
      if (tok1 == NAME && tok2 == COLON && pass == 1)
	error ("missing '(' in exception list");
      return 0;
    }
  require (LPRN);
  name = parse_name_string ();
  if (PEEK_TOKEN () == RPRN && PEEK_TOKEN1 () == COLON)
    {
      /* Matched: '(' <name_string> ')' ':' */
      FORWARD_TOKEN (); FORWARD_TOKEN ();
      return pass == 1 ? build_tree_list (NULL_TREE, name) : name;
    }
  if (PEEK_TOKEN() == COMMA)
    {
      if (pass == 1)
	list = build_tree_list (NULL_TREE, name);
      while (check_token (COMMA))
	{
	  tree old_names = list;
	  name = parse_name_string ();
	  if (pass == 1)
	    {
	      for ( ; old_names != NULL_TREE; old_names = TREE_CHAIN (old_names))
		{
		  if (TREE_VALUE (old_names) == name)
		    {
		      error ("ON exception names must be unique");
		      goto continue_parsing;
		    }
		}
	      list = tree_cons (NULL_TREE, name, list);
	    continue_parsing:
	      ;
	    }
	}
      if (! check_token (RPRN) || ! check_token(COLON))
	error ("syntax error in exception list");
      return pass == 1 ? nreverse (list) : name;
    }
  /* Matched: '(' name_string
     but it doesn't match the syntax of an exception list.
     It could be the beginning of an expression, so back up. */
  pushback_token (NAME, name);
  pushback_token (LPRN, 0);
  return NULL_TREE;
}

static void
parse_on_alternatives ()
{
  for (;;)
    {
      tree except_list = parse_on_exception_list ();
      if (except_list != NULL)
	chill_handle_on_labels (except_list);
      else if (parse_action ())
	expand_exit_needed = 1;
      else
	break;
    }
}

static tree
parse_opt_handler ()
{
  if (! check_token (ON))
    {
      POP_UNUSED_ON_CONTEXT;
      return NULL_TREE;
    }
  if (check_token (END))
    {
      pedwarn ("empty ON-condition"); 
      POP_UNUSED_ON_CONTEXT;
      return NULL_TREE;
    } 
  if (! ignoring)
    {
      chill_start_on ();
      expand_exit_needed = 0;
    }
  if (PEEK_TOKEN () != ELSE)
    {
      parse_on_alternatives ();
      if (! ignoring && expand_exit_needed)
	expand_exit_something (); 
    }
  if (check_token (ELSE))
    {
      chill_start_default_handler ();
      label = NULL_TREE;
      parse_opt_actions ();
      if (! ignoring)
	{
	  emit_line_note (input_filename, lineno); 
	  expand_exit_something (); 
	} 
    }
  expect (END, "missing 'END' after");
  if (! ignoring)
    chill_finish_on ();
  POP_USED_ON_CONTEXT;
  return integer_zero_node; 
}

static void
parse_loc_declaration (in_spec_module)
     int in_spec_module;
{
  tree names = parse_defining_occurrence_list ();
  int save_ignoring = ignoring;
  int is_static, lifetime_bound;
  tree mode, init_value = NULL_TREE;
  int loc_decl = 0;

  ignoring = pass == 2;
  mode = parse_mode ();
  ignoring = save_ignoring;
  is_static = check_token (STATIC);
  if (check_token (BASED))
    {
      expect(LPRN, "BASED must be followed by (NAME)");
      do_based_decls (names, mode, parse_name_string ());
      expect(RPRN, "BASED must be followed by (NAME)");
      return;
    }
  if (check_token (LOC))
    {
      /* loc-identity declaration */
      if (pass == 1)
	mode = build_chill_reference_type (mode);
      loc_decl = 1;
    }
  lifetime_bound = check_token (INIT);
  if (lifetime_bound && loc_decl)
    {
      if (pass == 1)
	error ("INIT not allowed at loc-identity declaration");
      lifetime_bound = 0;
    }
  if (PEEK_TOKEN () == ASGN || PEEK_TOKEN() == EQL)
    {
      save_ignoring = ignoring;
      ignoring = pass == 1;
      if (PEEK_TOKEN() == EQL)
	{
	  if (pass == 1)
	    error ("'=' used where ':=' is required");
	}
      FORWARD_TOKEN();
      if (! lifetime_bound)
	push_handler ();
      init_value = parse_untyped_expr ();
      if (in_spec_module)
	{
	  error ("initialization is not allowed in spec module");
	  init_value = NULL_TREE;
	}
      if (! lifetime_bound)
	parse_opt_handler ();
      ignoring = save_ignoring;
    }
  if (init_value == NULL_TREE && loc_decl && pass == 1)
    error ("loc-identity declaration without initialisation");
  do_decls (names, mode,
	    is_static || global_bindings_p ()
	    /* the variable becomes STATIC if all_static_flag is set and
	       current functions doesn't have the RECURSIVE attribute */
	    || (all_static_flag && !CH_DECL_RECURSIVE (current_function_decl)),
	    lifetime_bound, init_value, in_spec_module);

  /* Free any temporaries we made while initializing the decl.  */
  free_temp_slots ();
}

static void
parse_declaration_statement (in_spec_module)
     int in_spec_module;
{
  int save_ignoring = ignoring;
  ignoring = pass == 2;
  require (DCL);
  parse_loc_declaration (in_spec_module);
  while (PEEK_TOKEN () == COMMA)
    {
      FORWARD_TOKEN ();
      parse_loc_declaration (in_spec_module);
    }
  ignoring = save_ignoring;
  parse_semi_colon ();
}

tree
parse_optforbid ()
{
  if (check_token (FORBID) == 0)
    return NULL_TREE;
  if (check_token (ALL))
    return ignoring ? NULL_TREE : build_int_2 (-1, -1);
#if 0
  if (check_token (LPRN))
    {
      tree list = parse_forbidlist ();
      expect (RPRN, "missing ')' after FORBID list");
      return list;
    }
#endif
  error ("bad syntax following FORBID");
  return NULL_TREE;
}

/* Matches: <grant postfix> or <seize postfix>
   Returns: A (singleton) TREE_LIST. */

tree
parse_postfix (grant_or_seize)
     enum terminal grant_or_seize;
{
  tree name = parse_opt_name_string (1);
  tree forbid = NULL_TREE;
  if (name == NULL_TREE)
    {
      error ("expected a postfix name here");
      name = error_mark_node;
    }
  if (grant_or_seize == GRANT)
    forbid = parse_optforbid ();
  return build_tree_list (forbid, name);
}

tree
parse_postfix_list (grant_or_seize)
     enum terminal grant_or_seize;
{
  tree list = parse_postfix (grant_or_seize);
  while (check_token (COMMA))
    list = chainon (list, parse_postfix (grant_or_seize));
  return list;
}

void
parse_rename_clauses (grant_or_seize)
     enum terminal grant_or_seize;
{
  for (;;)
    {
      tree rename_old_prefix, rename_new_prefix, postfix;
      require (LPRN);
      rename_old_prefix = parse_opt_name_string (0);
      expect (ARROW, "missing '->' in rename clause");
      rename_new_prefix = parse_opt_name_string (0);
      expect (RPRN,  "missing ')' in rename clause");
      expect ('!',  "missing '!' in rename clause");
      postfix = parse_postfix (grant_or_seize);

      if (grant_or_seize == GRANT)
	chill_grant (rename_old_prefix, rename_new_prefix,
		     TREE_VALUE (postfix), TREE_PURPOSE (postfix));
      else
	chill_seize (rename_old_prefix, rename_new_prefix,
		     TREE_VALUE (postfix));

      if (PEEK_TOKEN () != COMMA)
	break;
      FORWARD_TOKEN ();
      if (PEEK_TOKEN () != LPRN)
	{
	  error ("expected another rename clause");
	  break;
	}
    }
}

static tree
parse_opt_prefix_clause ()
{
  if (check_token (PREFIXED) == 0)
    return NULL_TREE;
  return build_prefix_clause (parse_opt_name_string (0));
}

void
parse_grant_statement ()
{
  require (GRANT);
  if (PEEK_TOKEN () == LPRN)
    parse_rename_clauses (GRANT);
  else
    {
      tree window = parse_postfix_list (GRANT);
      tree new_prefix = parse_opt_prefix_clause ();
      tree t;
      for (t = window; t; t = TREE_CHAIN (t))
	chill_grant (NULL_TREE, new_prefix, TREE_VALUE (t), TREE_PURPOSE (t));
    }
}

void
parse_seize_statement ()
{
  require (SEIZE);
  if (PEEK_TOKEN () == LPRN)
    parse_rename_clauses (SEIZE);
  else
    {
      tree seize_window = parse_postfix_list (SEIZE);
      tree old_prefix = parse_opt_prefix_clause ();
      tree t;
      for (t = seize_window; t; t = TREE_CHAIN (t))
	chill_seize (old_prefix, NULL_TREE, TREE_VALUE (t));
    }
}

/* In pass 1, this returns a TREE_LIST, one node for each parameter.
   In pass 2, we get a list of PARM_DECLs chained together.
   In either case, the list is in reverse order. */

static tree
parse_param_name_list ()
{
  tree list = NULL_TREE;
  do
    {
      tree new_link;
      tree name = parse_defining_occurrence ();
      if (name == NULL_TREE)
	{
	  error ("syntax error in parameter name list");
	  return list;
	}
      if (pass == 1)
	new_link = build_tree_list (NULL_TREE, name);
      /* else if (current_module->is_spec_module) ; nothing */
      else  /* pass == 2 */
	{
	  new_link = make_node (PARM_DECL);
	  DECL_NAME (new_link) = name;
	  DECL_ASSEMBLER_NAME (new_link) = name;
	}

      TREE_CHAIN (new_link) = list;
      list = new_link;
    } while (check_token (COMMA));
  return list;
}

static tree
parse_param_attr ()
{
  tree attr;
  switch (PEEK_TOKEN ())
    {
    case PARAMATTR:          /* INOUT is returned here */
      attr = PEEK_TREE ();
      FORWARD_TOKEN ();
      return attr;
    case IN:
      FORWARD_TOKEN ();
      return ridpointers[(int) RID_IN];
    case LOC:
      FORWARD_TOKEN ();
      return ridpointers[(int) RID_LOC];
#if 0
    case DYNAMIC:
      FORWARD_TOKEN ();
      return ridpointers[(int) RID_DYNAMIC];
#endif
    default:
      return NULL_TREE;
    }
}

/* We wrap CHILL array parameters in a STRUCT.  The original parameter
   name is unpacked from the struct at get_identifier time */

/* In pass 1, returns list of types; in pass 2: chain of PARM_DECLs. */
   
static tree
parse_formpar ()
{
  tree names = parse_param_name_list ();
  tree mode = parse_mode ();
  tree paramattr = parse_param_attr ();
  return chill_munge_params (nreverse (names), mode, paramattr);
}

/*
 * Note: build_process_header depends upon the *exact*
 * representation of STRUCT fields and of formal parameter
 * lists.  If either is changed, build_process_header will
 * also need change.  Push_extern_process is affected as well.
 */
static tree
parse_formparlist ()
{
  tree list = NULL_TREE;
  if (PEEK_TOKEN() == RPRN)
    return NULL_TREE;
  for (;;)
    {
      list = chainon (list, parse_formpar ());
      if (! check_token (COMMA))
	break;
    }
  return list;
}

static tree
parse_opt_result_spec ()
{
  tree mode;
  int is_nonref, is_loc, is_dynamic;
  if (!check_token (RETURNS))
    return void_type_node;
  expect (LPRN, "expected '(' after RETURNS");
  mode = parse_mode ();
  is_nonref = check_token (NONREF);
  is_loc = check_token (LOC);
  is_dynamic = check_token (DYNAMIC);
  if (is_nonref && !is_loc)
    error ("NONREF specific without LOC in result attribute");
  if (is_dynamic && !is_loc)
    error ("DYNAMIC specific without LOC in result attribute");
  mode = get_type_of (mode);
  if (is_loc && ! ignoring)
    mode = build_chill_reference_type (mode);
  expect (RPRN, "expected ')' after RETURNS");
  return mode;
}

static tree
parse_opt_except ()
{
  tree list = NULL_TREE;
  if (!check_token (EXCEPTIONS))
    return NULL_TREE;
  expect (LPRN, "expected '(' after EXCEPTIONS");
  do
    {
      tree except_name = parse_name_string ();
      tree name;
      for (name = list; name != NULL_TREE; name = TREE_CHAIN (name))
	if (TREE_VALUE (name) == except_name && pass == 1)
	  {
	    error ("exception names must be unique");
	    break;
	  }
      if (name == NULL_TREE && !ignoring)
	list = tree_cons (NULL_TREE, except_name, list); 
    } while (check_token (COMMA));
  expect (RPRN, "expected ')' after EXCEPTIONS");
  return list;
}

static tree
parse_opt_recursive ()
{
  if (check_token (RECURSIVE))
    return ridpointers[RID_RECURSIVE];
  else
    return NULL_TREE;
}

static tree
parse_procedureattr ()
{
  tree generality;
  tree optrecursive;
  switch (PEEK_TOKEN ())
    {
    case GENERAL:
      FORWARD_TOKEN ();
      generality = ridpointers[RID_GENERAL];
      break;
    case SIMPLE:
      FORWARD_TOKEN ();
      generality = ridpointers[RID_SIMPLE];
      break;
    case INLINE:
      FORWARD_TOKEN ();
      generality = ridpointers[RID_INLINE];
      break;
    default:
      generality = NULL_TREE;
    }
  optrecursive = parse_opt_recursive ();
  if (pass != 1)
    return NULL_TREE;
  if (generality)
    generality = build_tree_list (NULL_TREE, generality);
  if (optrecursive)
    generality = tree_cons (NULL_TREE, optrecursive, generality);
  return generality;
}

/* Parse the body and last part of a procedure or process definition. */

static void
parse_proc_body (name, exceptions)
     tree name;
     tree exceptions;
{
  int save_proc_action_level = proc_action_level;
  proc_action_level = action_nesting_level;
  if (exceptions != NULL_TREE)
    /* set up a handler for reraising exceptions */
    push_handler ();
  push_action ();
  define__PROCNAME__ ();
  parse_body ();
  proc_action_level = save_proc_action_level;
  expect (END, "'END' was expected here");
  parse_opt_handler ();
  if (exceptions != NULL_TREE)
    chill_reraise_exceptions (exceptions);
  parse_opt_end_label_semi_colon (name);
  end_function ();
}

static void
parse_procedure_definition (in_spec_module)
     int in_spec_module;
{
  int save_ignoring = ignoring;
  tree name = parse_defining_occurrence ();
  tree params, result, exceptlist, attributes;
  int save_chill_at_module_level = chill_at_module_level;
  chill_at_module_level = 0;
  if (!in_spec_module)
    ignoring = pass == 2;
  require (COLON); require (PROC);
  expect (LPRN, "missing '(' after PROC");
  params = parse_formparlist ();
  expect (RPRN, "missing ')' in PROC");
  result = parse_opt_result_spec ();
  exceptlist = parse_opt_except ();
  attributes = parse_procedureattr ();
  ignoring = save_ignoring;
  if (in_spec_module)
    {
      expect (END, "missing 'END'");
      parse_opt_end_label_semi_colon (name);
      push_extern_function (name, result, params, exceptlist, 0);
      return;
    }
  push_chill_function_context ();
  start_chill_function (name, result, params, exceptlist, attributes);
  current_module->procedure_seen = 1; 
  parse_proc_body (name, TYPE_RAISES_EXCEPTIONS (TREE_TYPE (current_function_decl)));
  chill_at_module_level = save_chill_at_module_level;
}

static tree
parse_processpar ()
{
  tree names = parse_defining_occurrence_list ();
  tree mode = parse_mode ();
  tree paramattr = parse_param_attr ();

  if (names && TREE_CODE (names) == IDENTIFIER_NODE)
    names = build_tree_list (NULL_TREE, names);
  return tree_cons (tree_cons (paramattr, mode, NULL_TREE), names, NULL_TREE);
}

static tree
parse_processparlist ()
{
  tree list = NULL_TREE;
  if (PEEK_TOKEN() == RPRN)
    return NULL_TREE;
  for (;;)
    {
      list = chainon (list, parse_processpar ());
      if (! check_token (COMMA))
	break;
    }
  return list;
}

static void
parse_process_definition (in_spec_module)
     int in_spec_module;
{
  int save_ignoring = ignoring;
  tree name = parse_defining_occurrence ();
  tree params;
  tree tmp;
  if (!in_spec_module)
    ignoring = 0;
  require (COLON); require (PROCESS);
  expect (LPRN, "missing '(' after PROCESS");
  params = parse_processparlist (in_spec_module);
  expect (RPRN, "missing ')' in PROCESS");
  ignoring = save_ignoring;
  if (in_spec_module)
    {
      expect (END, "missing 'END'");
      parse_opt_end_label_semi_colon (name);
      push_extern_process (name, params, NULL_TREE, 0);
      return;
    }
  tmp = build_process_header (name, params);
  parse_proc_body (name, NULL_TREE);
  build_process_wrapper (name, tmp);
}

static void
parse_signal_definition ()
{
  tree signame = parse_defining_occurrence ();
  tree modes = NULL_TREE;
  tree dest = NULL_TREE;

  if (check_token (EQL))
    {
      expect (LPRN, "missing '(' after 'SIGNAL <name> ='");
      for (;;)
	{
	  tree mode = parse_mode ();
	  modes = tree_cons (NULL_TREE, mode, modes);
	  if (! check_token (COMMA))
	    break;
	}
      expect (RPRN, "missing ')'");
      modes = nreverse (modes);
    }

  if (check_token (TO))
    {
      tree decl;
      int save_ignoring = ignoring;
      ignoring = 0;
      decl = parse_name ();
      ignoring = save_ignoring;
      if (pass > 1)
	{
	  if (decl == NULL_TREE
	      || TREE_CODE (decl) == ERROR_MARK
	      || TREE_CODE (decl) != FUNCTION_DECL
	      || !CH_DECL_PROCESS (decl))
	    error ("must specify a PROCESS name");
	  else
	    dest = decl; 
	}
    }

  if (! global_bindings_p ())
    error ("SIGNAL must be in global reach");
  else
    {
      tree struc =  build_signal_struct_type (signame, modes, dest);
      tree decl = 
	generate_tasking_code_variable (signame, 
					&signal_code, 
					current_module->is_spec_module);
      /* remember the code variable in the struct type */
      DECL_TASKING_CODE_DECL (struc) = (struct lang_decl *)decl;
      CH_DECL_SIGNAL (struc) = 1;
      add_taskstuff_to_list (decl, "_TT_Signal", 
			     current_module->is_spec_module ?
			     NULL_TREE : signal_code, struc, NULL_TREE);
    }

}

static void
parse_signal_definition_statement ()
{
  int save_ignoring = ignoring;
  ignoring = pass == 2;
  require (SIGNAL);
  for (;;)
    {
      parse_signal_definition ();
      if (! check_token (COMMA))
	break;
      if (PEEK_TOKEN () == SC)
	{
	  error ("syntax error while parsing signal definition statement");
	  break;
	}
    }
  parse_semi_colon ();
  ignoring = save_ignoring;
}

static int
parse_definition (in_spec_module)
     int in_spec_module;
{
  switch (PEEK_TOKEN ())
    {
    case NAME:
      if (PEEK_TOKEN1() == COLON)
	{
	  if (PEEK_TOKEN2() == PROC)
	    {
	      parse_procedure_definition (in_spec_module);
	      return 1;
	    }
	  else if (PEEK_TOKEN2() == PROCESS)
	    {
	      parse_process_definition (in_spec_module);
	      return 1;
	    }
	}
      return 0;
    case DCL:
      parse_declaration_statement(in_spec_module);
      break;
    case GRANT:
      parse_grant_statement ();
      break;
    case NEWMODE:
      parse_mode_definition_statement(1);
      break;
    case SC:
      label = NULL_TREE;
      FORWARD_TOKEN();
      return 1;
    case SEIZE:
      parse_seize_statement ();
      break;
    case SIGNAL:
      parse_signal_definition_statement ();
      break;
    case SYN:
      parse_synonym_definition_statement();
      break;
    case SYNMODE:
      parse_mode_definition_statement(0);
      break;
    default:
      return 0;
    }
  return 1;
}

static void
parse_then_clause ()
{
  expect (THEN, "expected 'THEN' after 'IF'");
  if (! ignoring)
    emit_line_note (input_filename, lineno);
  parse_opt_actions ();
}

static void
parse_opt_else_clause ()
{
  while (check_token (ELSIF))
    {
      tree cond = parse_expression ();
      if (! ignoring)
	expand_start_elseif (truthvalue_conversion (cond));
      parse_then_clause ();
    }
  if (check_token (ELSE))
    {
      if (! ignoring)
	{ emit_line_note (input_filename, lineno);
	  expand_start_else (); 
	} 
      parse_opt_actions ();
    }
}

static tree parse_expr_list ()
{
  tree expr = parse_expression ();
  tree list = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr);
  while (check_token (COMMA))
    {
      expr = parse_expression ();
      if (! ignoring)
	list = tree_cons (NULL_TREE, expr, list);
    }
  return list;
}

static tree
parse_range_list_clause ()
{
  tree name = parse_opt_name_string (0);
  if (name == NULL_TREE)
    return NULL_TREE;
  while (check_token (COMMA))
    {
      name = parse_name_string (0);
    }
  if (check_token (SC))
    {
      sorry ("case range list"); 
      return error_mark_node;
    }
  pushback_token (NAME, name);
  return NULL_TREE;
}

static void
pushback_paren_expr (expr)
     tree expr;
{
  if (pass == 1 && !ignoring)
    expr = build1 (PAREN_EXPR, NULL_TREE, expr);
  pushback_token (EXPR, expr);
}

/* Matches: <case label> */

static tree
parse_case_label ()
{
  tree expr;
  if (check_token (ELSE))
    return case_else_node;
  /* Does this also handle the case of a mode name?  FIXME */
  expr = parse_expression ();
  if (check_token (COLON))
    {
      tree max_expr = parse_expression ();
      if (! ignoring)
	expr = build (RANGE_EXPR, NULL_TREE, expr, max_expr);
    }
  return expr;
}

/* Parses:  <case_label_list>
   Fails if not followed by COMMA or COLON.
   If it fails, it backs up if needed, and returns NULL_TREE.
   IN_TUPLE is true if we are parsing a tuple element,
   and 0 if we are parsing a case label specification. */

static tree
parse_case_label_list (selector, in_tuple)
     tree selector;
     int in_tuple;
{
  tree expr, list;
  if (! check_token (LPRN))
    return NULL_TREE;
  if (check_token (MUL))
    {
      expect (RPRN, "missing ')' after '*' case label list");
      if (ignoring)
	return integer_zero_node;
      expr = build (RANGE_EXPR, NULL_TREE, NULL_TREE, NULL_TREE);
      expr = build_tree_list (NULL_TREE, expr);
      return expr;
    }
  expr = parse_case_label ();
  if (check_token (RPRN))
    {
      if ((in_tuple || PEEK_TOKEN () != COMMA) && PEEK_TOKEN () != COLON)
	{
	  /* Ooops!  It looks like it was the start of an action or
	     unlabelled tuple element,  and not a case label, so back up. */
	  if (expr != NULL_TREE && TREE_CODE (expr) == RANGE_EXPR)
	    {
	      error ("misplaced colon in case label");
	      expr = error_mark_node;
	    }
	  pushback_paren_expr (expr);
	  return NULL_TREE;
	}
      list = build_tree_list (NULL_TREE, expr);
      if (expr == case_else_node && selector != NULL_TREE)
	ELSE_LABEL_SPECIFIED (selector) = 1;
      return list;
    }
  list = build_tree_list (NULL_TREE, expr);
  if (expr == case_else_node && selector != NULL_TREE)
    ELSE_LABEL_SPECIFIED (selector) = 1;

  while (check_token (COMMA))
    {
      expr = parse_case_label ();
      list = tree_cons (NULL_TREE, expr, list);
      if (expr == case_else_node && selector != NULL_TREE)
	ELSE_LABEL_SPECIFIED (selector) = 1;
    }
  expect (RPRN, "missing ')' at end of case label list");
  return nreverse (list);
}

/* Parses:  <case_label_specification>
   Must be followed by a COLON.
   If it fails, it backs up if needed, and returns NULL_TREE. */

static tree
parse_case_label_specification (selectors)
     tree selectors;
{
  tree list_list = NULL_TREE;
  tree list;
  list = parse_case_label_list (selectors, 0);
  if (list == NULL_TREE)
    return NULL_TREE;
  list_list = build_tree_list (NULL_TREE, list);
  while (check_token (COMMA))
    {
      if (selectors != NULL_TREE)
	selectors = TREE_CHAIN (selectors);
      list = parse_case_label_list (selectors, 0);
      if (list == NULL_TREE)
	{
	  error ("unrecognized case label list after ','");
	  return list_list;
	}
      list_list = tree_cons (NULL_TREE, list, list_list);
    }
  return nreverse (list_list);
}

static void
parse_single_dimension_case_action (selector)
     tree selector;
{
  int  no_completeness_check = 0;

/* The case label/action toggle.  It is 0 initially, and when an action
   was last seen.  It is 1 integer_zero_node when a label was last seen. */
  int caseaction_flag = 0;

  if (! ignoring)
    {
      expand_exit_needed = 0;
      selector = check_case_selector (selector);
      expand_start_case (1, selector, TREE_TYPE (selector), "CASE statement");
      push_momentary ();
    }

  for (;;)
    {
      tree label_spec = parse_case_label_specification (selector);
      if (label_spec != NULL_TREE)
	{
	  expect (COLON, "missing ':' in case alternative");
	  if (! ignoring)
	    {
              no_completeness_check |= chill_handle_single_dimension_case_label (
                selector, label_spec, &expand_exit_needed, &caseaction_flag);
	    }
	}
      else if (parse_action ())
	{
	  expand_exit_needed = 1; 
	  caseaction_flag = 0;
	}
      else
	break;
    }

  if (! ignoring)
    {
      if (expand_exit_needed || caseaction_flag == 1)
	expand_exit_something (); 
    }
  if (check_token (ELSE))
    {
      if (! ignoring)
	  chill_handle_case_default ();
      parse_opt_actions ();
      if (! ignoring)
	{
	  emit_line_note (input_filename, lineno); 
	  expand_exit_something (); 
	}
    }
  else if (! ignoring && TREE_CODE (selector) != ERROR_MARK &&
	   ! no_completeness_check)
    check_missing_cases (TREE_TYPE (selector));

  expect (ESAC, "missing 'ESAC' after 'CASE'");
  if (! ignoring)
    {
      expand_end_case (selector);
      pop_momentary (); 
    }
}

static void
parse_multi_dimension_case_action (selector)
     tree selector;
{
  struct rtx_def *begin_test_label = 0, *end_case_label, *new_label;
  tree action_labels = NULL_TREE;
  tree tests = NULL_TREE;
  int  save_lineno = lineno;
  char *save_filename = input_filename;

  /* We can't compute the range of an (ELSE) label until all of the CASE
     label specifications have been seen, however, the code for the actions
     between them is generated on the fly. We can still generate everything in
     one pass is we use the following form:

     Compile a CASE of the form

       case S1,...,Sn of
         (X11),...,(X1n): A1;
               ...
         (Xm1),...,(Xmn): Am;
         else             Ae;
       esac;

     into:

       goto L0;
       L1:   A1;  goto L99;
          ...
       Lm:   Am;  goto L99;
       Le:   Ae;  goto L99;
       L0:
       T1 := s1; ...; Tn := Sn;
       if (T1 = X11 and ... and Tn = X1n) GOTO L1;
          ...
       if (T1 = Xm1 and ... and Tn = Xmn) GOTO Lm;
       GOTO Le;
       L99;
   */

  if (! ignoring)
    {
      selector = check_case_selector_list (selector);
      begin_test_label = gen_label_rtx ();
      end_case_label   = gen_label_rtx ();
      emit_jump (begin_test_label);
    }

  for (;;)
    {
      tree label_spec = parse_case_label_specification (selector);
      if (label_spec != NULL_TREE)
	{
	  expect (COLON, "missing ':' in case alternative");
	  if (! ignoring)
	    {
	      tests = tree_cons (label_spec, NULL_TREE, tests);

	      if (action_labels != NULL_TREE)
		emit_jump (end_case_label);

	      new_label = gen_label_rtx ();
	      emit_label (new_label);
	      emit_line_note (input_filename, lineno);
	      action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels);
              TREE_CST_RTL (action_labels) = new_label;
	    }
	}
      else if (! parse_action ())
	{
	  if (action_labels != NULL_TREE)
	    emit_jump (end_case_label);
	  break;
	}
    }

  if (check_token (ELSE))
    {
      if (! ignoring)
	{
	  new_label = gen_label_rtx ();
	  emit_label (new_label);
	  emit_line_note (input_filename, lineno);
	  action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels);
	  TREE_CST_RTL (action_labels) = new_label;
	}
      parse_opt_actions ();
      if (! ignoring)
	emit_jump (end_case_label);
    }

  expect (ESAC, "missing 'ESAC' after 'CASE'");

  if (! ignoring)
    {
      emit_label (begin_test_label);
      emit_line_note (save_filename, save_lineno);
      if (tests != NULL_TREE)
	{
	  tree cond;
	  tests = nreverse (tests);
	  action_labels = nreverse (action_labels);
	  compute_else_ranges (selector, tests);

	  cond = build_multi_case_selector_expression (selector, TREE_PURPOSE (tests));
	  expand_start_cond (truthvalue_conversion (cond), label ? 1 : 0);
	  emit_jump (TREE_CST_RTL (action_labels));

	  for (tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels);
	       tests != NULL_TREE && action_labels != NULL_TREE;
	       tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels))
	    {
	      cond =
		build_multi_case_selector_expression (selector, TREE_PURPOSE (tests));
	      expand_start_elseif (truthvalue_conversion (cond));
	      emit_jump (TREE_CST_RTL (action_labels));
	    }
	  if (action_labels != NULL_TREE)
	    {
	      expand_start_else (); 
	      emit_jump (TREE_CST_RTL (action_labels));
	    }
	  expand_end_cond (); 
	}
      emit_label (end_case_label);
    }
}

static void
parse_case_action (label)
     tree label;
{
  tree selector;
  int  multi_dimension_case = 0;

  require (CASE);
  selector = parse_expr_list ();
  selector = nreverse (selector);
  expect (OF, "missing 'OF' after 'CASE'");
  parse_range_list_clause ();

  PUSH_ACTION;
  if (label)
    pushlevel (1);

  if (! ignoring)
    {
      expand_exit_needed = 0;
      if (TREE_CODE (selector) == TREE_LIST)
	{
	  if (TREE_CHAIN (selector) != NULL_TREE)
            multi_dimension_case = 1;
          else
	    selector = TREE_VALUE (selector);
	}
    }

  /* We want to use the regular CASE support for the single dimension case. The
     multi dimension case requires different handling. Note that when "ignoring"
     is true we parse using the single dimension code. This is OK since it will
     still parse correctly. */
  if (multi_dimension_case)
    parse_multi_dimension_case_action (selector);
  else
    parse_single_dimension_case_action (selector);

  if (label)
    {
      possibly_define_exit_label (label);
      poplevel (0, 0, 0);
    }
}

/* Matches: [ <asm_operand> { "," <asm_operand> }* ],
   where <asm_operand> = STRING '(' <expression> ')'
   These are the operands other than the first string and colon
   in  asm ("addextend %2,%1": "=dm" (x), "0" (y), "g" (*x))  */

static tree
parse_asm_operands ()
{
  tree list = NULL_TREE;
  if (PEEK_TOKEN () != STRING)
    return NULL_TREE;
  for (;;)
    {
      tree string, expr;
      if (PEEK_TOKEN () != STRING)
	{
	  error ("bad ASM operand");
	  return list;
	}
      string = PEEK_TREE();
      FORWARD_TOKEN ();
      expect (LPRN, "missing '(' in ASM operand");
      expr = parse_expression ();
      expect (RPRN, "missing ')' in ASM operand");
      list = tree_cons (string, expr, list);
      if (! check_token (COMMA))
	break;
    }
  return nreverse (list);
}

/* Matches:  STRING { ',' STRING }* */

static tree
parse_asm_clobbers ()
{
  tree list = NULL_TREE;
  for (;;)
    {
      tree string;
      if (PEEK_TOKEN () != STRING)
	{
	  error ("bad ASM operand");
	  return list;
	}
      string = PEEK_TREE();
      FORWARD_TOKEN ();
      list = tree_cons (NULL_TREE, string, list);
      if (! check_token (COMMA))
	break;
    }
  return list;
}

void
ch_expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line)
     tree string, outputs, inputs, clobbers;
     int vol;
     char *filename;
     int line;
{
  int noutputs = list_length (outputs);
  register int i;
  /* o[I] is the place that output number I should be written.  */
  register tree *o = (tree *) alloca (noutputs * sizeof (tree));
  register tree tail;

  if (TREE_CODE (string) == ADDR_EXPR)
    string = TREE_OPERAND (string, 0);
  if (TREE_CODE (string) != STRING_CST)
    {
      error ("asm template is not a string constant");
      return;
    }

  /* Record the contents of OUTPUTS before it is modified.  */
  for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++)
    o[i] = TREE_VALUE (tail);

#if 0
  /* Perform default conversions on array and function inputs.  */
  /* Don't do this for other types--
     it would screw up operands expected to be in memory.  */
  for (i = 0, tail = inputs; tail; tail = TREE_CHAIN (tail), i++)
    if (TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == ARRAY_TYPE
	|| TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == FUNCTION_TYPE)
      TREE_VALUE (tail) = default_conversion (TREE_VALUE (tail));
#endif

  /* Generate the ASM_OPERANDS insn;
     store into the TREE_VALUEs of OUTPUTS some trees for
     where the values were actually stored.  */
  expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line);

  /* Copy all the intermediate outputs into the specified outputs.  */
  for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++)
    {
      if (o[i] != TREE_VALUE (tail))
	{
	  expand_expr (build_chill_modify_expr (o[i], TREE_VALUE (tail)),
		       0, VOIDmode, 0);
	  free_temp_slots ();
	}
      /* Detect modification of read-only values.
	 (Otherwise done by build_modify_expr.)  */
      else
	{
	  tree type = TREE_TYPE (o[i]);
	  if (TYPE_READONLY (type)
	      || ((TREE_CODE (type) == RECORD_TYPE
		   || TREE_CODE (type) == UNION_TYPE)
		  && TYPE_FIELDS_READONLY (type)))
	    warning ("readonly location modified by 'asm'");
	}
    }

  /* Those MODIFY_EXPRs could do autoincrements.  */
  emit_queue ();
}

static void
parse_asm_action ()
{
  tree insn;
  require (ASM_KEYWORD);
  expect (LPRN, "missing '('");
  PUSH_ACTION;
  if (!ignoring)
    emit_line_note (input_filename, lineno);
  insn = parse_expression ();
  if (check_token (COLON))
    {
      tree output_operand, input_operand, clobbered_regs;
      output_operand = parse_asm_operands ();
      if (check_token (COLON))
	input_operand = parse_asm_operands ();
      else
	input_operand = NULL_TREE;
      if (check_token (COLON))
	clobbered_regs = parse_asm_clobbers ();
      else
	clobbered_regs = NULL_TREE;
      expect (RPRN, "missing ')'");
      if (!ignoring)
	ch_expand_asm_operands (insn, output_operand, input_operand,
				clobbered_regs, FALSE,
				input_filename, lineno);
    }
  else
    {
      expect (RPRN, "missing ')'");
      STRIP_NOPS (insn);
      if (ignoring) { }
      else if ((TREE_CODE (insn) == ADDR_EXPR
	   && TREE_CODE (TREE_OPERAND (insn, 0)) == STRING_CST)
	  || TREE_CODE (insn) == STRING_CST)
	expand_asm (insn);
      else
	error ("argument of `asm' is not a constant string");
    }
}

static void
parse_begin_end_block (label)
     tree label;
{
  require (BEGINTOKEN);
#if 0
  /* don't make a linenote at BEGIN */
  INIT_ACTION;
#endif
  pushlevel (1);
  if (! ignoring)
    {
      clear_last_expr ();
      push_momentary ();
      expand_start_bindings (label ? 1 : 0); 
    }
  push_handler ();
  parse_body ();
  expect (END, "missing 'END'");
  /* Note that the opthandler comes before the poplevel
     - hence a handler is in the scope of the block. */
  parse_opt_handler ();
  possibly_define_exit_label (label);
  if (! ignoring)
    { 
      emit_line_note (input_filename, lineno);
      expand_end_bindings (getdecls (), kept_level_p (), 0);
    }
  poplevel (kept_level_p (), 0, 0);
  if (! ignoring)
    pop_momentary (); 
  parse_opt_end_label_semi_colon (label);
}

static void
parse_if_action (label)
     tree label;
{
  tree cond;
  require (IF);
  PUSH_ACTION;
  cond = parse_expression ();
  if (label)
    pushlevel (1);
  if (! ignoring)
    { 
      expand_start_cond (truthvalue_conversion (cond),
			 label ? 1 : 0); 
    }
  parse_then_clause ();
  parse_opt_else_clause ();
  expect (FI, "expected 'FI' after 'IF'");
  if (! ignoring)
    { 
      emit_line_note (input_filename, lineno);
      expand_end_cond (); 
    }
  if (label)
    {
      possibly_define_exit_label  (label);
      poplevel (0, 0, 0);
    }
}

/* Matches:  <iteration>  (as in a <for control>). */

static void
parse_iteration ()
{
  tree loop_counter = parse_defining_occurrence ();
  if (check_token (ASGN))
    {
      tree start_value = parse_expression ();
      tree step_value
	= check_token (BY) ? parse_expression () : NULL_TREE;
      int going_down = check_token (DOWN);
      tree end_value;
      if (check_token (TO))
	end_value = parse_expression ();
      else
	{
	  error ("expected 'TO' in step enumeration");
	  end_value = error_mark_node;
	}
      if (!ignoring)
	build_loop_iterator (loop_counter, start_value, step_value,
			     end_value, going_down, 0, 0);
    }
  else
    {
      int going_down = check_token (DOWN);
      tree expr;
      if (check_token (IN))
	expr = parse_expression ();
      else
	{
	  error ("expected 'IN' in FOR control here");
	  expr = error_mark_node;
	}
      if (!ignoring)
	{
	  tree low_bound, high_bound;
	  if (expr && TREE_CODE (expr) == TYPE_DECL)
	    {
	      expr = TREE_TYPE (expr);
	      /* FIXME: expr must be an array or powerset */
	      low_bound = convert (expr, TYPE_MIN_VALUE (expr));
	      high_bound = convert (expr, TYPE_MAX_VALUE (expr));
	    }
	  else
	    {
	      low_bound = expr;
	      high_bound = NULL_TREE;
	    }
	  build_loop_iterator (loop_counter, low_bound,
			       NULL_TREE, high_bound,
			       going_down, 1, 0);
	}
    }
}

/* Matches: '(' <event list> ')' ':'.
   Or; returns NULL_EXPR. */

static tree
parse_delay_case_event_list ()
{
  tree event_list = NULL_TREE;
  tree event;
  if (! check_token (LPRN))
    return NULL_TREE;
  event = parse_expression ();
  if (PEEK_TOKEN () == ')' && PEEK_TOKEN1 () != ':')
    {
      /* Oops. */
      require (RPRN);
      pushback_paren_expr (event);
      return NULL_TREE;
    }
  for (;;)
    {
      if (! ignoring)
	event_list = tree_cons (NULL_TREE, event, event_list);
      if (! check_token (COMMA))
	break;
      event = parse_expression ();
    }
  expect (RPRN, "missing ')'");
  expect (COLON, "missing ':'");
  return ignoring ? error_mark_node : event_list;
}

static void
parse_delay_case_action (label)
     tree label;
{
  tree label_cnt = NULL_TREE, set_location, priority;
  tree combined_event_list = NULL_TREE;
  require (DELAY);
  require (CASE);
  PUSH_ACTION;
  pushlevel (1);
  expand_exit_needed = 0;
  if (check_token (SET))
    {
      set_location = parse_expression ();
      parse_semi_colon ();
    }
  else
    set_location = NULL_TREE;
  if (check_token (PRIORITY))
    {
      priority = parse_expression ();
      parse_semi_colon ();
    }
  else
    priority = NULL_TREE;
  if (! ignoring)
    label_cnt = build_delay_case_start (set_location, priority);
  for (;;)
    {
      tree event_list = parse_delay_case_event_list ();
      if (event_list)
	{
	  if (! ignoring )
	    { 
	      int if_or_elseif = combined_event_list == NULL_TREE;
	      build_delay_case_label (event_list, if_or_elseif);  
	      combined_event_list = chainon (combined_event_list, event_list);
	    }
	}
      else if (parse_action ())
	{
	  if (! ignoring)
	    {
	      expand_exit_needed = 1;
	      if (combined_event_list == NULL_TREE)
		error ("missing DELAY CASE alternative");
	    }
	}
      else
	break;
    }
  expect (ESAC, "missing 'ESAC' in DELAY CASE'");
  if (! ignoring)
    build_delay_case_end (combined_event_list);
  possibly_define_exit_label (label);
  poplevel (0, 0, 0); 
}

static void
parse_do_action (label)
     tree label;
{
  tree condition;
  int token;
  require (DO);
  if (check_token (WITH))
    {
      tree list = NULL_TREE;
      for (;;)
	{
	  tree name = parse_primval ();
	  if (! ignoring && TREE_CODE (name) != ERROR_MARK)
	    {
	      if (TREE_CODE (TREE_TYPE (name)) == REFERENCE_TYPE)
		name = convert (TREE_TYPE (TREE_TYPE (name)), name);
	      else
		{
		  int is_loc = chill_location (name);
		  if (is_loc == 1) /* This is probably not possible */
		    warning ("non-referable location in DO WITH");
		  
		  if (is_loc > 1)
		    name = build_chill_arrow_expr (name, 1);
		  name = decl_temp1 (get_identifier ("__with_element"),
				     TREE_TYPE (name),
				     0, name, 0, 0);
		  if (is_loc > 1)
		    name = build_chill_indirect_ref (name, NULL_TREE, 0);
		  
		}
	      if (TREE_CODE (TREE_TYPE (name)) != RECORD_TYPE)
		error ("WITH element must be of STRUCT mode");
	      else
		list = tree_cons (NULL_TREE, name, list);
	    }
	  if (! check_token (COMMA))
	    break;
	}
      pushlevel (1);
      push_action ();
      for (list = nreverse (list); list != NULL_TREE; list = TREE_CHAIN (list))
	shadow_record_fields (TREE_VALUE (list));

      parse_semi_colon ();
      parse_opt_actions ();
      expect (OD, "missing 'OD' in 'DO WITH'");
      if (! ignoring)
	emit_line_note (input_filename, lineno);
      possibly_define_exit_label (label);
      parse_opt_handler ();
      parse_opt_end_label_semi_colon (label);
      poplevel (0, 0, 0); 
      return;
    }
  token = PEEK_TOKEN();
  if (token != FOR && token != WHILE)
    {
      push_handler ();
      parse_opt_actions ();
      expect (OD, "Missing 'OD' after 'DO'");
      parse_opt_handler ();
      parse_opt_end_label_semi_colon (label);
      return;
    }
  if (! ignoring)
    emit_line_note (input_filename, lineno);
  push_loop_block ();
  if (check_token (FOR))
    {
      if (check_token (EVER))
	{
	  if (!ignoring)
	    build_loop_iterator (NULL_TREE, NULL_TREE,
				 NULL_TREE, NULL_TREE,
				 0, 0, 1);
	}
      else
	{
	  parse_iteration ();
	  while (check_token (COMMA))
	    parse_iteration ();
	}
    }
  else if (!ignoring)
    build_loop_iterator (NULL_TREE, NULL_TREE,
			 NULL_TREE, NULL_TREE,
			 0, 0, 1);
       
  begin_loop_scope ();
  if (! ignoring)
    build_loop_start (label);
  condition = check_token (WHILE) ? parse_expression () : NULL_TREE;
  if (! ignoring)
    top_loop_end_check (condition);
  parse_semi_colon ();
  parse_opt_actions ();
  if (! ignoring)
    build_loop_end (); 
  expect (OD, "Missing 'OD' after 'DO'");
  /* Note that the handler is inside the reach of the DO. */
  parse_opt_handler ();
  end_loop_scope (label);
  pop_loop_block ();
  parse_opt_end_label_semi_colon (label);
}

/* Matches: '(' <signal name> [ 'IN' <defining occurrence list> ']' ')' ':'
   or: '(' <buffer location> IN (defining occurrence> ')' ':'
   or: returns NULL_TREE. */

static tree
parse_receive_spec ()
{
  tree val;
  tree name_list = NULL_TREE;
  if (!check_token (LPRN))
    return NULL_TREE;
  val = parse_primval ();
  if (check_token (IN))
    {
#if 0
      if (flag_local_loop_counter)
	name_list = parse_defining_occurrence_list ();
      else
#endif
	{
	  for (;;)
	    {
	      tree loc = parse_primval ();
	      if (! ignoring)
		name_list = tree_cons (NULL_TREE, loc, name_list);
	      if (! check_token (COMMA))
		break;
	    }
	}
    }
  if (! check_token (RPRN))
    {
      error ("missing ')' in signal/buffer receive alternative");
      return NULL_TREE;
    }
  if (check_token (COLON))
    {
      if (ignoring || val == NULL_TREE || TREE_CODE (val) == ERROR_MARK)
	return error_mark_node;
      else
	return build_receive_case_label (val, name_list);
    }

  /* We saw: '(' <primitive value> ')' not followed by ':'.
     Presumably the start of an action.  Backup and fail. */
  if (name_list != NULL_TREE)
    error ("misplaced 'IN' in signal/buffer receive alternative");
  pushback_paren_expr (val);
  return NULL_TREE;
}

/* To understand the code generation for this, see ch-tasking.c,
   and the 2-page comments preceding the
   build_chill_receive_case_start () definition. */

static void
parse_receive_case_action (label)
     tree label;
{
  tree instance_location;
  tree have_else_actions;
  int spec_seen = 0;
  tree alt_list = NULL_TREE;
  require (RECEIVE);
  require (CASE);
  push_action ();
  pushlevel (1);
  if (! ignoring)
    {
      expand_exit_needed = 0;
    }

  if (check_token (SET))
    {
      instance_location = parse_expression ();
      parse_semi_colon ();
    }
  else
    instance_location = NULL_TREE;
  if (! ignoring)
    instance_location = build_receive_case_start (instance_location);

  for (;;)
    {
      tree receive_spec = parse_receive_spec ();
      if (receive_spec)
	{
	  if (! ignoring)
	    alt_list = tree_cons (NULL_TREE, receive_spec, alt_list);
	  spec_seen++;
	}
      else if (parse_action ())
	{
	  if (! spec_seen && pass == 1)
	    error ("missing RECEIVE alternative");
	  if (! ignoring)
	    expand_exit_needed = 1;
	  spec_seen = 1;
	}
      else
	break;
    }
  if (check_token (ELSE))
    {
      if (! ignoring)
	{
	  emit_line_note (input_filename, lineno); 
	  if (build_receive_case_if_generated ())
	    expand_start_else ();
	}
      parse_opt_actions ();
      have_else_actions = integer_one_node;
    }
  else
    have_else_actions = integer_zero_node;
  expect (ESAC, "missing 'ESAC' matching 'RECEIVE CASE'");
  if (! ignoring)
    {
      build_receive_case_end (nreverse (alt_list), have_else_actions);
    }
  possibly_define_exit_label (label);
  poplevel (0, 0, 0); 
}

static void
parse_send_action ()
{
  tree signal = NULL_TREE;
  tree buffer = NULL_TREE;
  tree value_list;
  tree with_expr, to_expr, priority;
  require (SEND);
  /* The tricky part is distinguishing between a SEND buffer action,
     and a SEND signal action. */
  if (pass != 2 || PEEK_TOKEN () != NAME)
    {
      /* If this is pass 2, it's a SEND buffer action.
	 If it's pass 1, we don't care. */
      buffer = parse_primval ();
    }
  else
    {
      /* We have to specifically check for signalname followed by
	 a '(', since we allow a signalname to be used (syntactically)
	 as a "function". */
      tree name = parse_name ();
      if (TREE_CODE (name) == TYPE_DECL && CH_DECL_SIGNAL (name))
	signal = name; /* It's a SEND signal action! */
      else
	{
	  /* It's not a legal SEND signal action.
	     Back up and try as a SEND buffer action. */
	  pushback_token (EXPR, name);
	  buffer = parse_primval ();
	}
    }
  if (check_token (LPRN))
    {
      value_list = NULL_TREE;
      for (;;)
	{
	  tree expr = parse_untyped_expr ();
	  if (! ignoring)
	    value_list = tree_cons (NULL_TREE, expr, value_list);
	  if (! check_token (COMMA))
	    break;
	}
      value_list = nreverse (value_list);
      expect (RPRN, "missing ')'");
    }
  else
    value_list = NULL_TREE;
  if (check_token (WITH))
    with_expr = parse_expression ();
  else
    with_expr = NULL_TREE;
  if (check_token (TO))
    to_expr = parse_expression ();
  else
    to_expr = NULL_TREE;
  if (check_token (PRIORITY))
    priority = parse_expression ();
  else
    priority = NULL_TREE;
  PUSH_ACTION;
  if (ignoring)
    return;

  if (signal)
    { /* It's a <send signal action>! */
      tree sigdesc = build_signal_descriptor (signal, value_list);
      if (sigdesc != NULL_TREE && TREE_CODE (sigdesc) != ERROR_MARK)
	{
	  tree sendto = to_expr ? to_expr : IDENTIFIER_SIGNAL_DEST (signal);
	  expand_send_signal (sigdesc, with_expr,
			      sendto, priority, DECL_NAME (signal));
	}
    }
  else
    {
      /* all checks are done in expand_send_buffer */
      expand_send_buffer (buffer, value_list, priority, with_expr, to_expr);
    }
}

static void
parse_start_action ()
{
  tree name, copy_number, param_list, startset;
  require (START);
  name = parse_name_string ();
  expect (LPRN, "missing '(' in START action");
  PUSH_ACTION;
  /* copy number is a required parameter */
  copy_number = parse_expression ();
  if (!ignoring
      && (copy_number == NULL_TREE 
	  || TREE_CODE (copy_number) == ERROR_MARK
	  || TREE_CODE (TREE_TYPE (copy_number)) != INTEGER_TYPE))
    {
      error ("PROCESS copy number must be integer");
      copy_number = integer_zero_node;
    }
  if (check_token (COMMA))
    param_list = parse_expr_list (); /* user parameters */
  else
    param_list = NULL_TREE;
  expect (RPRN, "missing ')'");
  startset = check_token (SET) ? parse_primval () : NULL;
  build_start_process (name, copy_number, param_list, startset);
}

static void
parse_opt_actions ()
{
  while (parse_action ()) ;
}

static int
parse_action ()
{
  tree label = NULL_TREE;
  tree expr, rhs, loclist;
  enum tree_code op;

  if (current_function_decl == global_function_decl
      && PEEK_TOKEN () != SC
      && PEEK_TOKEN () != END)
    seen_action = 1, build_constructor = 1;

  if (PEEK_TOKEN () == NAME && PEEK_TOKEN1 () == COLON)
    {
      label = parse_defining_occurrence ();
      require (COLON);
      INIT_ACTION;
      define_label (input_filename, lineno, label);
    }

  switch (PEEK_TOKEN ())
    {
    case AFTER:
      {
	int delay;
	require (AFTER);
	expr = parse_primval ();
	delay = check_token (DELAY);
	expect (IN, "missing 'IN'");
	push_action ();
	pushlevel (1);
	build_after_start (expr, delay);
	parse_opt_actions ();
	expect (TIMEOUT, "missing 'TIMEOUT'");
	build_after_timeout_start ();
	parse_opt_actions ();
	expect (END, "missing 'END'");
	build_after_end ();
	possibly_define_exit_label (label);
	poplevel (0, 0, 0); 
      }
      goto bracketed_action;
    case ASM_KEYWORD:
      parse_asm_action ();
      goto no_handler_action;
    case ASSERT:
      require (ASSERT);
      PUSH_ACTION;
      expr = parse_expression ();
      if (! ignoring)
	{ tree assertfail = ridpointers[(int) RID_ASSERTFAIL];
	  expr = build (TRUTH_ORIF_EXPR, void_type_node, expr,
			build_cause_exception (assertfail, 0));
	  expand_expr_stmt (fold (expr));
	}
      goto handler_action;
    case AT:
      require (AT);
      PUSH_ACTION;
      expr = parse_primval ();
      expect (IN, "missing 'IN'");
      pushlevel (1);
      if (! ignoring)
	build_at_action (expr);
      parse_opt_actions ();
      expect (TIMEOUT, "missing 'TIMEOUT'");
      if (! ignoring)
	expand_start_else ();
      parse_opt_actions ();
      expect (END, "missing 'END'");
      if (! ignoring)
	expand_end_cond ();
      possibly_define_exit_label (label);
      poplevel (0, 0, 0);
      goto bracketed_action;
    case BEGINTOKEN:
      parse_begin_end_block (label);
      return 1;
    case CASE:
      parse_case_action (label);
      goto bracketed_action;
    case CAUSE:
      require (CAUSE);
      expr = parse_name_string ();
      PUSH_ACTION;
      if (! ignoring && TREE_CODE (expr) != ERROR_MARK)
	expand_cause_exception (expr);
      goto no_handler_action;
    case CONTINUE:
      require (CONTINUE);
      expr = parse_expression ();
      PUSH_ACTION;
      if (! ignoring)
	expand_continue_event (expr);
      goto handler_action;
    case CYCLE:
      require (CYCLE);
      PUSH_ACTION;
      expr = parse_primval ();
      expect (IN, "missing 'IN' after 'CYCLE'");
      pushlevel (1);
      /* We a tree list where TREE_VALUE is the label
	 and TREE_PURPOSE is the variable denotes the timeout id. */
      expr = build_cycle_start (expr);
      parse_opt_actions ();
      expect (END, "missing 'END'");
      if (! ignoring)
	build_cycle_end (expr);
      possibly_define_exit_label (label);
      poplevel (0, 0, 0);
      goto bracketed_action;
    case DELAY:
      if (PEEK_TOKEN1 () == CASE)
	{
	  parse_delay_case_action (label);
	  goto bracketed_action;
	}
      require (DELAY);
      PUSH_ACTION;
      expr = parse_primval ();
      rhs = check_token (PRIORITY) ? parse_expression () : NULL_TREE;
      if (! ignoring)
	build_delay_action (expr, rhs);
      goto handler_action;
    case DO:
      parse_do_action (label);
      return 1;
    case EXIT:
      require (EXIT);
      expr = parse_name_string ();
      PUSH_ACTION;
      lookup_and_handle_exit (expr);
      goto no_handler_action;
    case GOTO:
      require (GOTO);
      expr = parse_name_string ();
      PUSH_ACTION;
      lookup_and_expand_goto (expr);
      goto no_handler_action;
    case IF:
      parse_if_action (label);
      goto bracketed_action;
    case RECEIVE:
      if (PEEK_TOKEN1 () != CASE)
	return 0;
      parse_receive_case_action (label);
      goto bracketed_action;
    case RESULT:
      require (RESULT);
      PUSH_ACTION;
      expr = parse_untyped_expr ();
      if (! ignoring)
	chill_expand_result (expr, 1);
      goto handler_action;
    case RETURN:
      require (RETURN);
      PUSH_ACTION;
      expr = parse_opt_untyped_expr ();
      if (! ignoring)
	{
	  /* Do this as RESULT expr and RETURN to get exceptions */
	  chill_expand_result (expr, 0);
	  expand_goto_except_cleanup (proc_action_level);
	  chill_expand_return (NULL_TREE, 0);
	}
      if (expr)
	goto handler_action;
      else
	goto no_handler_action;
    case SC:
      require (SC);
      return 1;
    case SEND:
      parse_send_action ();
      goto handler_action;
    case START:
      parse_start_action ();
      goto handler_action;
    case STOP:
      require (STOP);
      PUSH_ACTION;
      if (! ignoring)
	{ tree func = lookup_name (get_identifier ("__stop_process"));
	  tree result = build_chill_function_call (func, NULL_TREE);
	  expand_expr_stmt (result);
	} 
      goto no_handler_action;
    case CALL:
      require (CALL);
      /* Fall through to here ... */
    case EXPR:
    case LPRN:
    case NAME:
      /* This handles calls and assignments. */
      PUSH_ACTION;
      expr = parse_primval ();
      switch (PEEK_TOKEN ())
	{
	case END:
	  parse_semi_colon ();  /* Emits error message. */
	case ON:
	case SC:
	  if (!ignoring && TREE_CODE (expr) != ERROR_MARK)
	    {
	      if (TREE_CODE (expr) != CALL_EXPR
		  && TREE_TYPE (expr) != void_type_node
		  && ! TREE_SIDE_EFFECTS (expr))
		{
		  if (TREE_CODE (expr) == FUNCTION_DECL)
		    error ("missing parenthesis for procedure call");
		  else
		    error ("expression is not an action");
		  expr = error_mark_node;
		}
	      else
		expand_expr_stmt (expr);
	    }
	  goto handler_action;
	default:
	  loclist
	    = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr);
	  while (PEEK_TOKEN () == COMMA)
	    {
	      FORWARD_TOKEN ();
	      expr = parse_primval ();
	      if (!ignoring && TREE_CODE (expr) != ERROR_MARK)
		loclist = tree_cons (NULL_TREE, expr, loclist);
	    }
	}
      switch (PEEK_TOKEN ())
	{
	case OR:	op = BIT_IOR_EXPR;	break;
	case XOR:	op = BIT_XOR_EXPR;	break;
	case ORIF:	op = TRUTH_ORIF_EXPR;	break;
	case AND:	op = BIT_AND_EXPR;	break;
	case ANDIF:	op = TRUTH_ANDIF_EXPR;	break;
	case PLUS:	op = PLUS_EXPR;		break;
	case SUB:	op = MINUS_EXPR;	break;
	case CONCAT:	op = CONCAT_EXPR;	break;
	case MUL:	op = MULT_EXPR;		break;
	case DIV:	op = TRUNC_DIV_EXPR;	break;
	case MOD:	op = FLOOR_MOD_EXPR;	break;
	case REM:	op = TRUNC_MOD_EXPR;	break;

	default:
	  error ("syntax error in action");
	case SC:  case ON:
	case ASGN:	op = NOP_EXPR;		break;
	  ;
	}

      /* Looks like it was an assignment action. */
      FORWARD_TOKEN ();
      if (op != NOP_EXPR)
	expect (ASGN, "expected ':=' here");
      rhs = parse_untyped_expr ();
      if (!ignoring)
	expand_assignment_action (loclist, op, rhs);
      goto handler_action;

    default:
      return 0;
    }

 bracketed_action:
  /* We've parsed a bracketed action. */
  parse_opt_handler ();
  parse_opt_end_label_semi_colon (label);
  return 1;

 no_handler_action:
  if (parse_opt_handler () != NULL_TREE && pass == 1)
    error ("no handler is permitted on this action.");
  parse_semi_colon ();
  return 1;

 handler_action:
  parse_opt_handler ();
  parse_semi_colon ();
  return 1;
}

static void
parse_body ()
{
 again:
  while (parse_definition (0)) ;

  while (parse_action ()) ;

  if (parse_definition (0))
    {
      if (pass == 1)
	pedwarn ("definition follows action");
      goto again;
    }
}

static tree
parse_opt_untyped_expr ()
{
  switch (PEEK_TOKEN ())
    {
    case ON:
    case END:
    case SC:
    case COMMA:
    case COLON:
    case RPRN:
      return NULL_TREE;
    default:
      return parse_untyped_expr ();
    }
}

static tree
parse_call (function)
     tree function;
{
  tree arg1, arg2, arg_list = NULL_TREE;
  enum terminal tok;
  require (LPRN);
  arg1 = parse_opt_untyped_expr ();
  if (arg1 != NULL_TREE)
    {
      tok = PEEK_TOKEN ();
      if (tok == UP || tok == COLON)
	{
	  FORWARD_TOKEN ();
#if 0
	  /* check that arg1 isn't untyped (or mode);*/
#endif
	  arg2 = parse_expression ();
	  expect (RPRN, "expected ')' to terminate slice");
	  if (ignoring)
	    return integer_zero_node;
	  else if (tok == UP)
	    return build_chill_slice_with_length (function, arg1, arg2);
	  else
	    return build_chill_slice_with_range (function, arg1, arg2);
	}
      if (!ignoring)
	arg_list = build_tree_list (NULL_TREE, arg1);
      while (check_token (COMMA))
	{
	  arg2 = parse_untyped_expr ();
	  if (!ignoring)
	    arg_list = tree_cons (NULL_TREE, arg2, arg_list);
	}
    }
     
  expect (RPRN, "expected ')' here");
  return ignoring ? function
    : build_generalized_call (function, nreverse (arg_list));
}

/* Matches:  <field name list>
   Returns:  A list of IDENTIFIER_NODEs (or NULL_TREE if ignoring),
   in reverse order. */

static tree
parse_tuple_fieldname_list ()
{
  tree list = NULL_TREE;
  do
    {
      tree name;
      if (!check_token (DOT))
	{
	  error ("bad tuple field name list");
	  return NULL_TREE;
	}
      name = parse_simple_name_string ();
      list = ignoring ? NULL_TREE : tree_cons (NULL_TREE, name, list);
    }  while (check_token (COMMA));
  return list;
}

/* Returns one or nore TREE_LIST nodes, in reverse order. */

static tree
parse_tuple_element ()
{
  /* The tupleelement chain is built in reverse order,
     and put in forward order when the list is used.  */
  tree value, label;
  if (PEEK_TOKEN () == DOT)
    {
      /* Parse a labelled structure tuple. */
      tree list = parse_tuple_fieldname_list (), field;
      expect (COLON, "missing ':' in tuple");
      value = parse_untyped_expr ();
      if (ignoring)
	return NULL_TREE;
      /* FIXME:  Should use save_expr(value), but that
	 confuses nested calls to digest_init! */
      /* Re-use the list of field names as a list of name-value pairs. */
      for (field = list; field != NULL_TREE; field = TREE_CHAIN (field))
	{ tree field_name = TREE_VALUE (field);
	  TREE_PURPOSE (field) = field_name;
	  TREE_VALUE (field) = value;
	  TUPLE_NAMED_FIELD (field) = 1;
	}
      return list;
    }

  label = parse_case_label_list (NULL_TREE, 1);
  if (label)
    {
      expect (COLON, "missing ':' in tuple");
      value = parse_untyped_expr ();
      if (ignoring || label == NULL_TREE)
	return NULL_TREE;
      if (TREE_CODE (label) != TREE_LIST)
	{
	  error ("invalid syntax for label in tuple");
	  return NULL_TREE;
	}
      else
	{
	  /* FIXME:  Should use save_expr(value), but that
	     confuses nested calls to digest_init! */
	  tree link = label;
	  for (; link != NULL_TREE; link = TREE_CHAIN (link))
	    { tree index = TREE_VALUE (link);
	      if (pass == 1 && TREE_CODE (index) != TREE_LIST)
		index = build1 (PAREN_EXPR, NULL_TREE, index);
	      TREE_VALUE (link) = value;
	      TREE_PURPOSE (link) = index;
	    }
	  return nreverse (label);
	}
    }
  
  value = parse_untyped_expr ();
  if (check_token (COLON))
    {
      /* A powerset range [or possibly a labeled Array?] */
      tree value2 = parse_untyped_expr ();
      return ignoring ? NULL_TREE : build_tree_list (value, value2);
    }
  return ignoring ? NULL_TREE : build_tree_list (NULL_TREE, value);
}

/* Matches:  a COMMA-separated list of tuple elements.
   Returns a list (of TREE_LIST nodes). */
static tree
parse_opt_element_list ()
{
  tree list = NULL_TREE;
  if (PEEK_TOKEN () == RPC)
    return NULL_TREE;
  for (;;)
    {
      tree element = parse_tuple_element ();
      list = chainon (element, list); /* Built in reverse order */
      if (PEEK_TOKEN () == RPC)
	break;
      if (!check_token (COMMA))
	{
	  error ("bad syntax in tuple");
	  return NULL_TREE;
	}
    }
  return nreverse (list);
}

/* Parses: '[' elements ']'
   If modename is non-NULL it prefixed the tuple.  */

static tree
parse_tuple (modename)
     tree modename;
{
  tree list;
  require (LPC);
  list = parse_opt_element_list ();
  expect (RPC, "missing ']' after tuple");
  if (ignoring)
    return integer_zero_node;
  list =  build_nt (CONSTRUCTOR, NULL_TREE, list);
  if (modename == NULL_TREE)
    return list;
  else if (pass == 1)
    TREE_TYPE (list) = modename;
  else if (TREE_CODE (modename) != TYPE_DECL)
    {
      error ("non-mode name before tuple");
      return error_mark_node;
    }
  else
    list = chill_expand_tuple (TREE_TYPE (modename), list);
  return list;
}

static tree
parse_primval ()
{
  tree val;
  switch (PEEK_TOKEN ())
    {
    case NUMBER:
    case FLOATING:
    case STRING:
    case SINGLECHAR:
    case BITSTRING:
    case CONST:
    case EXPR:
      val = PEEK_TREE();
      FORWARD_TOKEN ();
      break;
    case THIS:
      val = build_chill_function_call (PEEK_TREE (), NULL_TREE);
      FORWARD_TOKEN ();
      break;
    case LPRN:
      FORWARD_TOKEN ();
      val = parse_expression ();
      expect (RPRN, "missing right parenthesis");
      if (pass == 1 && ! ignoring)
	val = build1 (PAREN_EXPR, NULL_TREE, val);
      break;
    case LPC:
      val = parse_tuple (NULL_TREE);
      break;
    case NAME:
      val = parse_name ();
      if (PEEK_TOKEN() == LPC)
	val = parse_tuple (val); /* Matched:  <mode_name> <tuple> */
      break;
    default: 
      if (!ignoring)
	error ("invalid expression/location syntax");
      val = error_mark_node;
    }
  for (;;)
    {
      tree name, args;
      switch (PEEK_TOKEN ())
	{
	case DOT:
	  FORWARD_TOKEN ();
	  name = parse_simple_name_string ();
	  val = ignoring ? val : build_chill_component_ref (val, name);
	  continue;
	case ARROW:
	  FORWARD_TOKEN ();
	  name = parse_opt_name_string (0);
	  val = ignoring ? val : build_chill_indirect_ref (val, name, 1);
	  continue;
	case LPRN:
	  /* The SEND buffer action syntax is ambiguous, at least when
	     parsed left-to-right.  In the example 'SEND foo(v) ...' the
	     phrase 'foo(v)' could be a buffer location procedure call
	     (which then must be followed by the value to send).
	     On the other hand, if 'foo' is a buffer, stop parsing
	     after 'foo', and let parse_send_action pick up '(v) as
	     the value ot send.

	     We handle the ambiguity for SEND signal action differently,
	     since we allow (as an extension) a signal to be used as
	     a "function" (see build_generalized_call). */
	  if (TREE_TYPE (val) != NULL_TREE
	      && CH_IS_BUFFER_MODE (TREE_TYPE (val)))
	    return val;
	  val = parse_call (val);
	  continue;
	case STRING:
	case BITSTRING:
	case SINGLECHAR:
	case NAME:
	  /* Handle string repetition. (See comment in parse_operand5.) */
	  args = parse_primval ();
	  val = ignoring ? val : build_generalized_call (val, args);
	  continue;
	default:
	  break;
	}
      break;
    }
  return val;
}

static tree
parse_operand6 ()
{
  if (check_token (RECEIVE))
    {
      tree location ATTRIBUTE_UNUSED = parse_primval ();
      sorry ("RECEIVE expression");
      return integer_one_node;
    }
  else if (check_token (ARROW))
    {
      tree location = parse_primval ();
      return ignoring ? location : build_chill_arrow_expr (location, 0);
    }
  else
    return parse_primval();
}

static tree
parse_operand5()
{
  enum tree_code op;
  /* We are supposed to be looking for a <string repetition operator>,
     but in general we can't distinguish that from a parenthesized
     expression.  This is especially difficult if we allow the
     string operand to be a constant expression (as requested by
     some users), and not just a string literal.
     Consider:  LPRN expr RPRN LPRN expr RPRN
     Is that a function call or string repetition?
     Instead, we handle string repetition in parse_primval,
     and build_generalized_call. */
  tree rarg;
  switch (PEEK_TOKEN())
    {
    case NOT:  op = BIT_NOT_EXPR; break;
    case SUB:  op = NEGATE_EXPR; break;
    default:
      op = NOP_EXPR;
    }
    if (op != NOP_EXPR)
      FORWARD_TOKEN();
    rarg = parse_operand6();
    return (op == NOP_EXPR || ignoring) ? rarg
      : build_chill_unary_op (op, rarg);
}

static tree
parse_operand4 ()
{
  tree larg = parse_operand5(), rarg;
  enum tree_code op;
  for (;;)
    {
      switch (PEEK_TOKEN())
	{
	case MUL:  op = MULT_EXPR; break;
	case DIV:  op = TRUNC_DIV_EXPR; break;
	case MOD:  op = FLOOR_MOD_EXPR; break;
	case REM:  op = TRUNC_MOD_EXPR; break;
	default:
	return larg;
	}
      FORWARD_TOKEN();
      rarg = parse_operand5();
      if (!ignoring)
	larg = build_chill_binary_op (op, larg, rarg);
    }
}

static tree
parse_operand3 ()
{
  tree larg = parse_operand4 (), rarg;
  enum tree_code op;
  for (;;)
    {
      switch (PEEK_TOKEN())
	{
	case PLUS:   op = PLUS_EXPR; break;
	case SUB:    op = MINUS_EXPR; break;
	case CONCAT: op = CONCAT_EXPR; break;
	default:
	return larg;
	}
      FORWARD_TOKEN();
      rarg = parse_operand4();
      if (!ignoring)
	larg = build_chill_binary_op (op, larg, rarg);
    }
}

static tree
parse_operand2 ()
{
  tree larg = parse_operand3 (), rarg;
  enum tree_code op;
  for (;;)
    {
      if (check_token (IN))
	{
	  rarg = parse_operand3();
	  if (! ignoring)
	    larg = build_chill_binary_op (SET_IN_EXPR, larg, rarg);
	}
      else
	{
	  switch (PEEK_TOKEN())
	    {
	    case GT:  op = GT_EXPR; break;
	    case GTE: op = GE_EXPR; break;
	    case LT:  op = LT_EXPR; break;
	    case LTE: op = LE_EXPR; break;
	    case EQL: op = EQ_EXPR; break;
	    case NE:  op = NE_EXPR; break;
	    default:
	      return larg;
	    }
	  FORWARD_TOKEN();
	  rarg = parse_operand3();
	  if (!ignoring)
	    larg = build_compare_expr (op, larg, rarg);
	}
    }
}

static tree
parse_operand1 ()
{
  tree larg = parse_operand2 (), rarg;
  enum tree_code op;
  for (;;)
    {
      switch (PEEK_TOKEN())
	{
	case AND:   op = BIT_AND_EXPR; break;
	case ANDIF: op = TRUTH_ANDIF_EXPR; break;
	default:
	  return larg;
	}
      FORWARD_TOKEN();
      rarg = parse_operand2();
      if (!ignoring)
	larg = build_chill_binary_op (op, larg, rarg);
    }
}

static tree
parse_operand0 ()
{
  tree larg = parse_operand1(), rarg;
  enum tree_code op;
  for (;;)
    {
      switch (PEEK_TOKEN())
	{
	case OR:  op = BIT_IOR_EXPR; break;
	case XOR:  op = BIT_XOR_EXPR; break;
	case ORIF:  op = TRUTH_ORIF_EXPR; break;
	default:
	  return larg;
	}
      FORWARD_TOKEN();
      rarg = parse_operand1();
      if (!ignoring)
	larg = build_chill_binary_op (op, larg, rarg);
    }
}

static tree
parse_expression ()
{
    return parse_operand0 ();
}

static tree
parse_case_expression ()
{
  tree selector_list;
  tree else_expr;
  tree case_expr;
  tree case_alt_list = NULL_TREE;

  require (CASE);
  selector_list = parse_expr_list ();
  selector_list = nreverse (selector_list);

  expect (OF, "missing 'OF'");
  while (PEEK_TOKEN () == LPRN)
    {
      tree label_spec = parse_case_label_specification (selector_list);
      tree sub_expr;
      expect (COLON, "missing ':' in value case alternative");
      sub_expr = parse_expression ();
      expect (SC, "missing ';'");
      if (! ignoring)
	case_alt_list = tree_cons (label_spec, sub_expr, case_alt_list);
    }
  if (check_token (ELSE))
    {
      else_expr = parse_expression ();
      if (check_token (SC) && pass == 1)
	warning("there should not be a ';' here"); 
    }
  else
    else_expr = NULL_TREE;
  expect (ESAC, "missing 'ESAC' in 'CASE' expression");

  if (ignoring)
    return integer_zero_node;

  /* If this is a multi dimension case, then transform it into an COND_EXPR
     here. This must be done before store_expr is called since it has some
     special handling for COND_EXPR expressions. */
  if (TREE_CHAIN (selector_list) != NULL_TREE)
    {
      case_alt_list = nreverse (case_alt_list);
      compute_else_ranges (selector_list, case_alt_list);
      case_expr =
	build_chill_multi_dimension_case_expr (selector_list, case_alt_list, else_expr);
    }
  else
    case_expr = build_chill_case_expr (selector_list, case_alt_list, else_expr);

  return case_expr;
}

static tree
parse_then_alternative ()
{
  expect (THEN, "missing 'THEN' in 'IF' expression");
  return parse_expression ();
}

static tree
parse_else_alternative ()
{
  if (check_token (ELSIF))
    return parse_if_expression_body ();
  else if (check_token (ELSE))
    return parse_expression ();
  error ("missing ELSE/ELSIF in IF expression");
  return error_mark_node;
}

/* Matches: <boolean expression> <then alternative> <else alternative> */

static tree
parse_if_expression_body ()
{
  tree bool_expr, then_expr, else_expr;
  bool_expr = parse_expression ();
  then_expr = parse_then_alternative ();
  else_expr = parse_else_alternative ();
  if (ignoring)
    return integer_zero_node;
  else
    return build_nt (COND_EXPR, bool_expr, then_expr, else_expr);
}

static tree
parse_if_expression ()
{
  tree expr;
  require (IF);
  expr = parse_if_expression_body ();
  expect (FI, "missing 'FI' at end of conditional expression");
  return expr;
}

/* An <untyped_expr> is a superset of <expr>.  It also includes
   <conditional expressions> and untyped <tuples>, whose types
   are not given by their constituents.  Hence, these are only
   allowed in certain contexts that expect a certain type.
   You should call convert() to fix up the <untyped_expr>. */

static tree
parse_untyped_expr ()
{
  tree val;
  switch (PEEK_TOKEN())
    {
    case IF:
      return parse_if_expression ();
    case CASE:
      return parse_case_expression ();
    case LPRN:
      switch (PEEK_TOKEN1())
	{
	case IF:
	case CASE:
	  if (pass == 1)
	    pedwarn ("conditional expression not allowed inside parentheses");
	  goto skip_lprn;
	case LPC:
	  if (pass == 1)
	    pedwarn ("mode-less tuple not allowed inside parentheses");
	skip_lprn:
	  FORWARD_TOKEN ();
	  val = parse_untyped_expr ();
	  expect (RPRN, "missing ')'");
	  return val;
	default: ;
	  /* fall through */
	}
    default:
      return parse_operand0 ();
    }
}

/* Matches:  <index mode> */

static tree
parse_index_mode ()
{
  /* This is another one that is nasty to parse!
   Let's feel our way ahead ... */
  tree lower, upper;
  if (PEEK_TOKEN () == NAME)
    {
      tree name = parse_name ();
      switch (PEEK_TOKEN ())
	{
	case COMMA:
	case RPRN:
	case SC: /* An error */
	  /* This can only (legally) be a discrete mode name. */
	  return name;
	case LPRN:
	  /* This could be named discrete range,
	     a cast, or some other expression (maybe). */
	  require (LPRN);
	  lower = parse_expression ();
	  if (check_token (COLON))
	    {
	      upper = parse_expression ();
	      expect (RPRN, "missing ')'");
	      /* Matched: <mode_name> '(' <expr> ':' <expr> ')' */
	      if (ignoring)
		return NULL_TREE;
	      else
		return build_chill_range_type (name, lower, upper);
	    }
	  /* Looks like a cast or procedure call or something.
	     Backup, and try again. */
	  pushback_token (EXPR, lower);
	  pushback_token (LPRN, NULL_TREE);
	  lower = parse_call (name);
	  goto parse_literal_range_colon;
	default:
	  /* This has to be the start of an expression. */
	  pushback_token (EXPR, name);
	  goto parse_literal_range;
	}
    }
  /* It's not a name.  But it could still be a discrete mode. */
  lower = parse_opt_mode ();
  if (lower)
    return lower;
 parse_literal_range:
  /* Nope, it's a discrete literal range. */
  lower = parse_expression ();
 parse_literal_range_colon:
  expect (COLON, "expected ':' here");
  
  upper = parse_expression ();
  return ignoring ? NULL_TREE
    : build_chill_range_type (NULL_TREE, lower, upper);
}

static tree
parse_set_mode ()
{
  int  set_name_cnt = 0;          /* count of named set elements */
  int  set_is_numbered = 0;     /* TRUE if set elements have explicit values */
  int  set_is_not_numbered = 0;
  tree list = NULL_TREE;
  tree mode = ignoring ? void_type_node : start_enum (NULL_TREE);
  require (SET);
  expect (LPRN, "missing left parenthesis after SET");
  for (;;)
    {
      tree name, value = NULL_TREE;
      if (check_token (MUL))
	name = NULL_TREE;
      else
	{
	  name = parse_defining_occurrence ();
	  if (check_token (EQL))
	    {
	      value = parse_expression ();
	      set_is_numbered = 1;
	    }
	  else
	    set_is_not_numbered = 1;
	  set_name_cnt++;
	}
      name = build_enumerator (name, value);
      if (pass == 1)
	list = chainon (name, list);
      if (! check_token (COMMA))
	break;
    }
  expect (RPRN, "missing right parenthesis after SET");
  if (!ignoring)
    {
      if (set_is_numbered && set_is_not_numbered)
	/* Z.200 doesn't allow mixed numbered and unnumbered set elements,
	   but we can do it. Print a warning */
	pedwarn ("mixed numbered and unnumbered set elements is not standard");
      mode = finish_enum (mode, list); 
      if (set_name_cnt == 0)
	error ("SET mode must define at least one named value");
      CH_ENUM_IS_NUMBERED(mode) = set_is_numbered ? 1 : 0;
    }
  return mode;
}

/* parse layout POS:
   returns a tree with following layout

                treelist
       pupose=treelist  value=NULL_TREE (to indicate POS)
     pupose=word  value=treelist | NULL_TREE
           pupose=startbit  value=treelist | NULL_TREE
                      purpose=                      value=
               integer_zero | integer_one    length | endbit
*/
static tree
parse_pos ()
{
  tree word;
  tree startbit = NULL_TREE, endbit = NULL_TREE;
  tree what = NULL_TREE;
  
  require (LPRN);
  word = parse_untyped_expr ();
  if (check_token (COMMA))
    {
      startbit = parse_untyped_expr ();
      if (check_token (COMMA))
	{
	  what = integer_zero_node;
	  endbit = parse_untyped_expr ();
	}
      else if (check_token (COLON))
	{
	  what = integer_one_node;
	  endbit = parse_untyped_expr ();
	}
    }
  require (RPRN);
  
  /* build the tree as described above */
  if (what != NULL_TREE)
    what = tree_cons (what, endbit, NULL_TREE);
  if (startbit != NULL_TREE)
    startbit = tree_cons (startbit, what, NULL_TREE);
  endbit = tree_cons (word, startbit, NULL_TREE);
  return tree_cons (endbit, NULL_TREE, NULL_TREE);
}

/* parse layout STEP
   returns a tree with the following layout

                treelist
     pupose=NULL_TREE value=treelist (to indicate STEP)
         pupose=POS(see baove)  value=stepsize | NULL_TREE
*/
static tree
parse_step ()
{
  tree pos;
  tree stepsize = NULL_TREE;
  
  require (LPRN);
  require (POS);
  pos = parse_pos ();
  if (check_token (COMMA))
    stepsize = parse_untyped_expr ();
  require (RPRN);
  TREE_VALUE (pos) = stepsize;
  return tree_cons (NULL_TREE, pos, NULL_TREE);
}

/* returns layout for fields or array elements.
   NULL_TREE            no layout specified
   integer_one_node     PACK specified
   integer_zero_node    NOPACK specified
   tree_list PURPOSE    POS
   tree_list VALUE      STEP
*/
static tree
parse_opt_layout (in)
     int in;     /* 0 ... parse structure, 1 ... parse array */
{
  tree val = NULL_TREE;

  if (check_token (PACK))
    {
      return integer_one_node;
    }
  else if (check_token (NOPACK))
    {
      return integer_zero_node;
    }
  else if (check_token (POS))
    {
      val = parse_pos ();
      if (in == 1 && pass == 1)
	{
	  error ("POS not allowed for ARRAY");
	  val = NULL_TREE;
	}
      return val;
    }
  else if (check_token (STEP))
    {
      val = parse_step ();
      if (in == 0 && pass == 1)
	{
	  error ("STEP not allowed in field definition");
	  val = NULL_TREE;
	}
      return val;
    }
  else
    return NULL_TREE;
}

static tree
parse_field_name_list ()
{
  tree chain = NULL_TREE;
  tree name = parse_defining_occurrence ();
  if (name == NULL_TREE)
    {
      error("missing field name");
      return NULL_TREE;
    }
  chain = build_tree_list (NULL_TREE, name);
  while (check_token (COMMA))
    {
      name = parse_defining_occurrence ();
      if (name == NULL)
	{
	  error ("bad field name following ','");
	  break;
	}
      if (! ignoring)
	chain = tree_cons (NULL_TREE, name, chain);
    }
  return chain;
}

/* Matches: <fixed field> or <variant field>, i.e.:
   <field name defining occurrence list> <mode> [ <field layout> ].
   Returns:  A chain of FIELD_DECLs.
   NULL_TREE is returned if ignoring is true or an error is seen. */

static tree
parse_fixed_field ()
{
  tree field_names = parse_field_name_list ();
  tree mode = parse_mode ();
  tree layout = parse_opt_layout (0);
  return ignoring ? NULL_TREE
    : grok_chill_fixedfields (field_names, mode, layout);
}


/* Matches: [ <variant field> { "," <variant field> }* ]
   Returns:  A chain of FIELD_DECLs.
   NULL_TREE is returned if ignoring is true or an error is seen. */

static tree
parse_variant_field_list ()
{
  tree fields = NULL_TREE;
  if (PEEK_TOKEN () != NAME)
    return NULL_TREE;
  for (;;)
    {
      fields = chainon (fields, parse_fixed_field ());
      if (PEEK_TOKEN () != COMMA || PEEK_TOKEN1 () != NAME)
	break;
      require (COMMA);
    }
  return fields;
}

/* Matches: <variant alternative>
   Returns a TREE_LIST node, whose TREE_PURPOSE (if non-NULL) is the label,
   and whose TREE_VALUE is the list of FIELD_DECLs. */

static tree
parse_variant_alternative ()
{
  tree labels;

  if (PEEK_TOKEN () == LPRN)
    labels = parse_case_label_specification (NULL_TREE);
  else
    labels = NULL_TREE;
  if (! check_token (COLON))
    {
      error ("expected ':' in structure variant alternative");
      return NULL_TREE;
    }

  /* We now read a list a variant fields, until we come to the end
     of the variant alternative.  But since both variant fields
     *and* variant alternatives are separated by COMMAs,
     we will have to look ahead to distinguish the start of a variant
     field from the start of a new variant alternative.
     We use the fact that a variant alternative must start with
     either a LPRN or a COLON, while a variant field must start with a NAME.
     This look-ahead is handled by parse_simple_fields. */
  return build_tree_list (labels, parse_variant_field_list ());
}

/* Parse <field> (which is <fixed field> or <alternative field>).
   Returns:  A chain of FIELD_DECLs (or NULL_TREE on error or if ignoring). */

static tree
parse_field ()
{
  if (check_token (CASE))
    {
      tree tag_list = NULL_TREE, variants, opt_variant_else;
      if (PEEK_TOKEN () == NAME)
	{
	  tag_list = nreverse (parse_field_name_list ());
	  if (pass == 1)
	    tag_list = lookup_tag_fields (tag_list, current_fieldlist);
	}
      expect (OF, "missing 'OF' in alternative structure field");

      variants = parse_variant_alternative ();
      while (check_token (COMMA))
	variants = chainon (parse_variant_alternative (), variants);
      variants = nreverse (variants);

      if (check_token (ELSE))
	opt_variant_else = parse_variant_field_list ();
      else
	opt_variant_else = NULL_TREE;
      expect (ESAC, "missing 'ESAC' following alternative structure field");
      if (ignoring)
	return NULL_TREE;
      return grok_chill_variantdefs (tag_list, variants, opt_variant_else);
    }
  else if (PEEK_TOKEN () == NAME)
    return parse_fixed_field ();
  else
    {
      if (pass == 1)
	error ("missing field");
      return NULL_TREE;
    }
}

static tree
parse_structure_mode ()
{
  tree save_fieldlist = current_fieldlist;
  tree fields;
  require (STRUCT);
  expect (LPRN, "expected '(' after STRUCT");
  current_fieldlist = fields = parse_field ();
  while (check_token (COMMA))
    fields = chainon (fields, parse_field ());
  expect (RPRN, "expected ')' after STRUCT");
  current_fieldlist = save_fieldlist;
  return ignoring ? void_type_node : build_chill_struct_type (fields);
}

static tree
parse_opt_queue_size ()
{
  if (check_token (LPRN))
    {
      tree size = parse_expression ();
      expect (RPRN, "missing ')'");
      return size;
    }
  else
    return NULL_TREE;
}

static tree
parse_procedure_mode ()
{
  tree param_types = NULL_TREE, result_spec, except_list, recursive;
  require (PROC);
  expect (LPRN, "missing '(' after PROC");
  if (! check_token (RPRN))
    {
      for (;;)
	{
	  tree pmode = parse_mode ();
	  tree paramattr = parse_param_attr ();
	  if (! ignoring)
	    {
	      pmode = get_type_of (pmode);
	      param_types = tree_cons (paramattr, pmode, param_types);
	    }
	  if (! check_token (COMMA))
	    break;
	}
      expect (RPRN, "missing ')' after PROC");
    }
  result_spec = parse_opt_result_spec ();
  except_list = parse_opt_except ();
  recursive = parse_opt_recursive ();
  if (ignoring)
    return void_type_node;
  return build_chill_pointer_type (build_chill_function_type
				   (result_spec, nreverse (param_types),
				    except_list, recursive));
}

/* Matches: <mode>
   A NAME will be assumed to be a <mode name>, and thus a <mode>.
   Returns NULL_TREE if no mode is seen.
   (If ignoring is true, the return value may be an arbitrary tree node,
   but will be non-NULL if something that could be a mode is seen.) */

static tree
parse_opt_mode ()
{
  switch (PEEK_TOKEN ())
    {
    case ACCESS:
      {
	tree index_mode, record_mode;
	int dynamic = 0;
	require (ACCESS);
	if (check_token (LPRN))
	  {
	    index_mode = parse_index_mode ();
	    expect (RPRN, "mssing ')'");
	  }
	else
	  index_mode = NULL_TREE;
	record_mode = parse_opt_mode ();
	if (record_mode)
	  dynamic = check_token (DYNAMIC);
	return ignoring ? void_type_node
	                : build_access_mode (index_mode, record_mode, dynamic);
      }
    case ARRAY:
      {
	tree index_list = NULL_TREE, base_mode;
	int varying;
	int num_index_modes = 0;
	int i;
	tree layouts = NULL_TREE;
	FORWARD_TOKEN ();
	expect (LPRN, "missing '(' after ARRAY");
	for (;;)
	  {
	    tree index = parse_index_mode ();
	    num_index_modes++;
	    if (!ignoring)
	      index_list = tree_cons (NULL_TREE, index, index_list);
	    if (! check_token (COMMA))
	      break;
	  }
	expect (RPRN, "missing ')' after ARRAY");
	varying = check_token (VARYING);
	base_mode = parse_mode ();
	/* Allow a layout specification for each index mode */
	for (i = 0; i < num_index_modes; ++i)
	  {
	  tree new_layout = parse_opt_layout (1);
	  if (new_layout == NULL_TREE)
	    break;
	  if (!ignoring)
	    layouts = tree_cons (NULL_TREE, new_layout, layouts);
	  }
	if (ignoring)
	  return base_mode;
	return build_chill_array_type (get_type_of (base_mode),
				       index_list, varying, layouts);
      }
    case ASSOCIATION:
      require (ASSOCIATION);
      return association_type_node;
    case BIN:
      { tree length;
	FORWARD_TOKEN();
	expect (LPRN, "missing left parenthesis after BIN");
	length = parse_expression ();
	expect (RPRN, "missing right parenthesis after BIN");
	return ignoring ? void_type_node :  build_chill_bin_type (length);
      } 
    case BOOLS:
      {
	tree length;
	FORWARD_TOKEN ();
	expect (LPRN, "missing '(' after BOOLS");
	length = parse_expression ();
	expect (RPRN, "missing ')' after BOOLS");
	if (check_token (VARYING))
	  error ("VARYING bit-strings not implemented");
	return ignoring ? void_type_node : build_bitstring_type (length);
      }
    case BUFFER:
      {
	tree qsize, element_mode;
	require (BUFFER);
	qsize = parse_opt_queue_size ();
	element_mode = parse_mode ();
	return ignoring ? element_mode
	  : build_buffer_type (element_mode, qsize);
      }
    case CHARS:
      {
	tree length;
	int varying;
	tree type;
	FORWARD_TOKEN ();
	expect (LPRN, "missing '(' after CHARS");
	length = parse_expression ();
	expect (RPRN, "missing ')' after CHARS");
	varying = check_token (VARYING);
	if (ignoring)
	  return void_type_node;
	type = build_string_type (char_type_node, length);
	if (varying)
	  type = build_varying_struct (type);
	return type;
      }
    case EVENT:
      {
	tree qsize;
	require (EVENT);
	qsize = parse_opt_queue_size ();
	return ignoring ? void_type_node : build_event_type (qsize);
      }
    case NAME:
      {
	tree mode = get_type_of (parse_name ());
	if (check_token (LPRN))
	  {
	    tree min_value = parse_expression ();
	    if (check_token (COLON))
	      {
		tree max_value = parse_expression ();
		expect (RPRN, "syntax error - expected ')'");
		/* Matched: <mode_name> '(' <expr> ':' <expr> ')' */
		if (ignoring)
		  return mode;
		else
		  return build_chill_range_type (mode, min_value, max_value);
	      }
	    if (check_token (RPRN))
	      {
		int varying = check_token (VARYING);
		if (! ignoring)
		  {
		    if (mode == char_type_node || varying)
		      {
			if (mode != char_type_node
			    && mode != ridpointers[(int) RID_CHAR])
			  error ("strings must be composed of chars");
			mode = build_string_type (char_type_node, min_value);
			if (varying)
			  mode  = build_varying_struct (mode);
		      }
		    else
		      {
			/* Parameterized mode,
			   or old-fashioned CHAR(N) string declaration.. */
			tree pmode = make_node (LANG_TYPE);
			TREE_TYPE (pmode) = mode;
			TYPE_DOMAIN (pmode) = min_value;
			mode = pmode;
		      }
		  }
	      }
	  }
	return mode;
      }
    case POWERSET:
      { tree mode;
	FORWARD_TOKEN ();
	mode = parse_mode ();
	 if (ignoring || TREE_CODE (mode) == ERROR_MARK)
	   return mode;
	return build_powerset_type (get_type_of (mode)); 
      }
    case PROC:
      return parse_procedure_mode ();
    case RANGE:
      { tree low, high;
	FORWARD_TOKEN();
	expect (LPRN, "missing left parenthesis after RANGE");
	low = parse_expression ();
	expect (COLON, "missing colon");
	high = parse_expression ();
	expect (RPRN, "missing right parenthesis after RANGE");
	return ignoring ? void_type_node
	  :  build_chill_range_type (NULL_TREE, low, high);
      }
    case READ:
	FORWARD_TOKEN ();
	{
	  tree mode2 = get_type_of (parse_mode ());
	  if (ignoring || TREE_CODE (mode2) == ERROR_MARK)
	    return mode2;
	  if (mode2
	      && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd'
	      && CH_IS_BUFFER_MODE (mode2))
	    {
	      error ("BUFFER modes may not be readonly");
	      return mode2;
	    }
	  if (mode2
	      && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd'
	      && CH_IS_EVENT_MODE (mode2))
	    {
	      error ("EVENT modes may not be readonly");
	      return mode2;
	    }
	  return build_readonly_type (mode2);

      }
    case REF:
      { tree mode;
	FORWARD_TOKEN ();
	mode = parse_mode ();
	 if (ignoring)
	   return mode;
	mode = get_type_of (mode);
	return (TREE_CODE (mode) == ERROR_MARK) ? mode
	  : build_chill_pointer_type (mode); 
      }
    case SET:
      return parse_set_mode ();
    case SIGNAL:
      if (pedantic)
	error ("SIGNAL is not a valid mode");
      return generic_signal_type_node; 
    case STRUCT:
      return parse_structure_mode ();
    case TEXT:
      {
	tree length, index_mode;
	int dynamic;
	require (TEXT);
	expect (LPRN, "missing '('");
	length = parse_expression ();
	expect (RPRN, "missing ')'");
	/* FIXME:  This should actually look for an optional index_mode,
	   but that is tricky to do. */
	index_mode = parse_opt_mode ();
	dynamic = check_token (DYNAMIC);
	return ignoring ? void_type_node
	                : build_text_mode (length, index_mode, dynamic);
      }
    case USAGE:
      require (USAGE);
      return usage_type_node;
    case WHERE:
      require (WHERE);
      return where_type_node;
    default:
      return NULL_TREE; 
    }
}

static tree
parse_mode ()
{
 tree mode = parse_opt_mode ();
 if (mode == NULL_TREE)
   {
     if (pass == 1)
       error ("syntax error - missing mode");
     mode = error_mark_node;
   }
 return mode;
}

static void
parse_program()
{
  /* Initialize global variables for current pass. */
  int i;
  expand_exit_needed = 0;
  label = NULL_TREE;             /* for statement labels */
  current_module = NULL;
  current_function_decl = NULL_TREE;
  in_pseudo_module = 0;
  
  for (i = 0; i <= MAX_LOOK_AHEAD; i++)
    terminal_buffer[i] = TOKEN_NOT_READ;

#if 0
  /* skip some junk */
  while (PEEK_TOKEN() == HEADEREL)
    FORWARD_TOKEN();
#endif

  start_outer_function ();

  for (;;)
    {
      tree label = parse_optlabel ();
      if (PEEK_TOKEN() == MODULE || PEEK_TOKEN() == REGION)
	parse_modulion (label);
      else if (PEEK_TOKEN() == SPEC)
	parse_spec_module (label);
      else break;
    }

  finish_outer_function ();
}

void
parse_pass_1_2()
{
  parse_program();
  if (PEEK_TOKEN() != END_PASS_1)
    {
      error ("syntax error - expected a module or end of file");
      serious_errors++;
    }
  chill_finish_compile ();
  if (serious_errors)
    exit (FATAL_EXIT_CODE);
  switch_to_pass_2 ();
  ch_parse_init ();
  except_init_pass_2 ();
  ignoring = 0;
  parse_program();
  chill_finish_compile ();
}

int yyparse ()
{
  parse_pass_1_2 ();
  return 0;
}

/*
 * We've had an error.  Move the compiler's state back to
 * the global binding level.  This prevents the loop in
 * compile_file in toplev.c from looping forever, since the 
 * CHILL poplevel() has *no* effect on the value returned by 
 * global_bindings_p().
 */
void
to_global_binding_level ()
{
  while (! global_bindings_p ())
    current_function_decl = DECL_CONTEXT (current_function_decl);
  serious_errors++;
}

#if 1
int yydebug;
/* Sets the value of the 'yydebug' variable to VALUE.
   This is a function so we don't have to have YYDEBUG defined
   in order to build the compiler.  */
void
set_yydebug (value)
     int value;
{
#if YYDEBUG != 0
  yydebug = value;
#else
  warning ("YYDEBUG not defined.");
#endif
}
#endif