* sh.c (prepare_move_operand): Check if operand 0 is an invalid

[official-gcc.git] / gcc / f / stc.c

/* stc.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996, 1997, 2003 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran 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 Fortran 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 Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

   Related Modules:
      st.c

   Description:
      Verifies the proper semantics for statements, checking expressions already
      semantically analyzed individually, collectively, checking label defs and
      refs, and so on.  Uses ffebad to indicate errors in semantics.

      In many cases, both a token and a keyword (ffestrFirst, ffestrSecond,
      or ffestrOther) is provided.  ONLY USE THE TOKEN as a pointer to the
      source-code location for an error message or similar; use the keyword
      as the semantic matching for the token, since the token's text might
      not match the keyword's code.  For example, INTENT(IN OUT) A in free
      source form passes to ffestc_R519_start the token "IN" but the keyword
      FFESTR_otherINOUT, and the latter is correct.

      Generally, either a single ffestc function handles an entire statement,
      in which case its name is ffestc_xyz_, or more than one function is
      needed, in which case its names are ffestc_xyz_start_,
      ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_.
      The caller must call _start_ before calling any _item_ functions, and
      must call _finish_ afterwards.  If it is clearly a syntactic matter as
      to restrictions on the number and variety of _item_ calls, then the caller
      should report any errors and ffestc_ should presume it has been taken
      care of and handle any semantic problems with grace and no error messages.
      If the permitted number and variety of _item_ calls has some basis in
      semantics, then the caller should not generate any messages and ffestc
      should do all the checking.

      A few ffestc functions have names rather than grammar numbers, like
      ffestc_elsewhere and ffestc_end.  These are cases where the actual
      statement depends on its context rather than just its form; ELSE WHERE
      may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little
      more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE).  The actual
      ffestc functions do exist and do work, but may or may not be invoked
      by ffestb depending on whether some form of resolution is possible.
      For example, ffestc_R1103 end-program-stmt is reachable directly when
      END PROGRAM [name] is specified, or via ffestc_end when END is specified
      and the context is a main program.  So ffestc_xyz_ should make a quick
      determination of the context and pick the appropriate ffestc_Nxyz_
      function to invoke, without a lot of ceremony.

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "stc.h"
#include "bad.h"
#include "bld.h"
#include "data.h"
#include "expr.h"
#include "global.h"
#include "implic.h"
#include "lex.h"
#include "malloc.h"
#include "src.h"
#include "sta.h"
#include "std.h"
#include "stp.h"
#include "str.h"
#include "stt.h"
#include "stw.h"

/* Externals defined here. */

ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
/* Valid only from READ/WRITE start to finish. */

/* Simple definitions and enumerations. */

typedef enum
  {
    FFESTC_orderOK_,            /* Statement ok in this context, process. */
    FFESTC_orderBAD_,           /* Statement not ok in this context, don't
                                   process. */
    FFESTC_orderBADOK_,         /* Don't process but push block if
                                   applicable. */
    FFESTC
  } ffestcOrder_;

typedef enum
  {
    FFESTC_stateletSIMPLE_,     /* Expecting simple/start. */
    FFESTC_stateletATTRIB_,     /* Expecting attrib/item/itemstart. */
    FFESTC_stateletITEM_,       /* Expecting item/itemstart/finish. */
    FFESTC_stateletITEMVALS_,   /* Expecting itemvalue/itemendvals. */
    FFESTC_
  } ffestcStatelet_;

/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */

union ffestc_local_u_
  {
    struct
      {
        ffebld initlist;        /* For list of one sym in INTEGER I/3/ case. */
        ffetargetCharacterSize stmt_size;
        ffetargetCharacterSize size;
        ffeinfoBasictype basic_type;
        ffeinfoKindtype stmt_kind_type;
        ffeinfoKindtype kind_type;
        bool per_var_kind_ok;
        char is_R426;           /* 1=R426, 2=R501. */
      }
    decl;
    struct
      {
        ffebld objlist;         /* For list of target objects. */
        ffebldListBottom list_bottom;   /* For building lists. */
      }
    data;
    struct
      {
        ffebldListBottom list_bottom;   /* For building lists. */
        int entry_num;
      }
    dummy;
    struct
      {
        ffesymbol symbol;       /* NML symbol. */
      }
    namelist;
    struct
      {
        ffelexToken t;          /* First token in list. */
        ffeequiv eq;            /* Current equivalence being built up. */
        ffebld list;            /* List of expressions in equivalence. */
        ffebldListBottom bottom;
        bool ok;                /* TRUE while current list still being
                                   processed. */
        bool save;              /* TRUE if any var in list is SAVEd. */
      }
    equiv;
    struct
      {
        ffesymbol symbol;       /* BCB/NCB symbol. */
      }
    common;
    struct
      {
        ffesymbol symbol;       /* SFN symbol. */
      }
    sfunc;
  };                            /* Merge with the one in ffestc later. */

/* Static objects accessed by functions in this module. */

static bool ffestc_ok_;         /* _start_ fn's send this to _xyz_ fn's. */
static bool ffestc_parent_ok_;  /* Parent sym for baby sym fn's ok. */
static char ffestc_namelist_;   /* 0=>not namelist, 1=>namelist, 2=>error. */
static union ffestc_local_u_ ffestc_local_;
static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_;
static ffestwShriek ffestc_shriek_after1_ = NULL;
static unsigned long ffestc_blocknum_ = 0;      /* Next block# to assign. */
static int ffestc_entry_num_;
static int ffestc_sfdummy_argno_;
static int ffestc_saved_entry_num_;
static ffelab ffestc_label_;

/* Static functions (internal). */

static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t);
static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt,
                                        ffebld len, ffelexToken lent);
static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet,
                                        ffebld kind, ffelexToken kindt,
                                        ffebld len, ffelexToken lent);
static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last);
static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt,
                                              ffetargetCharacterSize val);
static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt,
                                              ffetargetCharacterSize val);
static void ffestc_labeldef_any_ (void);
static bool ffestc_labeldef_begin_ (void);
static void ffestc_labeldef_branch_begin_ (void);
static void ffestc_labeldef_branch_end_ (void);
static void ffestc_labeldef_endif_ (void);
static void ffestc_labeldef_format_ (void);
static void ffestc_labeldef_invalid_ (void);
static void ffestc_labeldef_notloop_ (void);
static void ffestc_labeldef_notloop_begin_ (void);
static void ffestc_labeldef_useless_ (void);
static bool ffestc_labelref_is_assignable_ (ffelexToken label_token,
                                            ffelab *label);
static bool ffestc_labelref_is_branch_ (ffelexToken label_token,
                                        ffelab *label);
static bool ffestc_labelref_is_format_ (ffelexToken label_token,
                                        ffelab *label);
static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
                                         ffelab *label);
static ffestcOrder_ ffestc_order_actiondo_ (void);
static ffestcOrder_ ffestc_order_actionif_ (void);
static ffestcOrder_ ffestc_order_actionwhere_ (void);
static void ffestc_order_any_ (void);
static void ffestc_order_bad_ (void);
static ffestcOrder_ ffestc_order_blockdata_ (void);
static ffestcOrder_ ffestc_order_blockspec_ (void);
static ffestcOrder_ ffestc_order_data_ (void);
static ffestcOrder_ ffestc_order_data77_ (void);
static ffestcOrder_ ffestc_order_do_ (void);
static ffestcOrder_ ffestc_order_entry_ (void);
static ffestcOrder_ ffestc_order_exec_ (void);
static ffestcOrder_ ffestc_order_format_ (void);
static ffestcOrder_ ffestc_order_function_ (void);
static ffestcOrder_ ffestc_order_iface_ (void);
static ffestcOrder_ ffestc_order_ifthen_ (void);
static ffestcOrder_ ffestc_order_implicit_ (void);
static ffestcOrder_ ffestc_order_implicitnone_ (void);
static ffestcOrder_ ffestc_order_parameter_ (void);
static ffestcOrder_ ffestc_order_program_ (void);
static ffestcOrder_ ffestc_order_progspec_ (void);
static ffestcOrder_ ffestc_order_selectcase_ (void);
static ffestcOrder_ ffestc_order_sfunc_ (void);
static ffestcOrder_ ffestc_order_subroutine_ (void);
static ffestcOrder_ ffestc_order_typedecl_ (void);
static ffestcOrder_ ffestc_order_unit_ (void);
static void ffestc_promote_dummy_ (ffelexToken t);
static void ffestc_promote_execdummy_ (ffelexToken t);
static void ffestc_promote_sfdummy_ (ffelexToken t);
static void ffestc_shriek_begin_program_ (void);
static void ffestc_shriek_blockdata_ (bool ok);
static void ffestc_shriek_do_ (bool ok);
static void ffestc_shriek_end_program_ (bool ok);
static void ffestc_shriek_function_ (bool ok);
static void ffestc_shriek_if_ (bool ok);
static void ffestc_shriek_ifthen_ (bool ok);
static void ffestc_shriek_select_ (bool ok);
static void ffestc_shriek_subroutine_ (bool ok);
static int ffestc_subr_binsrch_ (const char *const *list, int size,
                                 ffestpFile *spec, const char *whine);
static ffestvFormat ffestc_subr_format_ (ffestpFile *spec);
static bool ffestc_subr_is_branch_ (ffestpFile *spec);
static bool ffestc_subr_is_format_ (ffestpFile *spec);
static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec);
static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec,
                                 const char **target, int *length);
static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec);
static void ffestc_try_shriek_do_ (void);

/* Internal macros. */

#define ffestc_check_simple_() \
      assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_)
#define ffestc_check_start_() \
      assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \
      ffestc_statelet_ = FFESTC_stateletATTRIB_
#define ffestc_check_attrib_() \
      assert(ffestc_statelet_ == FFESTC_stateletATTRIB_)
#define ffestc_check_item_() \
      assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
            || ffestc_statelet_ == FFESTC_stateletITEM_); \
      ffestc_statelet_ = FFESTC_stateletITEM_
#define ffestc_check_item_startvals_() \
      assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
            || ffestc_statelet_ == FFESTC_stateletITEM_); \
      ffestc_statelet_ = FFESTC_stateletITEMVALS_
#define ffestc_check_item_value_() \
      assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_)
#define ffestc_check_item_endvals_() \
      assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \
      ffestc_statelet_ = FFESTC_stateletITEM_
#define ffestc_check_finish_() \
      assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
            || ffestc_statelet_ == FFESTC_stateletITEM_); \
      ffestc_statelet_ = FFESTC_stateletSIMPLE_
#define ffestc_order_action_() ffestc_order_exec_()
#define ffestc_shriek_if_lost_ ffestc_shriek_if_
\f
/* ffestc_establish_declinfo_ -- Determine specific type/params info for entity

   ffestc_establish_declinfo_(kind,kind_token,len,len_token);

   Must be called after _declstmt_ called to establish base type.  */

static void
ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len,
                            ffelexToken lent)
{
  ffeinfoBasictype bt = ffestc_local_.decl.basic_type;
  ffeinfoKindtype kt;
  ffetargetCharacterSize val;

  if (kindt == NULL)
    kt = ffestc_local_.decl.stmt_kind_type;
  else if (!ffestc_local_.decl.per_var_kind_ok)
    {
      ffebad_start (FFEBAD_KINDTYPE);
      ffebad_here (0, ffelex_token_where_line (kindt),
                   ffelex_token_where_column (kindt));
      ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_finish ();
      kt = ffestc_local_.decl.stmt_kind_type;
    }
  else
    {
      if (kind == NULL)
        {
          assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
          val = atol (ffelex_token_text (kindt));
          kt = ffestc_kindtype_star_ (bt, val);
        }
      else if (ffebld_op (kind) == FFEBLD_opANY)
        kt = ffestc_local_.decl.stmt_kind_type;
      else
        {
          assert (ffebld_op (kind) == FFEBLD_opCONTER);
          assert (ffeinfo_basictype (ffebld_info (kind))
                  == FFEINFO_basictypeINTEGER);
          assert (ffeinfo_kindtype (ffebld_info (kind))
                  == FFEINFO_kindtypeINTEGERDEFAULT);
          val = ffebld_constant_integerdefault (ffebld_conter (kind));
          kt = ffestc_kindtype_kind_ (bt, val);
        }

      if (kt == FFEINFO_kindtypeNONE)
        {                       /* Not valid kind type. */
          ffebad_start (FFEBAD_KINDTYPE);
          ffebad_here (0, ffelex_token_where_line (kindt),
                       ffelex_token_where_column (kindt));
          ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_finish ();
          kt = ffestc_local_.decl.stmt_kind_type;
        }
    }

  ffestc_local_.decl.kind_type = kt;

  /* Now check length specification for CHARACTER data type. */

  if (((len == NULL) && (lent == NULL))
      || (bt != FFEINFO_basictypeCHARACTER))
    val = ffestc_local_.decl.stmt_size;
  else
    {
      if (len == NULL)
        {
          assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
          val = atol (ffelex_token_text (lent));
        }
      else if (ffebld_op (len) == FFEBLD_opSTAR)
        val = FFETARGET_charactersizeNONE;
      else if (ffebld_op (len) == FFEBLD_opANY)
        val = FFETARGET_charactersizeNONE;
      else
        {
          assert (ffebld_op (len) == FFEBLD_opCONTER);
          assert (ffeinfo_basictype (ffebld_info (len))
                  == FFEINFO_basictypeINTEGER);
          assert (ffeinfo_kindtype (ffebld_info (len))
                  == FFEINFO_kindtypeINTEGERDEFAULT);
          val = ffebld_constant_integerdefault (ffebld_conter (len));
        }
    }

  if ((val == 0) && !(0 && ffe_is_90 ()))
    {
      val = 1;
      ffebad_start (FFEBAD_ZERO_SIZE);
      ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
      ffebad_finish ();
    }
  ffestc_local_.decl.size = val;
}

/* ffestc_establish_declstmt_ -- Establish host-specific type/params info

   ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
         len_token);  */

static void
ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
                            ffelexToken kindt, ffebld len, ffelexToken lent)
{
  ffeinfoBasictype bt;
  ffeinfoKindtype ktd;          /* Default kindtype. */
  ffeinfoKindtype kt;
  ffetargetCharacterSize val;
  bool per_var_kind_ok = TRUE;

  /* Determine basictype and default kindtype. */

  switch (type)
    {
    case FFESTP_typeINTEGER:
      bt = FFEINFO_basictypeINTEGER;
      ktd = FFEINFO_kindtypeINTEGERDEFAULT;
      break;

    case FFESTP_typeBYTE:
      bt = FFEINFO_basictypeINTEGER;
      ktd = FFEINFO_kindtypeINTEGER2;
      break;

    case FFESTP_typeWORD:
      bt = FFEINFO_basictypeINTEGER;
      ktd = FFEINFO_kindtypeINTEGER3;
      break;

    case FFESTP_typeREAL:
      bt = FFEINFO_basictypeREAL;
      ktd = FFEINFO_kindtypeREALDEFAULT;
      break;

    case FFESTP_typeCOMPLEX:
      bt = FFEINFO_basictypeCOMPLEX;
      ktd = FFEINFO_kindtypeREALDEFAULT;
      break;

    case FFESTP_typeLOGICAL:
      bt = FFEINFO_basictypeLOGICAL;
      ktd = FFEINFO_kindtypeLOGICALDEFAULT;
      break;

    case FFESTP_typeCHARACTER:
      bt = FFEINFO_basictypeCHARACTER;
      ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
      break;

    case FFESTP_typeDBLPRCSN:
      bt = FFEINFO_basictypeREAL;
      ktd = FFEINFO_kindtypeREALDOUBLE;
      per_var_kind_ok = FALSE;
      break;

    case FFESTP_typeDBLCMPLX:
      bt = FFEINFO_basictypeCOMPLEX;
#if FFETARGET_okCOMPLEX2
      ktd = FFEINFO_kindtypeREALDOUBLE;
#else
      ktd = FFEINFO_kindtypeREALDEFAULT;
      ffebad_start (FFEBAD_BAD_DBLCMPLX);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_finish ();
#endif
      per_var_kind_ok = FALSE;
      break;

    default:
      assert ("Unexpected type (F90 TYPE?)!" == NULL);
      bt = FFEINFO_basictypeNONE;
      ktd = FFEINFO_kindtypeNONE;
      break;
    }

  if (kindt == NULL)
    kt = ktd;
  else
    {                           /* Not necessarily default kind type. */
      if (kind == NULL)
        {                       /* Shouldn't happen for CHARACTER. */
          assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
          val = atol (ffelex_token_text (kindt));
          kt = ffestc_kindtype_star_ (bt, val);
        }
      else if (ffebld_op (kind) == FFEBLD_opANY)
        kt = ktd;
      else
        {
          assert (ffebld_op (kind) == FFEBLD_opCONTER);
          assert (ffeinfo_basictype (ffebld_info (kind))
                  == FFEINFO_basictypeINTEGER);
          assert (ffeinfo_kindtype (ffebld_info (kind))
                  == FFEINFO_kindtypeINTEGERDEFAULT);
          val = ffebld_constant_integerdefault (ffebld_conter (kind));
          kt = ffestc_kindtype_kind_ (bt, val);
        }

      if (kt == FFEINFO_kindtypeNONE)
        {                       /* Not valid kind type. */
          ffebad_start (FFEBAD_KINDTYPE);
          ffebad_here (0, ffelex_token_where_line (kindt),
                       ffelex_token_where_column (kindt));
          ffebad_here (1, ffelex_token_where_line (typet),
                       ffelex_token_where_column (typet));
          ffebad_finish ();
          kt = ktd;
        }
    }

  ffestc_local_.decl.basic_type = bt;
  ffestc_local_.decl.stmt_kind_type = kt;
  ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok;

  /* Now check length specification for CHARACTER data type. */

  if (((len == NULL) && (lent == NULL))
      || (type != FFESTP_typeCHARACTER))
    val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
  else
    {
      if (len == NULL)
        {
          assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
          val = atol (ffelex_token_text (lent));
        }
      else if (ffebld_op (len) == FFEBLD_opSTAR)
        val = FFETARGET_charactersizeNONE;
      else if (ffebld_op (len) == FFEBLD_opANY)
        val = FFETARGET_charactersizeNONE;
      else
        {
          assert (ffebld_op (len) == FFEBLD_opCONTER);
          assert (ffeinfo_basictype (ffebld_info (len))
                  == FFEINFO_basictypeINTEGER);
          assert (ffeinfo_kindtype (ffebld_info (len))
                  == FFEINFO_kindtypeINTEGERDEFAULT);
          val = ffebld_constant_integerdefault (ffebld_conter (len));
        }
    }

  if ((val == 0) && !(0 && ffe_is_90 ()))
    {
      val = 1;
      ffebad_start (FFEBAD_ZERO_SIZE);
      ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
      ffebad_finish ();
    }
  ffestc_local_.decl.stmt_size = val;
}

/* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)

   ffestc_establish_impletter_(first_letter_token,last_letter_token);  */

static void
ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
{
  bool ok = FALSE;              /* Stays FALSE if first letter > last. */
  char c;

  if (last == NULL)
    ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)),
                                      ffestc_local_.decl.basic_type,
                                      ffestc_local_.decl.kind_type,
                                      ffestc_local_.decl.size);
  else
    {
      for (c = *(ffelex_token_text (first));
           c <= *(ffelex_token_text (last));
           c++)
        {
          ok = ffeimplic_establish_initial (c,
                                            ffestc_local_.decl.basic_type,
                                            ffestc_local_.decl.kind_type,
                                            ffestc_local_.decl.size);
          if (!ok)
            break;
        }
    }

  if (!ok)
    {
      char cs[2];

      cs[0] = c;
      cs[1] = '\0';

      ffebad_start (FFEBAD_BAD_IMPLICIT);
      ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
      ffebad_string (cs);
      ffebad_finish ();
    }
}

/* ffestc_init_3 -- Initialize ffestc for new program unit

   ffestc_init_3();  */

void
ffestc_init_3 ()
{
  ffestv_save_state_ = FFESTV_savestateNONE;
  ffestc_entry_num_ = 0;
  ffestv_num_label_defines_ = 0;
}

/* ffestc_init_4 -- Initialize ffestc for new scoping unit

   ffestc_init_4();

   For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
   defs, and statement function defs.  */

void
ffestc_init_4 ()
{
  ffestc_saved_entry_num_ = ffestc_entry_num_;
  ffestc_entry_num_ = 0;
}

/* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value

   ffeinfoKindtype kt;
   ffeinfoBasictype bt;
   ffetargetCharacterSize val;
   kt = ffestc_kindtype_kind_(bt,val);
   if (kt == FFEINFO_kindtypeNONE)
       // unsupported/invalid KIND= value for type  */

static ffeinfoKindtype
ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
{
  ffetype type;
  ffetype base_type;
  ffeinfoKindtype kt;

  base_type = ffeinfo_type (bt, 1);     /* ~~ */
  assert (base_type != NULL);

  type = ffetype_lookup_kind (base_type, (int) val);
  if (type == NULL)
    return FFEINFO_kindtypeNONE;

  for (kt = 1; kt < FFEINFO_kindtype; ++kt)
    if (ffeinfo_type (bt, kt) == type)
      return kt;

  return FFEINFO_kindtypeNONE;
}

/* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value

   ffeinfoKindtype kt;
   ffeinfoBasictype bt;
   ffetargetCharacterSize val;
   kt = ffestc_kindtype_star_(bt,val);
   if (kt == FFEINFO_kindtypeNONE)
       // unsupported/invalid * value for type  */

static ffeinfoKindtype
ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
{
  ffetype type;
  ffetype base_type;
  ffeinfoKindtype kt;

  base_type = ffeinfo_type (bt, 1);     /* ~~ */
  assert (base_type != NULL);

  type = ffetype_lookup_star (base_type, (int) val);
  if (type == NULL)
    return FFEINFO_kindtypeNONE;

  for (kt = 1; kt < FFEINFO_kindtype; ++kt)
    if (ffeinfo_type (bt, kt) == type)
      return kt;

  return FFEINFO_kindtypeNONE;
}

/* Define label as usable for anything without complaint.  */

static void
ffestc_labeldef_any_ ()
{
  if ((ffesta_label_token == NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  ffelab_set_type (ffestc_label_, FFELAB_typeANY);
  ffestd_labeldef_any (ffestc_label_);

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_labeldef_begin_ -- Define label as unknown, initially

   ffestc_labeldef_begin_();  */

static bool
ffestc_labeldef_begin_ ()
{
  ffelabValue label_value;
  ffelab label;

  label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
  if ((label_value == 0) || (label_value > FFELAB_valueMAX))
    {
      ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_finish ();
    }

  label = ffelab_find (label_value);
  if (label == NULL)
    {
      label = ffestc_label_ = ffelab_new (label_value);
      ffestv_num_label_defines_++;
      ffelab_set_definition_line (label,
          ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
      ffelab_set_definition_column (label,
      ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));

      return TRUE;
    }

  if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
    {
      ffestv_num_label_defines_++;
      ffestc_label_ = label;
      ffelab_set_definition_line (label,
          ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
      ffelab_set_definition_column (label,
      ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));

      return TRUE;
    }

  ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED);
  ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
               ffelex_token_where_column (ffesta_label_token));
  ffebad_here (1, ffelab_definition_line (label),
               ffelab_definition_column (label));
  ffebad_string (ffelex_token_text (ffesta_label_token));
  ffebad_finish ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
  return FALSE;
}

/* ffestc_labeldef_branch_begin_ -- Define label as a branch target one

   ffestc_labeldef_branch_begin_();  */

static void
ffestc_labeldef_branch_begin_ ()
{
  if ((ffesta_label_token == NULL)
      || (ffestc_shriek_after1_ != NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  switch (ffelab_type (ffestc_label_))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
      ffelab_set_blocknum (ffestc_label_,
                           ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_branch (ffestc_label_);
      break;

    case FFELAB_typeNOTLOOP:
      if (ffelab_blocknum (ffestc_label_)
          < ffestw_blocknum (ffestw_stack_top ()))
        {
          ffebad_start (FFEBAD_LABEL_BLOCK);
          ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                       ffelab_firstref_column (ffestc_label_));
          ffebad_finish ();
        }
      ffelab_set_blocknum (ffestc_label_,
                           ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_branch (ffestc_label_);
      break;

    case FFELAB_typeLOOPEND:
      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
          || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
        {                       /* Unterminated block. */
          ffelab_set_type (ffestc_label_, FFELAB_typeANY);
          ffestd_labeldef_any (ffestc_label_);

          ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
          ffebad_here (0, ffelab_doref_line (ffestc_label_),
                       ffelab_doref_column (ffestc_label_));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_finish ();
          break;
        }
      ffestd_labeldef_branch (ffestc_label_);
      /* Leave something around for _branch_end_() to handle. */
      return;

    case FFELAB_typeFORMAT:
      ffelab_set_type (ffestc_label_, FFELAB_typeANY);
      ffestd_labeldef_any (ffestc_label_);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                   ffelab_firstref_column (ffestc_label_));
      ffebad_finish ();
      break;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* Define possible end of labeled-DO-loop.  Call only after calling
   ffestc_labeldef_branch_begin_, or when other branch_* functions
   recognize that a label might also be serving as a branch end (in
   which case they must issue a diagnostic).  */

static void
ffestc_labeldef_branch_end_ ()
{
  if (ffesta_label_token == NULL)
    return;

  assert (ffestc_label_ != NULL);
  assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND)
          || (ffelab_type (ffestc_label_) == FFELAB_typeANY));

  while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
         && (ffestw_label (ffestw_stack_top ()) == ffestc_label_))
    ffestc_shriek_do_ (TRUE);

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* ffestc_labeldef_endif_ -- Define label as an END IF one

   ffestc_labeldef_endif_();  */

static void
ffestc_labeldef_endif_ ()
{
  if ((ffesta_label_token == NULL)
      || (ffestc_shriek_after1_ != NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  switch (ffelab_type (ffestc_label_))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (ffestc_label_, FFELAB_typeENDIF);
      ffelab_set_blocknum (ffestc_label_,
                   ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
      ffestd_labeldef_endif (ffestc_label_);
      break;

    case FFELAB_typeNOTLOOP:
      if (ffelab_blocknum (ffestc_label_)
          < ffestw_blocknum (ffestw_previous (ffestw_stack_top ())))
        {
          ffebad_start (FFEBAD_LABEL_BLOCK);
          ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                       ffelab_firstref_column (ffestc_label_));
          ffebad_finish ();
        }
      ffelab_set_blocknum (ffestc_label_,
                   ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
      ffestd_labeldef_endif (ffestc_label_);
      break;

    case FFELAB_typeLOOPEND:
      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
          || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
        {                       /* Unterminated block. */
          ffelab_set_type (ffestc_label_, FFELAB_typeANY);
          ffestd_labeldef_any (ffestc_label_);

          ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
          ffebad_here (0, ffelab_doref_line (ffestc_label_),
                       ffelab_doref_column (ffestc_label_));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_finish ();
          break;
        }
      ffestd_labeldef_endif (ffestc_label_);
      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_doref_line (ffestc_label_),
                   ffelab_doref_column (ffestc_label_));
      ffebad_finish ();
      ffestc_labeldef_branch_end_ ();
      return;

    case FFELAB_typeFORMAT:
      ffelab_set_type (ffestc_label_, FFELAB_typeANY);
      ffestd_labeldef_any (ffestc_label_);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                   ffelab_firstref_column (ffestc_label_));
      ffebad_finish ();
      break;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* ffestc_labeldef_format_ -- Define label as a FORMAT one

   ffestc_labeldef_format_();  */

static void
ffestc_labeldef_format_ ()
{
  if ((ffesta_label_token == NULL)
      || (ffestc_shriek_after1_ != NULL))
    {
      ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_finish ();
      return;
    }

  if (!ffestc_labeldef_begin_ ())
    return;

  switch (ffelab_type (ffestc_label_))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT);
      ffestd_labeldef_format (ffestc_label_);
      break;

    case FFELAB_typeFORMAT:
      ffestd_labeldef_format (ffestc_label_);
      break;

    case FFELAB_typeLOOPEND:
      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
          || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
        {                       /* Unterminated block. */
          ffelab_set_type (ffestc_label_, FFELAB_typeANY);
          ffestd_labeldef_any (ffestc_label_);

          ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
          ffebad_here (0, ffelab_doref_line (ffestc_label_),
                       ffelab_doref_column (ffestc_label_));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_finish ();
          break;
        }
      ffestd_labeldef_format (ffestc_label_);
      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_doref_line (ffestc_label_),
                   ffelab_doref_column (ffestc_label_));
      ffebad_finish ();
      ffestc_labeldef_branch_end_ ();
      return;

    case FFELAB_typeNOTLOOP:
      ffelab_set_type (ffestc_label_, FFELAB_typeANY);
      ffestd_labeldef_any (ffestc_label_);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                   ffelab_firstref_column (ffestc_label_));
      ffebad_finish ();
      break;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present

   ffestc_labeldef_invalid_();  */

static void
ffestc_labeldef_invalid_ ()
{
  if ((ffesta_label_token == NULL)
      || (ffestc_shriek_after1_ != NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  ffebad_start (FFEBAD_INVALID_LABEL_DEF);
  ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
               ffelex_token_where_column (ffesta_label_token));
  ffebad_finish ();

  ffelab_set_type (ffestc_label_, FFELAB_typeANY);
  ffestd_labeldef_any (ffestc_label_);

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* Define label as a non-loop-ending one on a statement that can't
   be in the "then" part of a logical IF, such as a block-IF statement.  */

static void
ffestc_labeldef_notloop_ ()
{
  if (ffesta_label_token == NULL)
    return;

  assert (ffestc_shriek_after1_ == NULL);

  if (!ffestc_labeldef_begin_ ())
    return;

  switch (ffelab_type (ffestc_label_))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
      ffelab_set_blocknum (ffestc_label_,
                           ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_notloop (ffestc_label_);
      break;

    case FFELAB_typeNOTLOOP:
      if (ffelab_blocknum (ffestc_label_)
          < ffestw_blocknum (ffestw_stack_top ()))
        {
          ffebad_start (FFEBAD_LABEL_BLOCK);
          ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                       ffelab_firstref_column (ffestc_label_));
          ffebad_finish ();
        }
      ffelab_set_blocknum (ffestc_label_,
                           ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_notloop (ffestc_label_);
      break;

    case FFELAB_typeLOOPEND:
      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
          || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
        {                       /* Unterminated block. */
          ffelab_set_type (ffestc_label_, FFELAB_typeANY);
          ffestd_labeldef_any (ffestc_label_);

          ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
          ffebad_here (0, ffelab_doref_line (ffestc_label_),
                       ffelab_doref_column (ffestc_label_));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_finish ();
          break;
        }
      ffestd_labeldef_notloop (ffestc_label_);
      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_doref_line (ffestc_label_),
                   ffelab_doref_column (ffestc_label_));
      ffebad_finish ();
      ffestc_labeldef_branch_end_ ();
      return;

    case FFELAB_typeFORMAT:
      ffelab_set_type (ffestc_label_, FFELAB_typeANY);
      ffestd_labeldef_any (ffestc_label_);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                   ffelab_firstref_column (ffestc_label_));
      ffebad_finish ();
      break;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* Define label as a non-loop-ending one.  Use this when it is
   possible that the pending label is inhibited because we're in
   the midst of a logical-IF, and thus _branch_end_ is going to
   be called after the current statement to resolve a potential
   loop-ending label.  */

static void
ffestc_labeldef_notloop_begin_ ()
{
  if ((ffesta_label_token == NULL)
      || (ffestc_shriek_after1_ != NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  switch (ffelab_type (ffestc_label_))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
      ffelab_set_blocknum (ffestc_label_,
                           ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_notloop (ffestc_label_);
      break;

    case FFELAB_typeNOTLOOP:
      if (ffelab_blocknum (ffestc_label_)
          < ffestw_blocknum (ffestw_stack_top ()))
        {
          ffebad_start (FFEBAD_LABEL_BLOCK);
          ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                       ffelab_firstref_column (ffestc_label_));
          ffebad_finish ();
        }
      ffelab_set_blocknum (ffestc_label_,
                           ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_notloop (ffestc_label_);
      break;

    case FFELAB_typeLOOPEND:
      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
          || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
        {                       /* Unterminated block. */
          ffelab_set_type (ffestc_label_, FFELAB_typeANY);
          ffestd_labeldef_any (ffestc_label_);

          ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
          ffebad_here (0, ffelab_doref_line (ffestc_label_),
                       ffelab_doref_column (ffestc_label_));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_finish ();
          break;
        }
      ffestd_labeldef_branch (ffestc_label_);
      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_doref_line (ffestc_label_),
                   ffelab_doref_column (ffestc_label_));
      ffebad_finish ();
      return;

    case FFELAB_typeFORMAT:
      ffelab_set_type (ffestc_label_, FFELAB_typeANY);
      ffestd_labeldef_any (ffestc_label_);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                   ffelab_firstref_column (ffestc_label_));
      ffebad_finish ();
      break;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* ffestc_labeldef_useless_ -- Define label as a useless one

   ffestc_labeldef_useless_();  */

static void
ffestc_labeldef_useless_ ()
{
  if ((ffesta_label_token == NULL)
      || (ffestc_shriek_after1_ != NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  switch (ffelab_type (ffestc_label_))
    {
    case FFELAB_typeUNKNOWN:
      ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS);
      ffestd_labeldef_useless (ffestc_label_);
      break;

    case FFELAB_typeLOOPEND:
      ffelab_set_type (ffestc_label_, FFELAB_typeANY);
      ffestd_labeldef_any (ffestc_label_);

      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
          || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
        {                       /* Unterminated block. */
          ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
          ffebad_here (0, ffelab_doref_line (ffestc_label_),
                       ffelab_doref_column (ffestc_label_));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
                       ffelex_token_where_column (ffesta_label_token));
          ffebad_finish ();
          break;
        }
      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_doref_line (ffestc_label_),
                   ffelab_doref_column (ffestc_label_));
      ffebad_finish ();
      ffestc_labeldef_branch_end_ ();
      return;

    case FFELAB_typeASSIGNABLE:
    case FFELAB_typeFORMAT:
    case FFELAB_typeNOTLOOP:
      ffelab_set_type (ffestc_label_, FFELAB_typeANY);
      ffestd_labeldef_any (ffestc_label_);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
                   ffelex_token_where_column (ffesta_label_token));
      ffebad_here (1, ffelab_firstref_line (ffestc_label_),
                   ffelab_firstref_column (ffestc_label_));
      ffebad_finish ();
      break;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  ffestc_try_shriek_do_ ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
}

/* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt

   if (ffestc_labelref_is_assignable_(label_token,&label))
       // label ref is ok, label is filled in with ffelab object  */

static bool
ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label)
{
  ffelab label;
  ffelabValue label_value;

  label_value = (ffelabValue) atol (ffelex_token_text (label_token));
  if ((label_value == 0) || (label_value > FFELAB_valueMAX))
    {
      ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
      ffebad_here (0, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();
      return FALSE;
    }

  label = ffelab_find (label_value);
  if (label == NULL)
    {
      label = ffelab_new (label_value);
      ffelab_set_firstref_line (label,
                 ffewhere_line_use (ffelex_token_where_line (label_token)));
      ffelab_set_firstref_column (label,
             ffewhere_column_use (ffelex_token_where_column (label_token)));
    }

  switch (ffelab_type (label))
    {
    case FFELAB_typeUNKNOWN:
      ffelab_set_type (label, FFELAB_typeASSIGNABLE);
      break;

    case FFELAB_typeASSIGNABLE:
    case FFELAB_typeLOOPEND:
    case FFELAB_typeFORMAT:
    case FFELAB_typeNOTLOOP:
    case FFELAB_typeENDIF:
      break;

    case FFELAB_typeUSELESS:
      ffelab_set_type (label, FFELAB_typeANY);
      ffestd_labeldef_any (label);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
      ffebad_here (1, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();

      ffestc_try_shriek_do_ ();

      return FALSE;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  *x_label = label;
  return TRUE;
}

/* ffestc_labelref_is_branch_ -- Reference to label in branch stmt

   if (ffestc_labelref_is_branch_(label_token,&label))
       // label ref is ok, label is filled in with ffelab object  */

static bool
ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label)
{
  ffelab label;
  ffelabValue label_value;
  ffestw block;
  unsigned long blocknum;

  label_value = (ffelabValue) atol (ffelex_token_text (label_token));
  if ((label_value == 0) || (label_value > FFELAB_valueMAX))
    {
      ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
      ffebad_here (0, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();
      return FALSE;
    }

  label = ffelab_find (label_value);
  if (label == NULL)
    {
      label = ffelab_new (label_value);
      ffelab_set_firstref_line (label,
                 ffewhere_line_use (ffelex_token_where_line (label_token)));
      ffelab_set_firstref_column (label,
             ffewhere_column_use (ffelex_token_where_column (label_token)));
    }

  switch (ffelab_type (label))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (label, FFELAB_typeNOTLOOP);
      ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ()));
      break;

    case FFELAB_typeLOOPEND:
      if (ffelab_blocknum (label) != 0)
        break;                  /* Already taken care of. */
      for (block = ffestw_top_do (ffestw_stack_top ());
           (block != NULL) && (ffestw_label (block) != label);
           block = ffestw_top_do (ffestw_previous (block)))
        ;                       /* Find most recent DO <label> ancestor. */
      if (block == NULL)
        {                       /* Reference to within a (dead) block. */
          ffebad_start (FFEBAD_LABEL_BLOCK);
          ffebad_here (0, ffelab_definition_line (label),
                       ffelab_definition_column (label));
          ffebad_here (1, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();
          break;
        }
      ffelab_set_blocknum (label, ffestw_blocknum (block));
      ffelab_set_firstref_line (label,
                 ffewhere_line_use (ffelex_token_where_line (label_token)));
      ffelab_set_firstref_column (label,
             ffewhere_column_use (ffelex_token_where_column (label_token)));
      break;

    case FFELAB_typeNOTLOOP:
    case FFELAB_typeENDIF:
      if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
        break;
      blocknum = ffelab_blocknum (label);
      for (block = ffestw_stack_top ();
           ffestw_blocknum (block) > blocknum;
           block = ffestw_previous (block))
        ;                       /* Find most recent common ancestor. */
      if (ffelab_blocknum (label) == ffestw_blocknum (block))
        break;                  /* Check again. */
      if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
        {                       /* Reference to within a (dead) block. */
          ffebad_start (FFEBAD_LABEL_BLOCK);
          ffebad_here (0, ffelab_definition_line (label),
                       ffelab_definition_column (label));
          ffebad_here (1, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();
          break;
        }
      ffelab_set_blocknum (label, ffestw_blocknum (block));
      break;

    case FFELAB_typeFORMAT:
      if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
        {
          ffelab_set_type (label, FFELAB_typeANY);
          ffestd_labeldef_any (label);

          ffebad_start (FFEBAD_LABEL_USE_USE);
          ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
          ffebad_here (1, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();

          ffestc_try_shriek_do_ ();

          return FALSE;
        }
      /* Fall through. */
    case FFELAB_typeUSELESS:
      ffelab_set_type (label, FFELAB_typeANY);
      ffestd_labeldef_any (label);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
      ffebad_here (1, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();

      ffestc_try_shriek_do_ ();

      return FALSE;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  *x_label = label;
  return TRUE;
}

/* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification

   if (ffestc_labelref_is_format_(label_token,&label))
       // label ref is ok, label is filled in with ffelab object  */

static bool
ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
{
  ffelab label;
  ffelabValue label_value;

  label_value = (ffelabValue) atol (ffelex_token_text (label_token));
  if ((label_value == 0) || (label_value > FFELAB_valueMAX))
    {
      ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
      ffebad_here (0, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();
      return FALSE;
    }

  label = ffelab_find (label_value);
  if (label == NULL)
    {
      label = ffelab_new (label_value);
      ffelab_set_firstref_line (label,
                 ffewhere_line_use (ffelex_token_where_line (label_token)));
      ffelab_set_firstref_column (label,
             ffewhere_column_use (ffelex_token_where_column (label_token)));
    }

  switch (ffelab_type (label))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (label, FFELAB_typeFORMAT);
      break;

    case FFELAB_typeFORMAT:
      break;

    case FFELAB_typeLOOPEND:
    case FFELAB_typeNOTLOOP:
      if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
        {
          ffelab_set_type (label, FFELAB_typeANY);
          ffestd_labeldef_any (label);

          ffebad_start (FFEBAD_LABEL_USE_USE);
          ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
          ffebad_here (1, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();

          ffestc_try_shriek_do_ ();

          return FALSE;
        }
      /* Fall through. */
    case FFELAB_typeUSELESS:
    case FFELAB_typeENDIF:
      ffelab_set_type (label, FFELAB_typeANY);
      ffestd_labeldef_any (label);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
      ffebad_here (1, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();

      ffestc_try_shriek_do_ ();

      return FALSE;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  ffestc_try_shriek_do_ ();

  *x_label = label;
  return TRUE;
}

/* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt

   if (ffestc_labelref_is_loopend_(label_token,&label))
       // label ref is ok, label is filled in with ffelab object  */

static bool
ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
{
  ffelab label;
  ffelabValue label_value;

  label_value = (ffelabValue) atol (ffelex_token_text (label_token));
  if ((label_value == 0) || (label_value > FFELAB_valueMAX))
    {
      ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
      ffebad_here (0, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();
      return FALSE;
    }

  label = ffelab_find (label_value);
  if (label == NULL)
    {
      label = ffelab_new (label_value);
      ffelab_set_doref_line (label,
                 ffewhere_line_use (ffelex_token_where_line (label_token)));
      ffelab_set_doref_column (label,
             ffewhere_column_use (ffelex_token_where_column (label_token)));
    }

  switch (ffelab_type (label))
    {
    case FFELAB_typeASSIGNABLE:
      ffelab_set_doref_line (label,
                 ffewhere_line_use (ffelex_token_where_line (label_token)));
      ffelab_set_doref_column (label,
             ffewhere_column_use (ffelex_token_where_column (label_token)));
      ffewhere_line_kill (ffelab_firstref_line (label));
      ffelab_set_firstref_line (label, ffewhere_line_unknown ());
      ffewhere_column_kill (ffelab_firstref_column (label));
      ffelab_set_firstref_column (label, ffewhere_column_unknown ());
      /* Fall through. */
    case FFELAB_typeUNKNOWN:
      ffelab_set_type (label, FFELAB_typeLOOPEND);
      ffelab_set_blocknum (label, 0);
      break;

    case FFELAB_typeLOOPEND:
      if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
        {                       /* Def must follow all refs. */
          ffelab_set_type (label, FFELAB_typeANY);
          ffestd_labeldef_any (label);

          ffebad_start (FFEBAD_LABEL_DEF_DO);
          ffebad_here (0, ffelab_definition_line (label),
                       ffelab_definition_column (label));
          ffebad_here (1, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();

          ffestc_try_shriek_do_ ();

          return FALSE;
        }
      if (ffelab_blocknum (label) != 0)
        {                       /* Had a branch ref earlier, can't go inside
                                   this new block! */
          ffelab_set_type (label, FFELAB_typeANY);
          ffestd_labeldef_any (label);

          ffebad_start (FFEBAD_LABEL_USE_USE);
          ffebad_here (0, ffelab_firstref_line (label),
                       ffelab_firstref_column (label));
          ffebad_here (1, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();

          ffestc_try_shriek_do_ ();

          return FALSE;
        }
      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
          || (ffestw_label (ffestw_stack_top ()) != label))
        {                       /* Top of stack interrupts flow between two
                                   DOs specifying label. */
          ffelab_set_type (label, FFELAB_typeANY);
          ffestd_labeldef_any (label);

          ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO);
          ffebad_here (0, ffelab_doref_line (label),
                       ffelab_doref_column (label));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_here (2, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();

          ffestc_try_shriek_do_ ();

          return FALSE;
        }
      break;

    case FFELAB_typeNOTLOOP:
    case FFELAB_typeFORMAT:
      if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
        {
          ffelab_set_type (label, FFELAB_typeANY);
          ffestd_labeldef_any (label);

          ffebad_start (FFEBAD_LABEL_USE_USE);
          ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
          ffebad_here (1, ffelex_token_where_line (label_token),
                       ffelex_token_where_column (label_token));
          ffebad_finish ();

          ffestc_try_shriek_do_ ();

          return FALSE;
        }
      /* Fall through. */
    case FFELAB_typeUSELESS:
    case FFELAB_typeENDIF:
      ffelab_set_type (label, FFELAB_typeANY);
      ffestd_labeldef_any (label);

      ffebad_start (FFEBAD_LABEL_USE_DEF);
      ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
      ffebad_here (1, ffelex_token_where_line (label_token),
                   ffelex_token_where_column (label_token));
      ffebad_finish ();

      ffestc_try_shriek_do_ ();

      return FALSE;

    default:
      assert ("bad label" == NULL);
      /* Fall through.  */
    case FFELAB_typeANY:
      break;
    }

  *x_label = label;
  return TRUE;
}

/* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement

   if (ffestc_order_actiondo_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_actiondo_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateDO:
      return FFESTC_orderOK_;

    case FFESTV_stateIFTHEN:
    case FFESTV_stateSELECT1:
      if (ffestw_top_do (ffestw_stack_top ()) == NULL)
        break;
      return FFESTC_orderOK_;

    case FFESTV_stateIF:
      if (ffestw_top_do (ffestw_stack_top ()) == NULL)
        break;
      ffestc_shriek_after1_ = ffestc_shriek_if_;
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    default:
      break;
    }
  ffestc_order_bad_ ();
  return FFESTC_orderBAD_;
}

/* ffestc_order_actionif_ -- Check ordering on <actionif> statement

   if (ffestc_order_actionif_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_actionif_ ()
{
  bool update;

recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
    case FFESTV_statePROGRAM3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
      update = TRUE;
      break;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
      update = TRUE;
      break;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
      update = TRUE;
      break;

    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
      update = FALSE;
      break;

    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT1:
      return FFESTC_orderOK_;

    case FFESTV_stateIF:
      ffestc_shriek_after1_ = ffestc_shriek_if_;
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }

  switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
    {
    case FFESTV_stateINTERFACE0:
      ffestc_order_bad_ ();
      if (update)
        ffestw_update (NULL);
      return FFESTC_orderBAD_;

    default:
      if (update)
        ffestw_update (NULL);
      return FFESTC_orderOK_;
    }
}

/* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement

   if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_actionwhere_ ()
{
  bool update;

recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
    case FFESTV_statePROGRAM3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
      update = TRUE;
      break;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
      update = TRUE;
      break;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
      update = TRUE;
      break;

    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
      update = FALSE;
      break;

    case FFESTV_stateWHERETHEN:
    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT1:
      return FFESTC_orderOK_;

    case FFESTV_stateWHERE:
      return FFESTC_orderOK_;

    case FFESTV_stateIF:
      ffestc_shriek_after1_ = ffestc_shriek_if_;
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }

  switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
    {
    case FFESTV_stateINTERFACE0:
      ffestc_order_bad_ ();
      if (update)
        ffestw_update (NULL);
      return FFESTC_orderBAD_;

    default:
      if (update)
        ffestw_update (NULL);
      return FFESTC_orderOK_;
    }
}

/* Check ordering on "any" statement.  Like _actionwhere_, but
   doesn't produce any diagnostics.  */

static void
ffestc_order_any_ ()
{
  bool update;

recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
    case FFESTV_statePROGRAM3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
      update = TRUE;
      break;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
      update = TRUE;
      break;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
      update = TRUE;
      break;

    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
      update = FALSE;
      break;

    case FFESTV_stateWHERETHEN:
    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT1:
      return;

    case FFESTV_stateWHERE:
      return;

    case FFESTV_stateIF:
      ffestc_shriek_after1_ = ffestc_shriek_if_;
      return;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    default:
      return;
    }

  switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
    {
    case FFESTV_stateINTERFACE0:
      if (update)
        ffestw_update (NULL);
      return;

    default:
      if (update)
        ffestw_update (NULL);
      return;
    }
}

/* ffestc_order_bad_ -- Whine about statement ordering violation

   ffestc_order_bad_();

   Uses current ffesta_tokens[0] and, if available, info on where current
   state started to produce generic message.  Someday we should do
   fancier things than this, but this just gets things creaking along for
   now.  */

static void
ffestc_order_bad_ ()
{
  if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
    {
      ffebad_start (FFEBAD_ORDER_1);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_finish ();
    }
  else
    {
      ffebad_start (FFEBAD_ORDER_2);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
      ffebad_finish ();
    }
  ffestc_labeldef_useless_ ();  /* Any label definition is useless. */
}

/* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement

   if (ffestc_order_blockdata_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_blockdata_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
    case FFESTV_stateBLOCKDATA2:
    case FFESTV_stateBLOCKDATA3:
    case FFESTV_stateBLOCKDATA4:
    case FFESTV_stateBLOCKDATA5:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement

   if (ffestc_order_blockspec_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_blockspec_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
      return FFESTC_orderOK_;

    case FFESTV_stateMODULE0:
    case FFESTV_stateMODULE1:
    case FFESTV_stateMODULE2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
    case FFESTV_stateBLOCKDATA2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateMODULE3:
    case FFESTV_stateBLOCKDATA3:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}
/* ffestc_order_data_ -- Check ordering on DATA statement

   if (ffestc_order_data_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_data_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM2:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateBLOCKDATA2:
    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateBLOCKDATA3:
    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
    case FFESTV_stateBLOCKDATA4:
    case FFESTV_stateWHERETHEN:
    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT0:
    case FFESTV_stateSELECT1:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement

   if (ffestc_order_data77_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_data77_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
    case FFESTV_statePROGRAM3:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
    case FFESTV_stateBLOCKDATA2:
    case FFESTV_stateBLOCKDATA3:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
    case FFESTV_stateBLOCKDATA4:
      return FFESTC_orderOK_;

    case FFESTV_stateWHERETHEN:
    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT0:
    case FFESTV_stateSELECT1:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}
/* ffestc_order_do_ -- Check ordering on <do> statement

   if (ffestc_order_do_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_do_ ()
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateDO:
      return FFESTC_orderOK_;

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_entry_ -- Check ordering on ENTRY statement

   if (ffestc_order_entry_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_entry_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateSUBROUTINE0:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
      break;

    case FFESTV_stateFUNCTION0:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
      break;

    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
      break;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }

  switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
    {
    case FFESTV_stateNIL:
    case FFESTV_stateMODULE5:
      ffestw_update (NULL);
      return FFESTC_orderOK_;

    default:
      ffestc_order_bad_ ();
      ffestw_update (NULL);
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_exec_ -- Check ordering on <exec> statement

   if (ffestc_order_exec_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_exec_ ()
{
  bool update;

recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
    case FFESTV_statePROGRAM3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
      update = TRUE;
      break;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
      update = TRUE;
      break;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
      update = TRUE;
      break;

    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
      update = FALSE;
      break;

    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT1:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }

  switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
    {
    case FFESTV_stateINTERFACE0:
      ffestc_order_bad_ ();
      if (update)
        ffestw_update (NULL);
      return FFESTC_orderBAD_;

    default:
      if (update)
        ffestw_update (NULL);
      return FFESTC_orderOK_;
    }
}

/* ffestc_order_format_ -- Check ordering on FORMAT statement

   if (ffestc_order_format_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_format_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
    case FFESTV_stateWHERETHEN:
    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT0:
    case FFESTV_stateSELECT1:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_function_ -- Check ordering on <function> statement

   if (ffestc_order_function_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_function_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateFUNCTION4:
    case FFESTV_stateFUNCTION5:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_iface_ -- Check ordering on <iface> statement

   if (ffestc_order_iface_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_iface_ ()
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
    case FFESTV_statePROGRAM5:
    case FFESTV_stateSUBROUTINE5:
    case FFESTV_stateFUNCTION5:
    case FFESTV_stateMODULE5:
    case FFESTV_stateINTERFACE0:
      return FFESTC_orderOK_;

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement

   if (ffestc_order_ifthen_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_ifthen_ ()
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateIFTHEN:
      return FFESTC_orderOK_;

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement

   if (ffestc_order_implicit_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_implicit_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
      return FFESTC_orderOK_;

    case FFESTV_stateMODULE0:
    case FFESTV_stateMODULE1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM2:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateMODULE2:
    case FFESTV_stateBLOCKDATA2:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement

   if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_implicitnone_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
      return FFESTC_orderOK_;

    case FFESTV_stateMODULE0:
    case FFESTV_stateMODULE1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_parameter_ -- Check ordering on <parameter> statement

   if (ffestc_order_parameter_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_parameter_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
      return FFESTC_orderOK_;

    case FFESTV_stateMODULE0:
    case FFESTV_stateMODULE1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM2:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateMODULE2:
    case FFESTV_stateBLOCKDATA2:
    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateMODULE3:
    case FFESTV_stateBLOCKDATA3:
    case FFESTV_stateTYPE:      /* GNU extension here! */
    case FFESTV_stateSTRUCTURE:
    case FFESTV_stateUNION:
    case FFESTV_stateMAP:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_program_ -- Check ordering on <program> statement

   if (ffestc_order_program_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_program_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
    case FFESTV_statePROGRAM3:
    case FFESTV_statePROGRAM4:
    case FFESTV_statePROGRAM5:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_progspec_ -- Check ordering on <progspec> statement

   if (ffestc_order_progspec_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_progspec_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
      return FFESTC_orderOK_;

    case FFESTV_stateMODULE0:
    case FFESTV_stateMODULE1:
    case FFESTV_stateMODULE2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateMODULE3:
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
    case FFESTV_stateBLOCKDATA2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
      if (ffe_is_pedantic ())
        {
          ffebad_start (FFEBAD_BLOCKDATA_STMT);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}
/* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement

   if (ffestc_order_selectcase_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_selectcase_ ()
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateSELECT0:
    case FFESTV_stateSELECT1:
      return FFESTC_orderOK_;

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_sfunc_ -- Check ordering on statement-function definition

   if (ffestc_order_sfunc_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_sfunc_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}
/* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement

   if (ffestc_order_subroutine_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_subroutine_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateSUBROUTINE5:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}

/* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement

   if (ffestc_order_typedecl_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_typedecl_ ()
{
  recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_statePROGRAM1:
    case FFESTV_statePROGRAM2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
      return FFESTC_orderOK_;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
      return FFESTC_orderOK_;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
      return FFESTC_orderOK_;

    case FFESTV_stateMODULE0:
    case FFESTV_stateMODULE1:
    case FFESTV_stateMODULE2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
      return FFESTC_orderOK_;

    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
    case FFESTV_stateBLOCKDATA2:
      ffestw_update (NULL);
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
      return FFESTC_orderOK_;

    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateMODULE3:
    case FFESTV_stateBLOCKDATA3:
      return FFESTC_orderOK_;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}
/* ffestc_order_unit_ -- Check ordering on <unit> statement

   if (ffestc_order_unit_() != FFESTC_orderOK_)
       return;  */

static ffestcOrder_
ffestc_order_unit_ ()
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      return FFESTC_orderOK_;

    case FFESTV_stateWHERE:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;

    case FFESTV_stateIF:
      ffestc_order_bad_ ();
      ffestc_shriek_if_ (FALSE);
      return FFESTC_orderBAD_;

    default:
      ffestc_order_bad_ ();
      return FFESTC_orderBAD_;
    }
}
/* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
   ENTRY (prior to the first executable statement).  */

static void
ffestc_promote_dummy_ (ffelexToken t)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffebld e;
  bool sfref_ok;

  assert (t != NULL);

  if (ffelex_token_type (t) == FFELEX_typeASTERISK)
    {
      ffebld_append_item (&ffestc_local_.dummy.list_bottom,
                          ffebld_new_star ());
      return;                   /* Don't bother with alternate returns! */
    }

  s = ffesymbol_declare_local (t, FALSE);
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  sfref_ok = FALSE;

  if (sa & FFESYMBOL_attrsANY)
    na = sa;
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
        {                       /* Seen this one twice in this list! */
          na = FFESYMBOL_attrsetNONE;
        }
      else
        na = sa;
      sfref_ok = TRUE;          /* Ok for sym to be ref'd in sfuncdef
                                   previously, since already declared as a
                                   dummy arg. */
    }
  else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
                    | FFESYMBOL_attrsADJUSTS
                    | FFESYMBOL_attrsANY
                    | FFESYMBOL_attrsANYLEN
                    | FFESYMBOL_attrsANYSIZE
                    | FFESYMBOL_attrsARRAY
                    | FFESYMBOL_attrsDUMMY
                    | FFESYMBOL_attrsEXTERNAL
                    | FFESYMBOL_attrsSFARG
                    | FFESYMBOL_attrsTYPE)))
    na = sa | FFESYMBOL_attrsDUMMY;
  else
    na = FFESYMBOL_attrsetNONE;

  if (!ffesymbol_is_specable (s)
      && (!sfref_ok
          || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
      ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
      e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
                             FFEINTRIN_impNONE);
      ffebld_set_info (e,
                       ffeinfo_new (FFEINFO_basictypeNONE,
                                    FFEINFO_kindtypeNONE,
                                    0,
                                    FFEINFO_kindNONE,
                                    FFEINFO_whereNONE,
                                    FFETARGET_charactersizeNONE));
      ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
      ffesymbol_signal_unreported (s);
    }
}

/* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context

   ffestc_promote_execdummy_(t);

   Invoked for each token in dummy arg list of ENTRY when the statement
   follows the first executable statement.  */

static void
ffestc_promote_execdummy_ (ffelexToken t)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffesymbolState ss;
  ffesymbolState ns;
  ffeinfoKind kind;
  ffeinfoWhere where;
  ffebld e;

  assert (t != NULL);

  if (ffelex_token_type (t) == FFELEX_typeASTERISK)
    {
      ffebld_append_item (&ffestc_local_.dummy.list_bottom,
                          ffebld_new_star ());
      return;                   /* Don't bother with alternate returns! */
    }

  s = ffesymbol_declare_local (t, FALSE);
  na = sa = ffesymbol_attrs (s);
  ss = ffesymbol_state (s);
  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
    {                           /* Seen this one twice in this list! */
      na = FFESYMBOL_attrsetNONE;
    }

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  ns = FFESYMBOL_stateUNDERSTOOD;       /* Assume we know it all know. */

  switch (kind)
    {
    case FFEINFO_kindENTITY:
    case FFEINFO_kindFUNCTION:
    case FFEINFO_kindSUBROUTINE:
      break;                    /* These are fine, as far as we know. */

    case FFEINFO_kindNONE:
      if (sa & FFESYMBOL_attrsDUMMY)
        ns = FFESYMBOL_stateUNCERTAIN;  /* Learned nothing new. */
      else if (sa & FFESYMBOL_attrsANYLEN)
        {
          kind = FFEINFO_kindENTITY;
          where = FFEINFO_whereDUMMY;
        }
      else if (sa & FFESYMBOL_attrsACTUALARG)
        na = FFESYMBOL_attrsetNONE;
      else
        {
          na = sa | FFESYMBOL_attrsDUMMY;
          ns = FFESYMBOL_stateUNCERTAIN;
        }
      break;

    default:
      na = FFESYMBOL_attrsetNONE;       /* Error. */
      break;
    }

  switch (where)
    {
    case FFEINFO_whereDUMMY:
      break;                    /* This is fine. */

    case FFEINFO_whereNONE:
      where = FFEINFO_whereDUMMY;
      break;

    default:
      na = FFESYMBOL_attrsetNONE;       /* Error. */
      break;
    }

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, t);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, ns);
      ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
      ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
      if ((ns == FFESYMBOL_stateUNDERSTOOD)
          && (kind != FFEINFO_kindSUBROUTINE)
          && !ffeimplic_establish_symbol (s))
        {
          ffesymbol_error (s, t);
          return;
        }
      ffesymbol_set_info (s,
                          ffeinfo_new (ffesymbol_basictype (s),
                                       ffesymbol_kindtype (s),
                                       ffesymbol_rank (s),
                                       kind,
                                       where,
                                       ffesymbol_size (s)));
      e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
                             FFEINTRIN_impNONE);
      ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
      ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
      s = ffecom_sym_learned (s);
      ffesymbol_signal_unreported (s);
    }
}

/* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable

   ffestc_promote_sfdummy_(t);

   Invoked for each token in dummy arg list of statement function.

   22-Oct-91  JCB  1.1
      Reject arg if CHARACTER*(*).  */

static void
ffestc_promote_sfdummy_ (ffelexToken t)
{
  ffesymbol s;
  ffesymbol sp;                 /* Parent symbol. */
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffebld e;

  assert (t != NULL);

  s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
                                           also sets sfa_dummy_parent to
                                           parent symbol. */
  if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
    {
      ffesymbol_error (s, t);   /* Dummy already in list. */
      return;
    }

  sp = ffesymbol_sfdummyparent (s);     /* Now flag dummy's parent as used
                                           for dummy. */
  sa = ffesymbol_attrs (sp);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (sp)
      && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
          || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
              && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
              && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
              && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
    na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
  else if (sa & FFESYMBOL_attrsANY)
    na = sa;
  else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
                    | FFESYMBOL_attrsCOMMON
                    | FFESYMBOL_attrsDUMMY
                    | FFESYMBOL_attrsEQUIV
                    | FFESYMBOL_attrsINIT
                    | FFESYMBOL_attrsNAMELIST
                    | FFESYMBOL_attrsRESULT
                    | FFESYMBOL_attrsSAVE
                    | FFESYMBOL_attrsSFARG
                    | FFESYMBOL_attrsTYPE)))
    na = sa | FFESYMBOL_attrsSFARG;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    {
      ffesymbol_error (sp, t);
      ffesymbol_set_info (s, ffeinfo_new_any ());
    }
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
      ffesymbol_set_attrs (sp, na);
      if (!ffeimplic_establish_symbol (sp)
          || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
              && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
        ffesymbol_error (sp, t);
      else
        ffesymbol_set_info (s,
                            ffeinfo_new (ffesymbol_basictype (sp),
                                         ffesymbol_kindtype (sp),
                                         0,
                                         FFEINFO_kindENTITY,
                                         FFEINFO_whereDUMMY,
                                         ffesymbol_size (sp)));

      ffesymbol_signal_unreported (sp);
    }

  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
  ffesymbol_signal_unreported (s);
  e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
                         FFEINTRIN_impNONE);
  ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
  ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
}

/* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement

   ffestc_shriek_begin_program_();

   Invoked only when a PROGRAM statement is NOT present at the beginning
   of a main program unit.  */

static void
ffestc_shriek_begin_program_ ()
{
  ffestw b;
  ffesymbol s;

  ffestc_blocknum_ = 0;
  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, NULL);
  ffestw_set_state (b, FFESTV_statePROGRAM0);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_end_program_);
  ffestw_set_name (b, NULL);

  s = ffesymbol_declare_programunit (NULL,
                                 ffelex_token_where_line (ffesta_tokens[0]),
                              ffelex_token_where_column (ffesta_tokens[0]));

  /* Special case: this is one symbol that won't go through
     ffestu_exec_transition_ when the first statement in a main program is
     executable, because the transition happens in ffest before ffestc is
     reached and triggers the implicit generation of a main program.  So we
     do the exec transition for the implicit main program right here, just
     for cleanliness' sake (at the very least). */

  ffesymbol_set_info (s,
                      ffeinfo_new (FFEINFO_basictypeNONE,
                                   FFEINFO_kindtypeNONE,
                                   0,
                                   FFEINFO_kindPROGRAM,
                                   FFEINFO_whereLOCAL,
                                   FFETARGET_charactersizeNONE));
  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);

  ffesymbol_signal_unreported (s);

  ffestd_R1102 (s, NULL);
}

/* ffestc_shriek_blockdata_ -- End a BLOCK DATA

   ffestc_shriek_blockdata_(TRUE);  */

static void
ffestc_shriek_blockdata_ (bool ok)
{
  if (!ffesta_seen_first_exec)
    {
      ffesta_seen_first_exec = TRUE;
      ffestd_exec_begin ();
    }

  ffestd_R1112 (ok);

  ffestd_exec_end ();

  if (ffestw_name (ffestw_stack_top ()) != NULL)
    ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
  ffestw_kill (ffestw_pop ());

  ffe_terminate_2 ();
  ffe_init_2 ();
}

/* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc

   ffestc_shriek_do_(TRUE);

   Also invoked by _labeldef_branch_end_ (or, in cases
   of errors, other _labeldef_ functions) when the label definition is
   for a DO-target (LOOPEND) label, once per matching/outstanding DO
   block on the stack.  These cases invoke this function with ok==TRUE, so
   only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE.  */

static void
ffestc_shriek_do_ (bool ok)
{
  ffelab l;

  if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
      && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
    {                           /* DO target is label that is still
                                   undefined. */
      assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
              || (ffelab_type (l) == FFELAB_typeANY));
      if (ffelab_type (l) != FFELAB_typeANY)
        {
          ffelab_set_definition_line (l,
                                      ffewhere_line_use (ffelab_doref_line (l)));
          ffelab_set_definition_column (l,
                                        ffewhere_column_use (ffelab_doref_column (l)));
          ffestv_num_label_defines_++;
        }
      ffestd_labeldef_branch (l);
    }

  ffestd_do (ok);

  if (ffestw_name (ffestw_stack_top ()) != NULL)
    ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
  if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
    ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
  if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
    ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
  ffestw_kill (ffestw_pop ());
}

/* ffestc_shriek_end_program_ -- End a PROGRAM

   ffestc_shriek_end_program_();  */

static void
ffestc_shriek_end_program_ (bool ok)
{
  if (!ffesta_seen_first_exec)
    {
      ffesta_seen_first_exec = TRUE;
      ffestd_exec_begin ();
    }

  ffestd_R1103 (ok);

  ffestd_exec_end ();

  if (ffestw_name (ffestw_stack_top ()) != NULL)
    ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
  ffestw_kill (ffestw_pop ());

  ffe_terminate_2 ();
  ffe_init_2 ();
}

/* ffestc_shriek_function_ -- End a FUNCTION

   ffestc_shriek_function_(TRUE);  */

static void
ffestc_shriek_function_ (bool ok)
{
  if (!ffesta_seen_first_exec)
    {
      ffesta_seen_first_exec = TRUE;
      ffestd_exec_begin ();
    }

  ffestd_R1221 (ok);

  ffestd_exec_end ();

  ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
  ffestw_kill (ffestw_pop ());
  ffesta_is_entry_valid = FALSE;

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffe_terminate_2 ();
      ffe_init_2 ();
      break;

    default:
      ffe_terminate_3 ();
      ffe_init_3 ();
      break;

    case FFESTV_stateINTERFACE0:
      ffe_terminate_4 ();
      ffe_init_4 ();
      break;
    }
}

/* ffestc_shriek_if_ -- End of statement following logical IF

   ffestc_shriek_if_(TRUE);

   Applies ONLY to logical IF, not to IF-THEN.  For example, does not
   ffelex_token_kill the construct name for an IF-THEN block (the name
   field is invalid for logical IF).  ok==TRUE iff statement following
   logical IF (substatement) is valid; else, statement is invalid or
   stack forcibly popped due to ffestc_eof().  */

static void
ffestc_shriek_if_ (bool ok)
{
  ffestd_end_R807 (ok);

  ffestw_kill (ffestw_pop ());
  ffestc_shriek_after1_ = NULL;

  ffestc_try_shriek_do_ ();
}

/* ffestc_shriek_ifthen_ -- End an IF-THEN

   ffestc_shriek_ifthen_(TRUE);  */

static void
ffestc_shriek_ifthen_ (bool ok)
{
  ffestd_R806 (ok);

  if (ffestw_name (ffestw_stack_top ()) != NULL)
    ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
  ffestw_kill (ffestw_pop ());

  ffestc_try_shriek_do_ ();
}

/* ffestc_shriek_select_ -- End a SELECT

   ffestc_shriek_select_(TRUE);  */

static void
ffestc_shriek_select_ (bool ok)
{
  ffestwSelect s;
  ffestwCase c;

  ffestd_R811 (ok);

  if (ffestw_name (ffestw_stack_top ()) != NULL)
    ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
  s = ffestw_select (ffestw_stack_top ());
  ffelex_token_kill (s->t);
  for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
    ffelex_token_kill (c->t);
  malloc_pool_kill (s->pool);

  ffestw_kill (ffestw_pop ());

  ffestc_try_shriek_do_ ();
}

/* ffestc_shriek_subroutine_ -- End a SUBROUTINE

   ffestc_shriek_subroutine_(TRUE);  */

static void
ffestc_shriek_subroutine_ (bool ok)
{
  if (!ffesta_seen_first_exec)
    {
      ffesta_seen_first_exec = TRUE;
      ffestd_exec_begin ();
    }

  ffestd_R1225 (ok);

  ffestd_exec_end ();

  ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
  ffestw_kill (ffestw_pop ());
  ffesta_is_entry_valid = FALSE;

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffe_terminate_2 ();
      ffe_init_2 ();
      break;

    default:
      ffe_terminate_3 ();
      ffe_init_3 ();
      break;

    case FFESTV_stateINTERFACE0:
      ffe_terminate_4 ();
      ffe_init_4 ();
      break;
    }
}

/* ffestc_subr_binsrch_ -- Binary search of char const in list of strings

   i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");

   search_list contains search_list_size char *'s, spec is checked to see
   if it is a char constant and, if so, is binary-searched against the list.
   0 is returned if not found, else the "classic" index (beginning with 1)
   is returned.  Before returning 0 where the search was performed but
   fruitless, if "etc" is a non-NULL char *, an error message is displayed
   using "etc" as the pick-one-of-these string.  */

static int
ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
                      const char *whine)
{
  int lowest_tested;
  int highest_tested;
  int halfway;
  int offset;
  int c;
  const char *str;
  int len;

  if (size == 0)
    return 0;                   /* Nobody should pass size == 0, but for
                                   elegance.... */

  lowest_tested = -1;
  highest_tested = size;
  halfway = size >> 1;

  list += halfway;

  c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
  if (c == 2)
    return 0;
  c = -c;                       /* Sigh.  */

next:                           /* :::::::::::::::::::: */
  switch (c)
    {
    case -1:
      offset = (halfway - lowest_tested) >> 1;
      if (offset == 0)
        goto nope;              /* :::::::::::::::::::: */
      highest_tested = halfway;
      list -= offset;
      halfway -= offset;
      c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
      goto next;                /* :::::::::::::::::::: */

    case 0:
      return halfway + 1;

    case 1:
      offset = (highest_tested - halfway) >> 1;
      if (offset == 0)
        goto nope;              /* :::::::::::::::::::: */
      lowest_tested = halfway;
      list += offset;
      halfway += offset;
      c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
      goto next;                /* :::::::::::::::::::: */

    default:
      assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
      break;
    }

nope:                           /* :::::::::::::::::::: */
  ffebad_start (FFEBAD_SPEC_VALUE);
  ffebad_here (0, ffelex_token_where_line (spec->value),
               ffelex_token_where_column (spec->value));
  ffebad_string (whine);
  ffebad_finish ();
  return 0;
}

/* ffestc_subr_format_ -- Return summary of format specifier

   ffestc_subr_format_(&specifier);  */

static ffestvFormat
ffestc_subr_format_ (ffestpFile *spec)
{
  if (!spec->kw_or_val_present)
    return FFESTV_formatNONE;
  assert (spec->value_present);
  if (spec->value_is_label)
    return FFESTV_formatLABEL;  /* Ok if not a label. */

  assert (spec->value != NULL);
  if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
    return FFESTV_formatASTERISK;

  if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
    return FFESTV_formatNAMELIST;

  if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
    return FFESTV_formatCHAREXPR;       /* F77 C5. */

  switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
    {
    case FFEINFO_basictypeINTEGER:
      return FFESTV_formatINTEXPR;

    case FFEINFO_basictypeCHARACTER:
      return FFESTV_formatCHAREXPR;

    case FFEINFO_basictypeANY:
      return FFESTV_formatASTERISK;

    default:
      assert ("bad basictype" == NULL);
      return FFESTV_formatINTEXPR;
    }
}

/* ffestc_subr_is_branch_ -- Handle specifier as branch target label

   ffestc_subr_is_branch_(&specifier);  */

static bool
ffestc_subr_is_branch_ (ffestpFile *spec)
{
  if (!spec->kw_or_val_present)
    return TRUE;
  assert (spec->value_present);
  assert (spec->value_is_label);
  spec->value_is_label++;       /* For checking purposes only; 1=>2. */
  return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
}

/* ffestc_subr_is_format_ -- Handle specifier as format target label

   ffestc_subr_is_format_(&specifier);  */

static bool
ffestc_subr_is_format_ (ffestpFile *spec)
{
  if (!spec->kw_or_val_present)
    return TRUE;
  assert (spec->value_present);
  if (!spec->value_is_label)
    return TRUE;                /* Ok if not a label. */

  spec->value_is_label++;       /* For checking purposes only; 1=>2. */
  return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
}

/* ffestc_subr_is_present_ -- Ensure specifier is present, else error

   ffestc_subr_is_present_("SPECIFIER",&specifier);  */

static bool
ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
{
  if (spec->kw_or_val_present)
    {
      assert (spec->value_present);
      return TRUE;
    }

  ffebad_start (FFEBAD_MISSING_SPECIFIER);
  ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
               ffelex_token_where_column (ffesta_tokens[0]));
  ffebad_string (name);
  ffebad_finish ();
  return FALSE;
}

/* ffestc_subr_speccmp_ -- Compare string to constant expression, if present

   if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
       // specifier value is present and is a char constant "CONSTANT"

   Like strcmp, except the return values are defined as: -1 returned in place
   of strcmp's generic negative value, 1 in place of it's generic positive
   value, and 2 when there is no character constant string to compare.  Also,
   a case-insensitive comparison is performed, where string is assumed to
   already be in InitialCaps form.

   If a non-NULL pointer is provided as the char **target, then *target is
   written with NULL if 2 is returned, a pointer to the constant string
   value of the specifier otherwise.  Similarly, length is written with
   0 if 2 is returned, the length of the constant string value otherwise.  */

static int
ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
                      int *length)
{
  ffebldConstant c;
  int i;

  if (!spec->kw_or_val_present || !spec->value_present
      || (spec->u.expr == NULL)
      || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
    {
      if (target != NULL)
        *target = NULL;
      if (length != NULL)
        *length = 0;
      return 2;
    }

  if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
      != FFEBLD_constCHARACTERDEFAULT)
    {
      if (target != NULL)
        *target = NULL;
      if (length != NULL)
        *length = 0;
      return 2;
    }

  if (target != NULL)
    *target = ffebld_constant_characterdefault (c).text;
  if (length != NULL)
    *length = ffebld_constant_characterdefault (c).length;

  i = ffesrc_strcmp_1ns2i (ffe_case_match (),
                           ffebld_constant_characterdefault (c).text,
                           ffebld_constant_characterdefault (c).length,
                           string);
  if (i == 0)
    return 0;
  if (i > 0)
    return -1;                  /* Yes indeed, we reverse the strings to
                                   _strcmpin_.   */
  return 1;
}

/* ffestc_subr_unit_ -- Return summary of unit specifier

   ffestc_subr_unit_(&specifier);  */

static ffestvUnit
ffestc_subr_unit_ (ffestpFile *spec)
{
  if (!spec->kw_or_val_present)
    return FFESTV_unitNONE;
  assert (spec->value_present);
  assert (spec->value != NULL);

  if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
    return FFESTV_unitASTERISK;

  switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
    {
    case FFEINFO_basictypeINTEGER:
      return FFESTV_unitINTEXPR;

    case FFEINFO_basictypeCHARACTER:
      return FFESTV_unitCHAREXPR;

    case FFEINFO_basictypeANY:
      return FFESTV_unitASTERISK;

    default:
      assert ("bad basictype" == NULL);
      return FFESTV_unitINTEXPR;
    }
}

/* Call this function whenever it's possible that one or more top
   stack items are label-targeting DO blocks that have had their
   labels defined, but at a time when they weren't at the top of the
   stack.  This prevents uninformative diagnostics for programs
   like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END".  */

static void
ffestc_try_shriek_do_ ()
{
  ffelab lab;
  ffelabType ty;

  while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
         && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
         && (((ty = (ffelab_type (lab)))
              == FFELAB_typeANY)
             || (ty == FFELAB_typeUSELESS)
             || (ty == FFELAB_typeFORMAT)
             || (ty == FFELAB_typeNOTLOOP)
             || (ty == FFELAB_typeENDIF)))
    ffestc_shriek_do_ (FALSE);
}

/* ffestc_decl_start -- R426 or R501

   ffestc_decl_start(...);

   Verify that R426 component-def-stmt or R501 type-declaration-stmt are
   valid here, figure out which one, and implement.  */

void
ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
                   ffelexToken kindt, ffebld len, ffelexToken lent)
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
    case FFESTV_statePROGRAM0:
    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateFUNCTION0:
    case FFESTV_stateMODULE0:
    case FFESTV_stateBLOCKDATA0:
    case FFESTV_statePROGRAM1:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateMODULE1:
    case FFESTV_stateBLOCKDATA1:
    case FFESTV_statePROGRAM2:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateMODULE2:
    case FFESTV_stateBLOCKDATA2:
    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateMODULE3:
    case FFESTV_stateBLOCKDATA3:
    case FFESTV_stateUSE:
      ffestc_local_.decl.is_R426 = 2;
      break;

    case FFESTV_stateTYPE:
    case FFESTV_stateSTRUCTURE:
    case FFESTV_stateMAP:
      ffestc_local_.decl.is_R426 = 1;
      break;

    default:
      ffestc_order_bad_ ();
      ffestc_labeldef_useless_ ();
      ffestc_local_.decl.is_R426 = 0;
      return;
    }

  switch (ffestc_local_.decl.is_R426)
    {
    case 2:
      ffestc_R501_start (type, typet, kind, kindt, len, lent);
      break;

    default:
      ffestc_labeldef_useless_ ();
      break;
    }
}

/* ffestc_decl_attrib -- R426 or R501 type attribute

   ffestc_decl_attrib(...);

   Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
   is valid here and implement.  */

void
ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
                    ffelexToken attribt UNUSED,
                    ffestrOther intent_kw UNUSED,
                    ffesttDimList dims UNUSED)
{
  ffebad_start (FFEBAD_F90);
  ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
               ffelex_token_where_column (ffesta_tokens[0]));
  ffebad_finish ();
  return;
}

/* ffestc_decl_item -- R426 or R501

   ffestc_decl_item(...);

   Establish type for a particular object.  */

void
ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
              ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
                  ffelexToken initt, bool clist)
{
  switch (ffestc_local_.decl.is_R426)
    {
    case 2:
      ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
                        clist);
      break;

    default:
      break;
    }
}

/* ffestc_decl_itemstartvals -- R426 or R501 start list of values

   ffestc_decl_itemstartvals();

   Gonna specify values for the object now.  */

void
ffestc_decl_itemstartvals ()
{
  switch (ffestc_local_.decl.is_R426)
    {
    case 2:
      ffestc_R501_itemstartvals ();
      break;

    default:
      break;
    }
}

/* ffestc_decl_itemvalue -- R426 or R501 source value

   ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);

   Make sure repeat and value are valid for the object being initialized.  */

void
ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
                       ffebld value, ffelexToken value_token)
{
  switch (ffestc_local_.decl.is_R426)
    {
    case 2:
      ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
      break;

    default:
      break;
    }
}

/* ffestc_decl_itemendvals -- R426 or R501 end list of values

   ffelexToken t;  // the SLASH token that ends the list.
   ffestc_decl_itemendvals(t);

   No more values, might specify more objects now.  */

void
ffestc_decl_itemendvals (ffelexToken t)
{
  switch (ffestc_local_.decl.is_R426)
    {
    case 2:
      ffestc_R501_itemendvals (t);
      break;

    default:
      break;
    }
}

/* ffestc_decl_finish -- R426 or R501

   ffestc_decl_finish();

   Just wrap up any local activities.  */

void
ffestc_decl_finish ()
{
  switch (ffestc_local_.decl.is_R426)
    {
    case 2:
      ffestc_R501_finish ();
      break;

    default:
      break;
    }
}

/* ffestc_elsewhere -- Generic ELSE WHERE statement

   ffestc_end();

   Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant.  */

void
ffestc_elsewhere (ffelexToken where)
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateIFTHEN:
      ffestc_R805 (where);
      break;

    default:
      break;
    }
}

/* ffestc_end -- Generic END statement

   ffestc_end();

   Make sure a generic END is valid in the current context, and implement
   it.  */

void
ffestc_end ()
{
  ffestw b;

  b = ffestw_stack_top ();

recurse:

  switch (ffestw_state (b))
    {
    case FFESTV_stateBLOCKDATA0:
    case FFESTV_stateBLOCKDATA1:
    case FFESTV_stateBLOCKDATA2:
    case FFESTV_stateBLOCKDATA3:
    case FFESTV_stateBLOCKDATA4:
    case FFESTV_stateBLOCKDATA5:
      ffestc_R1112 (NULL);
      break;

    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateFUNCTION4:
    case FFESTV_stateFUNCTION5:
      if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
          && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
        {
          ffebad_start (FFEBAD_END_WO);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
          ffebad_string ("FUNCTION");
          ffebad_finish ();
        }
      ffestc_R1221 (NULL);
      break;

    case FFESTV_stateMODULE0:
    case FFESTV_stateMODULE1:
    case FFESTV_stateMODULE2:
    case FFESTV_stateMODULE3:
    case FFESTV_stateMODULE4:
    case FFESTV_stateMODULE5:
      break;

    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateSUBROUTINE5:
      if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
          && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
        {
          ffebad_start (FFEBAD_END_WO);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
          ffebad_string ("SUBROUTINE");
          ffebad_finish ();
        }
      ffestc_R1225 (NULL);
      break;

    case FFESTV_stateUSE:
      b = ffestw_previous (ffestw_stack_top ());
      goto recurse;             /* :::::::::::::::::::: */

    default:
      ffestc_R1103 (NULL);
      break;
    }
}

/* ffestc_eof -- Generic EOF

   ffestc_eof();

   Make sure we're at state NIL, or issue an error message and use each
   block's shriek function to clean up to state NIL.  */

void
ffestc_eof ()
{
  if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
    {
      ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
      ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
      ffebad_finish ();
      do
        (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
      while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
    }
}

/* ffestc_exec_transition -- Check if ok and move stmt state to executable

   if (ffestc_exec_transition())
       // Transition successful (kind of like a CONTINUE stmt was seen).

   If the current statement state is a non-nested specification state in
   which, say, a CONTINUE statement would be valid, then enter the state
   we'd be in after seeing CONTINUE (without, of course, generating any
   CONTINUE code), call ffestd_exec_begin, and return TRUE.  Otherwise
   return FALSE.

   This function cannot be invoked once the first executable statement
   is seen.  This function may choose to always return TRUE by shrieking
   away any interceding state stack entries to reach the base level of
   specification state, but right now it doesn't, and it is (or should
   be) purely an issue of how one wishes errors to be handled (for example,
   an unrecognized statement in the middle of a STRUCTURE construct: after
   the error message, should subsequent statements still be interpreted as
   being within the construct, or should the construct be terminated upon
   seeing the unrecognized statement?  we do the former at the moment).  */

bool
ffestc_exec_transition ()
{
  bool update;

recurse:

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
      ffestc_shriek_begin_program_ ();
      goto recurse;             /* :::::::::::::::::::: */

    case FFESTV_statePROGRAM0:
    case FFESTV_stateSUBROUTINE0:
    case FFESTV_stateFUNCTION0:
    case FFESTV_stateBLOCKDATA0:
      ffestw_state (ffestw_stack_top ()) += 4;  /* To state UNIT4. */
      update = TRUE;
      break;

    case FFESTV_statePROGRAM1:
    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateBLOCKDATA1:
      ffestw_state (ffestw_stack_top ()) += 3;  /* To state UNIT4. */
      update = TRUE;
      break;

    case FFESTV_statePROGRAM2:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateBLOCKDATA2:
      ffestw_state (ffestw_stack_top ()) += 2;  /* To state UNIT4. */
      update = TRUE;
      break;

    case FFESTV_statePROGRAM3:
    case FFESTV_stateSUBROUTINE3:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateBLOCKDATA3:
      ffestw_state (ffestw_stack_top ()) += 1;  /* To state UNIT4. */
      update = TRUE;
      break;

    case FFESTV_stateUSE:
      goto recurse;             /* :::::::::::::::::::: */

    default:
      return FALSE;
    }

  if (update)
    ffestw_update (NULL);       /* Update state line/col info. */

  ffesta_seen_first_exec = TRUE;
  ffestd_exec_begin ();

  return TRUE;
}

/* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var

   ffesymbol s;
   // call ffebad_start first, of course.
   ffestc_ffebad_here_doiter(0,s);
   // call ffebad_finish afterwards, naturally.

   Searches the stack of blocks backwards for a DO loop that has s
   as its iteration variable, then calls ffebad_here with pointers to
   that particular reference to the variable.  Crashes if the DO loop
   can't be found.  */

void
ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
{
  ffestw block;

  for (block = ffestw_top_do (ffestw_stack_top ());
       (block != NULL) && (ffestw_blocknum (block) != 0);
       block = ffestw_top_do (ffestw_previous (block)))
    {
      if (ffestw_do_iter_var (block) == s)
        {
          ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
                  ffelex_token_where_column (ffestw_do_iter_var_t (block)));
          return;
        }
    }
  assert ("no do block found" == NULL);
}

/* ffestc_is_decl_not_R1219 -- Context information for FFESTB

   if (ffestc_is_decl_not_R1219()) ...

   When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
   is seen, call this function.  It returns TRUE if the statement's context
   is such that it is a declaration of an object named
   "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
   if the statement's context is such that it begins the definition of a
   function named "name" havin the dummy argument list "name-list" (this
   is the R1219 function-stmt case).  */

bool
ffestc_is_decl_not_R1219 ()
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateNIL:
    case FFESTV_statePROGRAM5:
    case FFESTV_stateSUBROUTINE5:
    case FFESTV_stateFUNCTION5:
    case FFESTV_stateMODULE5:
    case FFESTV_stateINTERFACE0:
      return FALSE;

    default:
      return TRUE;
    }
}

/* ffestc_is_entry_in_subr -- Context information for FFESTB

   if (ffestc_is_entry_in_subr()) ...

   When a statement with the form "ENTRY name(name-list)"
   is seen, call this function.  It returns TRUE if the statement's context
   is such that it may have "*", meaning alternate return, in place of
   names in the name list (i.e. if the ENTRY is in a subroutine context).
   It also returns TRUE if the ENTRY is not in a function context (invalid
   but prevents extra complaints about "*", if present).  It returns FALSE
   if the ENTRY is in a function context.  */

bool
ffestc_is_entry_in_subr ()
{
  ffestvState s;

  s = ffestw_state (ffestw_stack_top ());

recurse:

  switch (s)
    {
    case FFESTV_stateFUNCTION0:
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
    case FFESTV_stateFUNCTION4:
      return FALSE;

    case FFESTV_stateUSE:
      s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
      goto recurse;             /* :::::::::::::::::::: */

    default:
      return TRUE;
    }
}

/* ffestc_is_let_not_V027 -- Context information for FFESTB

   if (ffestc_is_let_not_V027()) ...

   When a statement with the form "PARAMETERname=expr"
   is seen, call this function.  It returns TRUE if the statement's context
   is such that it is an assignment to an object named "PARAMETERname", FALSE
   if the statement's context is such that it is a V-extension PARAMETER
   statement that is like a PARAMETER(name=expr) statement except that the
   type of name is determined by the type of expr, not the implicit or
   explicit typing of name.  */

bool
ffestc_is_let_not_V027 ()
{
  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_statePROGRAM4:
    case FFESTV_stateSUBROUTINE4:
    case FFESTV_stateFUNCTION4:
    case FFESTV_stateWHERETHEN:
    case FFESTV_stateIFTHEN:
    case FFESTV_stateDO:
    case FFESTV_stateSELECT0:
    case FFESTV_stateSELECT1:
    case FFESTV_stateWHERE:
    case FFESTV_stateIF:
      return TRUE;

    default:
      return FALSE;
    }
}

/* ffestc_terminate_4 -- Terminate ffestc after scoping unit

   ffestc_terminate_4();

   For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
   defs, and statement function defs.  */

void
ffestc_terminate_4 ()
{
  ffestc_entry_num_ = ffestc_saved_entry_num_;
}

/* ffestc_R501_start -- type-declaration-stmt

   ffestc_R501_start(...);

   Verify that R501 type-declaration-stmt is
   valid here and implement.  */

void
ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
                   ffelexToken kindt, ffebld len, ffelexToken lent)
{
  ffestc_check_start_ ();
  if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
    {
      ffestc_local_.decl.is_R426 = 0;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
}

/* ffestc_R501_attrib -- type attribute

   ffestc_R501_attrib(...);

   Verify that R501 type-declaration-stmt attribute
   is valid here and implement.  */

void
ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
                    ffestrOther intent_kw UNUSED,
                    ffesttDimList dims UNUSED)
{
  ffestc_check_attrib_ ();

  switch (attrib)
    {
    case FFESTP_attribDIMENSION:
      ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
      break;

    case FFESTP_attribEXTERNAL:
      break;

    case FFESTP_attribINTRINSIC:
      break;

    case FFESTP_attribPARAMETER:
      break;

    case FFESTP_attribSAVE:
      switch (ffestv_save_state_)
        {
        case FFESTV_savestateNONE:
          ffestv_save_state_ = FFESTV_savestateSPECIFIC;
          ffestv_save_line_
            = ffewhere_line_use (ffelex_token_where_line (attribt));
          ffestv_save_col_
            = ffewhere_column_use (ffelex_token_where_column (attribt));
          break;

        case FFESTV_savestateSPECIFIC:
        case FFESTV_savestateANY:
          break;

        case FFESTV_savestateALL:
          if (ffe_is_pedantic ())
            {
              ffebad_start (FFEBAD_CONFLICTING_SAVES);
              ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
              ffebad_here (1, ffelex_token_where_line (attribt),
                           ffelex_token_where_column (attribt));
              ffebad_finish ();
            }
          ffestv_save_state_ = FFESTV_savestateANY;
          break;

        default:
          assert ("unexpected save state" == NULL);
          break;
        }
      break;

    default:
      assert ("unexpected attribute" == NULL);
      break;
    }
}

/* ffestc_R501_item -- declared object

   ffestc_R501_item(...);

   Establish type for a particular object.  */

void
ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
                  ffesttDimList dims, ffebld len, ffelexToken lent,
                  ffebld init, ffelexToken initt, bool clist)
{
  ffesymbol s;
  ffesymbol sfn;                /* FUNCTION symbol. */
  ffebld array_size;
  ffebld extents;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffestpDimtype nd;
  bool is_init = (init != NULL) || clist;
  bool is_assumed;
  bool is_ugly_assumed;
  ffeinfoRank rank;

  ffestc_check_item_ ();
  assert (name != NULL);
  assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
  assert (kind == NULL);        /* No way an expression should get here. */

  ffestc_establish_declinfo_ (kind, kindt, len, lent);

  is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
    && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);

  if ((dims != NULL) || is_init)
    ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);

  s = ffesymbol_declare_local (name, TRUE);
  sa = ffesymbol_attrs (s);

  /* First figure out what kind of object this is based solely on the current
     object situation (type params, dimension list, and initialization). */

  na = FFESYMBOL_attrsTYPE;

  if (is_assumed)
    na |= FFESYMBOL_attrsANYLEN;

  is_ugly_assumed = (ffe_is_ugly_assumed ()
                     && ((sa & FFESYMBOL_attrsDUMMY)
                         || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));

  nd = ffestt_dimlist_type (dims, is_ugly_assumed);
  switch (nd)
    {
    case FFESTP_dimtypeNONE:
      break;

    case FFESTP_dimtypeKNOWN:
      na |= FFESYMBOL_attrsARRAY;
      break;

    case FFESTP_dimtypeADJUSTABLE:
      na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
      break;

    case FFESTP_dimtypeASSUMED:
      na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
      break;

    case FFESTP_dimtypeADJUSTABLEASSUMED:
      na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
        | FFESYMBOL_attrsANYSIZE;
      break;

    default:
      assert ("unexpected dimtype" == NULL);
      na = FFESYMBOL_attrsetNONE;
      break;
    }

  if (!ffesta_is_entry_valid
      && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
           == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
    na = FFESYMBOL_attrsetNONE;

  if (is_init)
    {
      if (na == FFESYMBOL_attrsetNONE)
        ;
      else if (na & (FFESYMBOL_attrsANYLEN
                     | FFESYMBOL_attrsADJUSTABLE
                     | FFESYMBOL_attrsANYSIZE))
        na = FFESYMBOL_attrsetNONE;
      else
        na |= FFESYMBOL_attrsINIT;
    }

  /* Now figure out what kind of object we've got based on previous
     declarations of or references to the object. */

  if (na == FFESYMBOL_attrsetNONE)
    ;
  else if (!ffesymbol_is_specable (s)
           && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
                && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
               || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
                                   dimension/init UNDERSTOODs. */
  else if (sa & FFESYMBOL_attrsANY)
    na = sa;
  else if ((sa & na)
           || ((sa & (FFESYMBOL_attrsSFARG
                      | FFESYMBOL_attrsADJUSTS))
               && (na & (FFESYMBOL_attrsARRAY
                         | FFESYMBOL_attrsANYLEN)))
           || ((sa & FFESYMBOL_attrsRESULT)
               && (na & (FFESYMBOL_attrsARRAY
                         | FFESYMBOL_attrsINIT)))
           || ((sa & (FFESYMBOL_attrsSFUNC
                      | FFESYMBOL_attrsEXTERNAL
                      | FFESYMBOL_attrsINTRINSIC
                      | FFESYMBOL_attrsINIT))
               && (na & (FFESYMBOL_attrsARRAY
                         | FFESYMBOL_attrsANYLEN
                         | FFESYMBOL_attrsINIT)))
           || ((sa & FFESYMBOL_attrsARRAY)
               && !ffesta_is_entry_valid
               && (na & FFESYMBOL_attrsANYLEN))
           || ((sa & (FFESYMBOL_attrsADJUSTABLE
                      | FFESYMBOL_attrsANYLEN
                      | FFESYMBOL_attrsANYSIZE
                      | FFESYMBOL_attrsDUMMY))
               && (na & FFESYMBOL_attrsINIT))
           || ((sa & (FFESYMBOL_attrsSAVE
                      | FFESYMBOL_attrsNAMELIST
                      | FFESYMBOL_attrsCOMMON
                      | FFESYMBOL_attrsEQUIV))
               && (na & (FFESYMBOL_attrsADJUSTABLE
                         | FFESYMBOL_attrsANYLEN
                         | FFESYMBOL_attrsANYSIZE))))
    na = FFESYMBOL_attrsetNONE;
  else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
           && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
           && (na & FFESYMBOL_attrsANYLEN))
    {                           /* If CHARACTER*(*) FOO after PARAMETER FOO. */
      na |= FFESYMBOL_attrsTYPE;
      ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
    }
  else
    na |= sa;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    {
      ffesymbol_error (s, name);
      ffestc_parent_ok_ = FALSE;
    }
  else if (na & FFESYMBOL_attrsANY)
    ffestc_parent_ok_ = FALSE;
  else
    {
      ffesymbol_set_attrs (s, na);
      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      rank = ffesymbol_rank (s);
      if (dims != NULL)
        {
          ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
                                                         &array_size,
                                                         &extents,
                                                         is_ugly_assumed));
          ffesymbol_set_arraysize (s, array_size);
          ffesymbol_set_extents (s, extents);
          if (!(0 && ffe_is_90 ())
              && (ffebld_op (array_size) == FFEBLD_opCONTER)
              && (ffebld_constant_integerdefault (ffebld_conter (array_size))
                  == 0))
            {
              ffebad_start (FFEBAD_ZERO_ARRAY);
              ffebad_here (0, ffelex_token_where_line (name),
                           ffelex_token_where_column (name));
              ffebad_finish ();
            }
        }
      if (init != NULL)
        {
          ffesymbol_set_init (s,
                              ffeexpr_convert (init, initt, name,
                                               ffestc_local_.decl.basic_type,
                                               ffestc_local_.decl.kind_type,
                                               rank,
                                               ffestc_local_.decl.size,
                                               FFEEXPR_contextDATA));
          ffecom_notify_init_symbol (s);
          ffesymbol_update_init (s);
#if FFEGLOBAL_ENABLED
          if (ffesymbol_common (s) != NULL)
            ffeglobal_init_common (ffesymbol_common (s), initt);
#endif
        }
      else if (clist)
        {
          ffebld symter;

          symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
                                      FFEINTRIN_specNONE,
                                      FFEINTRIN_impNONE);

          ffebld_set_info (symter,
                           ffeinfo_new (ffestc_local_.decl.basic_type,
                                        ffestc_local_.decl.kind_type,
                                        rank,
                                        FFEINFO_kindNONE,
                                        FFEINFO_whereNONE,
                                        ffestc_local_.decl.size));
          ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
        }
      if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
        {
          ffesymbol_set_info (s,
                              ffeinfo_new (ffestc_local_.decl.basic_type,
                                           ffestc_local_.decl.kind_type,
                                           rank,
                                           ffesymbol_kind (s),
                                           ffesymbol_where (s),
                                           ffestc_local_.decl.size));
          if ((na & FFESYMBOL_attrsRESULT)
              && ((sfn = ffesymbol_funcresult (s)) != NULL))
            {
              ffesymbol_set_info (sfn,
                                  ffeinfo_new (ffestc_local_.decl.basic_type,
                                               ffestc_local_.decl.kind_type,
                                               rank,
                                               ffesymbol_kind (sfn),
                                               ffesymbol_where (sfn),
                                               ffestc_local_.decl.size));
              ffesymbol_signal_unreported (sfn);
            }
        }
      else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
               || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
               || ((ffestc_local_.decl.basic_type
                    == FFEINFO_basictypeCHARACTER)
                   && (ffestc_local_.decl.size != ffesymbol_size (s))))
        {                       /* Explicit type disagrees with established
                                   implicit type. */
          ffesymbol_error (s, name);
        }

      if ((na & FFESYMBOL_attrsADJUSTS)
          && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
              || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
        ffesymbol_error (s, name);

      ffesymbol_signal_unreported (s);
      ffestc_parent_ok_ = TRUE;
    }
}

/* ffestc_R501_itemstartvals -- Start list of values

   ffestc_R501_itemstartvals();

   Gonna specify values for the object now.  */

void
ffestc_R501_itemstartvals ()
{
  ffestc_check_item_startvals_ ();

  if (ffestc_parent_ok_)
    ffedata_begin (ffestc_local_.decl.initlist);
}

/* ffestc_R501_itemvalue -- Source value

   ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);

   Make sure repeat and value are valid for the object being initialized.  */

void
ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
                       ffebld value, ffelexToken value_token)
{
  ffetargetIntegerDefault rpt;

  ffestc_check_item_value_ ();

  if (!ffestc_parent_ok_)
    return;

  if (repeat == NULL)
    rpt = 1;
  else if (ffebld_op (repeat) == FFEBLD_opCONTER)
    rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
  else
    {
      ffestc_parent_ok_ = FALSE;
      ffedata_end (TRUE, NULL);
      return;
    }

  if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
                      (repeat_token == NULL) ? value_token : repeat_token)))
    ffedata_end (TRUE, NULL);
}

/* ffestc_R501_itemendvals -- End list of values

   ffelexToken t;  // the SLASH token that ends the list.
   ffestc_R501_itemendvals(t);

   No more values, might specify more objects now.  */

void
ffestc_R501_itemendvals (ffelexToken t)
{
  ffestc_check_item_endvals_ ();

  if (ffestc_parent_ok_)
    ffestc_parent_ok_ = ffedata_end (FALSE, t);

  if (ffestc_parent_ok_)
    ffesymbol_signal_unreported (ffebld_symter (ffebld_head
                                             (ffestc_local_.decl.initlist)));
}

/* ffestc_R501_finish -- Done

   ffestc_R501_finish();

   Just wrap up any local activities.  */

void
ffestc_R501_finish ()
{
  ffestc_check_finish_ ();
}

/* ffestc_R522 -- SAVE statement with no list

   ffestc_R522();

   Verify that SAVE is valid here, and flag everything as SAVEd.  */

void
ffestc_R522 ()
{
  ffestc_check_simple_ ();
  if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  switch (ffestv_save_state_)
    {
    case FFESTV_savestateNONE:
      ffestv_save_state_ = FFESTV_savestateALL;
      ffestv_save_line_
        = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
      ffestv_save_col_
        = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
      break;

    case FFESTV_savestateANY:
      break;

    case FFESTV_savestateSPECIFIC:
    case FFESTV_savestateALL:
      if (ffe_is_pedantic ())
        {
          ffebad_start (FFEBAD_CONFLICTING_SAVES);
          ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
          ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_finish ();
        }
      ffestv_save_state_ = FFESTV_savestateALL;
      break;

    default:
      assert ("unexpected save state" == NULL);
      break;
    }

  ffe_set_is_saveall (TRUE);

  ffestd_R522 ();
}

/* ffestc_R522start -- SAVE statement list begin

   ffestc_R522start();

   Verify that SAVE is valid here, and begin accepting items in the list.  */

void
ffestc_R522start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  switch (ffestv_save_state_)
    {
    case FFESTV_savestateNONE:
      ffestv_save_state_ = FFESTV_savestateSPECIFIC;
      ffestv_save_line_
        = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
      ffestv_save_col_
        = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
      break;

    case FFESTV_savestateSPECIFIC:
    case FFESTV_savestateANY:
      break;

    case FFESTV_savestateALL:
      if (ffe_is_pedantic ())
        {
          ffebad_start (FFEBAD_CONFLICTING_SAVES);
          ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
          ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_finish ();
        }
      ffestv_save_state_ = FFESTV_savestateANY;
      break;

    default:
      assert ("unexpected save state" == NULL);
      break;
    }

  ffestd_R522start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_R522item_object -- SAVE statement for object-name

   ffestc_R522item_object(name_token);

   Make sure name_token identifies a valid object to be SAVEd.  */

void
ffestc_R522item_object (ffelexToken name)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;

  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  s = ffesymbol_declare_local (name, FALSE);
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (s)
      && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
          || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
  else if (sa & FFESYMBOL_attrsANY)
    na = sa;
  else if (!(sa & ~(FFESYMBOL_attrsARRAY
                    | FFESYMBOL_attrsEQUIV
                    | FFESYMBOL_attrsINIT
                    | FFESYMBOL_attrsNAMELIST
                    | FFESYMBOL_attrsSFARG
                    | FFESYMBOL_attrsTYPE)))
    na = sa | FFESYMBOL_attrsSAVE;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, name);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_update_save (s);
      ffesymbol_signal_unreported (s);
    }

  ffestd_R522item_object (name);
}

/* ffestc_R522item_cblock -- SAVE statement for common-block-name

   ffestc_R522item_cblock(name_token);

   Make sure name_token identifies a valid common block to be SAVEd.  */

void
ffestc_R522item_cblock (ffelexToken name)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;

  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
                              ffelex_token_where_column (ffesta_tokens[0]));
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (s))
    na = FFESYMBOL_attrsetNONE;
  else if (sa & FFESYMBOL_attrsANY)
    na = sa;                    /* Already have an error here, say nothing. */
  else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
    na = sa | FFESYMBOL_attrsSAVECBLOCK;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_update_save (s);
      ffesymbol_signal_unreported (s);
    }

  ffestd_R522item_cblock (name);
}

/* ffestc_R522finish -- SAVE statement list complete

   ffestc_R522finish();

   Just wrap up any local activities.  */

void
ffestc_R522finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R522finish ();
}

/* ffestc_R524_start -- DIMENSION statement list begin

   ffestc_R524_start(bool virtual);

   Verify that DIMENSION is valid here, and begin accepting items in the
   list.  */

void
ffestc_R524_start (bool virtual)
{
  ffestc_check_start_ ();
  if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestd_R524_start (virtual);

  ffestc_ok_ = TRUE;
}

/* ffestc_R524_item -- DIMENSION statement for object-name

   ffestc_R524_item(name_token,dim_list);

   Make sure name_token identifies a valid object to be DIMENSIONd.  */

void
ffestc_R524_item (ffelexToken name, ffesttDimList dims)
{
  ffesymbol s;
  ffebld array_size;
  ffebld extents;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffestpDimtype nd;
  ffeinfoRank rank;
  bool is_ugly_assumed;

  ffestc_check_item_ ();
  assert (name != NULL);
  assert (dims != NULL);
  if (!ffestc_ok_)
    return;

  ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);

  s = ffesymbol_declare_local (name, FALSE);
  sa = ffesymbol_attrs (s);

  /* First figure out what kind of object this is based solely on the current
     object situation (dimension list). */

  is_ugly_assumed = (ffe_is_ugly_assumed ()
                     && ((sa & FFESYMBOL_attrsDUMMY)
                         || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));

  nd = ffestt_dimlist_type (dims, is_ugly_assumed);
  switch (nd)
    {
    case FFESTP_dimtypeKNOWN:
      na = FFESYMBOL_attrsARRAY;
      break;

    case FFESTP_dimtypeADJUSTABLE:
      na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
      break;

    case FFESTP_dimtypeASSUMED:
      na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
      break;

    case FFESTP_dimtypeADJUSTABLEASSUMED:
      na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
        | FFESYMBOL_attrsANYSIZE;
      break;

    default:
      assert ("Unexpected dims type" == NULL);
      na = FFESYMBOL_attrsetNONE;
      break;
    }

  /* Now figure out what kind of object we've got based on previous
     declarations of or references to the object. */

  if (!ffesymbol_is_specable (s))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
  else if (sa & FFESYMBOL_attrsANY)
    na = FFESYMBOL_attrsANY;
  else if (!ffesta_is_entry_valid
           && (sa & FFESYMBOL_attrsANYLEN))
    na = FFESYMBOL_attrsetNONE;
  else if ((sa & FFESYMBOL_attrsARRAY)
           || ((sa & (FFESYMBOL_attrsCOMMON
                      | FFESYMBOL_attrsEQUIV
                      | FFESYMBOL_attrsNAMELIST
                      | FFESYMBOL_attrsSAVE))
               && (na & (FFESYMBOL_attrsADJUSTABLE
                         | FFESYMBOL_attrsANYSIZE))))
    na = FFESYMBOL_attrsetNONE;
  else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
                    | FFESYMBOL_attrsANYLEN
                    | FFESYMBOL_attrsANYSIZE
                    | FFESYMBOL_attrsCOMMON
                    | FFESYMBOL_attrsDUMMY
                    | FFESYMBOL_attrsEQUIV
                    | FFESYMBOL_attrsNAMELIST
                    | FFESYMBOL_attrsSAVE
                    | FFESYMBOL_attrsTYPE)))
    na |= sa;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, name);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
                                                     &array_size,
                                                     &extents,
                                                     is_ugly_assumed));
      ffesymbol_set_arraysize (s, array_size);
      ffesymbol_set_extents (s, extents);
      if (!(0 && ffe_is_90 ())
          && (ffebld_op (array_size) == FFEBLD_opCONTER)
          && (ffebld_constant_integerdefault (ffebld_conter (array_size))
              == 0))
        {
          ffebad_start (FFEBAD_ZERO_ARRAY);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_finish ();
        }
      ffesymbol_set_info (s,
                          ffeinfo_new (ffesymbol_basictype (s),
                                       ffesymbol_kindtype (s),
                                       rank,
                                       ffesymbol_kind (s),
                                       ffesymbol_where (s),
                                       ffesymbol_size (s)));
    }

  ffesymbol_signal_unreported (s);

  ffestd_R524_item (name, dims);
}

/* ffestc_R524_finish -- DIMENSION statement list complete

   ffestc_R524_finish();

   Just wrap up any local activities.  */

void
ffestc_R524_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R524_finish ();
}

/* ffestc_R528_start -- DATA statement list begin

   ffestc_R528_start();

   Verify that DATA is valid here, and begin accepting items in the list.  */

void
ffestc_R528_start ()
{
  ffestcOrder_ order;

  ffestc_check_start_ ();
  if (ffe_is_pedantic_not_90 ())
    order = ffestc_order_data77_ ();
  else
    order = ffestc_order_data_ ();
  if (order != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);

#if 1
  ffestc_local_.data.objlist = NULL;
#else
  ffestd_R528_start_ ();
#endif

  ffestc_ok_ = TRUE;
}

/* ffestc_R528_item_object -- DATA statement target object

   ffestc_R528_item_object(object,object_token);

   Make sure object is valid to be DATAd.  */

void
ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

#if 1
  if (ffestc_local_.data.objlist == NULL)
    ffebld_init_list (&ffestc_local_.data.objlist,
                      &ffestc_local_.data.list_bottom);

  ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
#else
  ffestd_R528_item_object_ (expr, expr_token);
#endif
}

/* ffestc_R528_item_startvals -- DATA statement start list of values

   ffestc_R528_item_startvals();

   No more objects, gonna specify values for the list of objects now.  */

void
ffestc_R528_item_startvals ()
{
  ffestc_check_item_startvals_ ();
  if (!ffestc_ok_)
    return;

#if 1
  assert (ffestc_local_.data.objlist != NULL);
  ffebld_end_list (&ffestc_local_.data.list_bottom);
  ffedata_begin (ffestc_local_.data.objlist);
#else
  ffestd_R528_item_startvals_ ();
#endif
}

/* ffestc_R528_item_value -- DATA statement source value

   ffestc_R528_item_value(repeat,repeat_token,value,value_token);

   Make sure repeat and value are valid for the objects being initialized.  */

void
ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
                        ffebld value, ffelexToken value_token)
{
  ffetargetIntegerDefault rpt;

  ffestc_check_item_value_ ();
  if (!ffestc_ok_)
    return;

#if 1
  if (repeat == NULL)
    rpt = 1;
  else if (ffebld_op (repeat) == FFEBLD_opCONTER)
    rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
  else
    {
      ffestc_ok_ = FALSE;
      ffedata_end (TRUE, NULL);
      return;
    }

  if (!(ffestc_ok_ = ffedata_value (rpt, value,
                                    (repeat_token == NULL)
                                    ? value_token
                                    : repeat_token)))
    ffedata_end (TRUE, NULL);

#else
  ffestd_R528_item_value_ (repeat, value);
#endif
}

/* ffestc_R528_item_endvals -- DATA statement start list of values

   ffelexToken t;  // the SLASH token that ends the list.
   ffestc_R528_item_endvals(t);

   No more values, might specify more objects now.  */

void
ffestc_R528_item_endvals (ffelexToken t)
{
  ffestc_check_item_endvals_ ();
  if (!ffestc_ok_)
    return;

#if 1
  ffedata_end (!ffestc_ok_, t);
  ffestc_local_.data.objlist = NULL;
#else
  ffestd_R528_item_endvals_ (t);
#endif
}

/* ffestc_R528_finish -- DATA statement list complete

   ffestc_R528_finish();

   Just wrap up any local activities.  */

void
ffestc_R528_finish ()
{
  ffestc_check_finish_ ();

#if 1
#else
  ffestd_R528_finish_ ();
#endif
}

/* ffestc_R537_start -- PARAMETER statement list begin

   ffestc_R537_start();

   Verify that PARAMETER is valid here, and begin accepting items in the
   list.  */

void
ffestc_R537_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_parameter_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);

  ffestd_R537_start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_R537_item -- PARAMETER statement assignment

   ffestc_R537_item(dest,dest_token,source,source_token);

   Make sure the source is a valid source for the destination; make the
   assignment.  */

void
ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
                  ffelexToken source_token)
{
  ffesymbol s;

  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  if ((ffebld_op (dest) == FFEBLD_opANY)
      || (ffebld_op (source) == FFEBLD_opANY))
    {
      if (ffebld_op (dest) == FFEBLD_opSYMTER)
        {
          s = ffebld_symter (dest);
          ffesymbol_set_init (s, ffebld_new_any ());
          ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
          ffesymbol_signal_unreported (s);
        }
      ffestd_R537_item (dest, source);
      return;
    }

  assert (ffebld_op (dest) == FFEBLD_opSYMTER);
  assert (ffebld_op (source) == FFEBLD_opCONTER);

  s = ffebld_symter (dest);
  if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
      && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
    {                           /* Destination has explicit/implicit
                                   CHARACTER*(*) type; set length. */
      ffesymbol_set_info (s,
                          ffeinfo_new (ffesymbol_basictype (s),
                                       ffesymbol_kindtype (s),
                                       0,
                                       ffesymbol_kind (s),
                                       ffesymbol_where (s),
                                       ffebld_size (source)));
      ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
    }

  source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
                                 FFEEXPR_contextDATA);

  ffesymbol_set_init (s, source);

  ffesymbol_signal_unreported (s);

  ffestd_R537_item (dest, source);
}

/* ffestc_R537_finish -- PARAMETER statement list complete

   ffestc_R537_finish();

   Just wrap up any local activities.  */

void
ffestc_R537_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R537_finish ();
}

/* ffestc_R539 -- IMPLICIT NONE statement

   ffestc_R539();

   Verify that the IMPLICIT NONE statement is ok here and implement.  */

void
ffestc_R539 ()
{
  ffestc_check_simple_ ();
  if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  ffeimplic_none ();

  ffestd_R539 ();
}

/* ffestc_R539start -- IMPLICIT statement

   ffestc_R539start();

   Verify that the IMPLICIT statement is ok here and implement.  */

void
ffestc_R539start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_implicit_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestd_R539start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_R539item -- IMPLICIT statement specification (R540)

   ffestc_R539item(...);

   Verify that the type and letter list are all ok and implement.  */

void
ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
                 ffebld len, ffelexToken lent, ffesttImpList letters)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  if ((type == FFESTP_typeCHARACTER) && (len != NULL)
      && (ffebld_op (len) == FFEBLD_opSTAR))
    {                           /* Complain and pretend they're CHARACTER
                                   [*1]. */
      ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
      ffebad_here (0, ffelex_token_where_line (lent),
                   ffelex_token_where_column (lent));
      ffebad_finish ();
      len = NULL;
      lent = NULL;
    }
  ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
  ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);

  ffestt_implist_drive (letters, ffestc_establish_impletter_);

  ffestd_R539item (type, kind, kindt, len, lent, letters);
}

/* ffestc_R539finish -- IMPLICIT statement

   ffestc_R539finish();

   Finish up any local activities.  */

void
ffestc_R539finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R539finish ();
}

/* ffestc_R542_start -- NAMELIST statement list begin

   ffestc_R542_start();

   Verify that NAMELIST is valid here, and begin accepting items in the
   list.  */

void
ffestc_R542_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_progspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  if (ffe_is_f2c_library ()
      && (ffe_case_source () == FFE_caseNONE))
    {
      ffebad_start (FFEBAD_NAMELIST_CASE);
      ffesta_ffebad_here_current_stmt (0);
      ffebad_finish ();
    }

  ffestd_R542_start ();

  ffestc_local_.namelist.symbol = NULL;

  ffestc_ok_ = TRUE;
}

/* ffestc_R542_item_nlist -- NAMELIST statement for group-name

   ffestc_R542_item_nlist(groupname_token);

   Make sure name_token identifies a valid object to be NAMELISTd.  */

void
ffestc_R542_item_nlist (ffelexToken name)
{
  ffesymbol s;

  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  if (ffestc_local_.namelist.symbol != NULL)
    ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);

  s = ffesymbol_declare_local (name, FALSE);

  if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
      || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
          && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
    {
      ffestc_parent_ok_ = TRUE;
      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        {
          ffebld_init_list (ffesymbol_ptr_to_namelist (s),
                            ffesymbol_ptr_to_listbottom (s));
          ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
          ffesymbol_set_info (s,
                              ffeinfo_new (FFEINFO_basictypeNONE,
                                           FFEINFO_kindtypeNONE,
                                           0,
                                           FFEINFO_kindNAMELIST,
                                           FFEINFO_whereLOCAL,
                                           FFETARGET_charactersizeNONE));
        }
    }
  else
    {
      if (ffesymbol_kind (s) != FFEINFO_kindANY)
        ffesymbol_error (s, name);
      ffestc_parent_ok_ = FALSE;
    }

  ffestc_local_.namelist.symbol = s;

  ffestd_R542_item_nlist (name);
}

/* ffestc_R542_item_nitem -- NAMELIST statement for variable-name

   ffestc_R542_item_nitem(name_token);

   Make sure name_token identifies a valid object to be NAMELISTd.  */

void
ffestc_R542_item_nitem (ffelexToken name)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffebld e;

  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  s = ffesymbol_declare_local (name, FALSE);
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (s)
      && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
          || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
              && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
    na = FFESYMBOL_attrsetNONE;
  else if (sa & FFESYMBOL_attrsANY)
    na = FFESYMBOL_attrsANY;
  else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
                    | FFESYMBOL_attrsARRAY
                    | FFESYMBOL_attrsCOMMON
                    | FFESYMBOL_attrsEQUIV
                    | FFESYMBOL_attrsINIT
                    | FFESYMBOL_attrsNAMELIST
                    | FFESYMBOL_attrsSAVE
                    | FFESYMBOL_attrsSFARG
                    | FFESYMBOL_attrsTYPE)))
    na = sa | FFESYMBOL_attrsNAMELIST;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, name);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_set_namelisted (s, TRUE);
      ffesymbol_signal_unreported (s);
#if 0                           /* No need to establish type yet! */
      if (!ffeimplic_establish_symbol (s))
        ffesymbol_error (s, name);
#endif
    }

  if (ffestc_parent_ok_)
    {
      e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
                             FFEINTRIN_impNONE);
      ffebld_set_info (e,
                       ffeinfo_new (FFEINFO_basictypeNONE,
                                    FFEINFO_kindtypeNONE, 0,
                                    FFEINFO_kindNONE,
                                    FFEINFO_whereNONE,
                                    FFETARGET_charactersizeNONE));
      ffebld_append_item
        (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
    }

  ffestd_R542_item_nitem (name);
}

/* ffestc_R542_finish -- NAMELIST statement list complete

   ffestc_R542_finish();

   Just wrap up any local activities.  */

void
ffestc_R542_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);

  ffestd_R542_finish ();
}

/* ffestc_R544_start -- EQUIVALENCE statement list begin

   ffestc_R544_start();

   Verify that EQUIVALENCE is valid here, and begin accepting items in the
   list.  */

void
ffestc_R544_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);

  ffestc_ok_ = TRUE;
}

/* ffestc_R544_item -- EQUIVALENCE statement assignment

   ffestc_R544_item(exprlist);

   Make sure the equivalence is valid, then implement it.  */

void
ffestc_R544_item (ffesttExprList exprlist)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  /* First we go through the list and come up with one ffeequiv object that
     will describe all items in the list.  When an ffeequiv object is first
     found, it is used (else we create one as a "local equiv" for the time
     being).  If subsequent ffeequiv objects are found, they are merged with
     the first so we end up with one.  However, if more than one COMMON
     variable is involved, then an error condition occurs. */

  ffestc_local_.equiv.ok = TRUE;
  ffestc_local_.equiv.t = NULL; /* No token yet. */
  ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
  ffestc_local_.equiv.save = FALSE;     /* No SAVEd variables yet. */

  ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
  ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
  ffebld_end_list (&ffestc_local_.equiv.bottom);

  if (!ffestc_local_.equiv.ok)
    return;                     /* Something went wrong, stop bothering with
                                   this stuff. */

  if (ffestc_local_.equiv.eq == NULL)
    ffestc_local_.equiv.eq = ffeequiv_new ();   /* Make local equivalence. */

  /* Append this list of equivalences to list of such lists for this
     equivalence. */

  ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
                ffestc_local_.equiv.t);
  if (ffestc_local_.equiv.save)
    ffeequiv_update_save (ffestc_local_.equiv.eq);
}

/* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list

   ffebld expr;
   ffelexToken t;
   ffestc_R544_equiv_(expr,t);

   Record information, if any, on symbol in expr; if symbol has equivalence
   object already, merge with outstanding object if present or make it
   the outstanding object.  */

static void
ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
{
  ffesymbol s;

  if (!ffestc_local_.equiv.ok)
    return;

  if (ffestc_local_.equiv.t == NULL)
    ffestc_local_.equiv.t = t;

  switch (ffebld_op (expr))
    {
    case FFEBLD_opANY:
      return;                   /* Don't put this on the list. */

    case FFEBLD_opSYMTER:
    case FFEBLD_opARRAYREF:
    case FFEBLD_opSUBSTR:
      break;                    /* All of these are ok. */

    default:
      assert ("ffestc_R544_equiv_ bad op" == NULL);
      return;
    }

  ffebld_append_item (&ffestc_local_.equiv.bottom, expr);

  s = ffeequiv_symbol (expr);

  /* See if symbol has an equivalence object already. */

  if (ffesymbol_equiv (s) != NULL)
    {
      if (ffestc_local_.equiv.eq == NULL)
        ffestc_local_.equiv.eq = ffesymbol_equiv (s);   /* New equiv obj. */
      else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
        {
          ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
                                                   ffestc_local_.equiv.eq,
                                                   t);
          if (ffestc_local_.equiv.eq == NULL)
            ffestc_local_.equiv.ok = FALSE;     /* Couldn't merge. */
        }
    }

  if (ffesymbol_is_save (s))
    ffestc_local_.equiv.save = TRUE;
}

/* ffestc_R544_finish -- EQUIVALENCE statement list complete

   ffestc_R544_finish();

   Just wrap up any local activities.  */

void
ffestc_R544_finish ()
{
  ffestc_check_finish_ ();
}

/* ffestc_R547_start -- COMMON statement list begin

   ffestc_R547_start();

   Verify that COMMON is valid here, and begin accepting items in the list.  */

void
ffestc_R547_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestc_local_.common.symbol = NULL;   /* Blank common is the default. */
  ffestc_parent_ok_ = TRUE;

  ffestd_R547_start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_R547_item_object -- COMMON statement for object-name

   ffestc_R547_item_object(name_token,dim_list);

   Make sure name_token identifies a valid object to be COMMONd.  */

void
ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
{
  ffesymbol s;
  ffebld array_size;
  ffebld extents;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffestpDimtype nd;
  ffebld e;
  ffeinfoRank rank;
  bool is_ugly_assumed;

  if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
    ffestc_R547_item_cblock (NULL);     /* As if "COMMON [//] ...". */

  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  if (dims != NULL)
    ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);

  s = ffesymbol_declare_local (name, FALSE);
  sa = ffesymbol_attrs (s);

  /* First figure out what kind of object this is based solely on the current
     object situation (dimension list). */

  is_ugly_assumed = (ffe_is_ugly_assumed ()
                     && ((sa & FFESYMBOL_attrsDUMMY)
                         || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));

  nd = ffestt_dimlist_type (dims, is_ugly_assumed);
  switch (nd)
    {
    case FFESTP_dimtypeNONE:
      na = FFESYMBOL_attrsCOMMON;
      break;

    case FFESTP_dimtypeKNOWN:
      na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
      break;

    default:
      na = FFESYMBOL_attrsetNONE;
      break;
    }

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (na == FFESYMBOL_attrsetNONE)
    ;
  else if (!ffesymbol_is_specable (s))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
  else if (sa & FFESYMBOL_attrsANY)
    na = FFESYMBOL_attrsANY;
  else if ((sa & (FFESYMBOL_attrsADJUSTS
                  | FFESYMBOL_attrsARRAY
                  | FFESYMBOL_attrsINIT
                  | FFESYMBOL_attrsSFARG))
           && (na & FFESYMBOL_attrsARRAY))
    na = FFESYMBOL_attrsetNONE;
  else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
                    | FFESYMBOL_attrsARRAY
                    | FFESYMBOL_attrsEQUIV
                    | FFESYMBOL_attrsINIT
                    | FFESYMBOL_attrsNAMELIST
                    | FFESYMBOL_attrsSFARG
                    | FFESYMBOL_attrsTYPE)))
    na |= sa;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, name);
  else if ((ffesymbol_equiv (s) != NULL)
           && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
           && (ffeequiv_common (ffesymbol_equiv (s))
               != ffestc_local_.common.symbol))
    {
      /* Oops, just COMMONed a symbol to a different area (via equiv).  */
      ffebad_start (FFEBAD_EQUIV_COMMON);
      ffebad_here (0, ffelex_token_where_line (name),
                   ffelex_token_where_column (name));
      ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
      ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
      ffebad_finish ();
      ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
      ffesymbol_set_info (s, ffeinfo_new_any ());
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_signal_unreported (s);
    }
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_set_common (s, ffestc_local_.common.symbol);
#if FFEGLOBAL_ENABLED
      if (ffesymbol_is_init (s))
        ffeglobal_init_common (ffestc_local_.common.symbol, name);
#endif
      if (ffesymbol_is_save (ffestc_local_.common.symbol))
        ffesymbol_update_save (s);
      if (ffesymbol_equiv (s) != NULL)
        {                       /* Is this newly COMMONed symbol involved in
                                   an equivalence? */
          if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
            ffeequiv_set_common (ffesymbol_equiv (s),   /* Yes, tell equiv obj. */
                                 ffestc_local_.common.symbol);
#if FFEGLOBAL_ENABLED
          if (ffeequiv_is_init (ffesymbol_equiv (s)))
            ffeglobal_init_common (ffestc_local_.common.symbol, name);
#endif
          if (ffesymbol_is_save (ffestc_local_.common.symbol))
            ffeequiv_update_save (ffesymbol_equiv (s));
        }
      if (dims != NULL)
        {
          ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
                                                         &array_size,
                                                         &extents,
                                                         is_ugly_assumed));
          ffesymbol_set_arraysize (s, array_size);
          ffesymbol_set_extents (s, extents);
          if (!(0 && ffe_is_90 ())
              && (ffebld_op (array_size) == FFEBLD_opCONTER)
              && (ffebld_constant_integerdefault (ffebld_conter (array_size))
                  == 0))
            {
              ffebad_start (FFEBAD_ZERO_ARRAY);
              ffebad_here (0, ffelex_token_where_line (name),
                           ffelex_token_where_column (name));
              ffebad_finish ();
            }
          ffesymbol_set_info (s,
                              ffeinfo_new (ffesymbol_basictype (s),
                                           ffesymbol_kindtype (s),
                                           rank,
                                           ffesymbol_kind (s),
                                           ffesymbol_where (s),
                                           ffesymbol_size (s)));
        }
      ffesymbol_signal_unreported (s);
    }

  if (ffestc_parent_ok_)
    {
      e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
                             FFEINTRIN_impNONE);
      ffebld_set_info (e,
                       ffeinfo_new (FFEINFO_basictypeNONE,
                                    FFEINFO_kindtypeNONE,
                                    0,
                                    FFEINFO_kindNONE,
                                    FFEINFO_whereNONE,
                                    FFETARGET_charactersizeNONE));
      ffebld_append_item
        (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
    }

  ffestd_R547_item_object (name, dims);
}

/* ffestc_R547_item_cblock -- COMMON statement for common-block-name

   ffestc_R547_item_cblock(name_token);

   Make sure name_token identifies a valid common block to be COMMONd.  */

void
ffestc_R547_item_cblock (ffelexToken name)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;

  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  if (ffestc_local_.common.symbol != NULL)
    ffesymbol_signal_unreported (ffestc_local_.common.symbol);

  s = ffesymbol_declare_cblock (name,
                                ffelex_token_where_line (ffesta_tokens[0]),
                              ffelex_token_where_column (ffesta_tokens[0]));
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (s))
    na = FFESYMBOL_attrsetNONE;
  else if (sa & FFESYMBOL_attrsANY)
    na = FFESYMBOL_attrsANY;    /* Already have an error here, say nothing. */
  else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
                    | FFESYMBOL_attrsSAVECBLOCK)))
    {
      if (!(sa & FFESYMBOL_attrsCBLOCK))
        ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
                          ffesymbol_ptr_to_listbottom (s));
      na = sa | FFESYMBOL_attrsCBLOCK;
    }
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    {
      ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
      ffestc_parent_ok_ = FALSE;
    }
  else if (na & FFESYMBOL_attrsANY)
    ffestc_parent_ok_ = FALSE;
  else
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      if (name == NULL)
        ffesymbol_update_save (s);
      ffestc_parent_ok_ = TRUE;
    }

  ffestc_local_.common.symbol = s;

  ffestd_R547_item_cblock (name);
}

/* ffestc_R547_finish -- COMMON statement list complete

   ffestc_R547_finish();

   Just wrap up any local activities.  */

void
ffestc_R547_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  if (ffestc_local_.common.symbol != NULL)
    ffesymbol_signal_unreported (ffestc_local_.common.symbol);

  ffestd_R547_finish ();
}

/* ffestc_R737 -- Assignment statement

   ffestc_R737(dest_expr,source_expr,source_token);

   Make sure the assignment is valid.  */

void
ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
{
  ffestc_check_simple_ ();

  if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
                                 FFEEXPR_contextLET);

  ffestd_R737A (dest, source);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R803 -- Block IF (IF-THEN) statement

   ffestc_R803(construct_name,expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R803 (ffelexToken construct_name, ffebld expr,
             ffelexToken expr_token UNUSED)
{
  ffestw b;
  ffesymbol s;

  ffestc_check_simple_ ();
  if (ffestc_order_exec_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
  ffestw_set_state (b, FFESTV_stateIFTHEN);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_ifthen_);
  ffestw_set_substate (b, 0);   /* Haven't seen ELSE yet. */

  if (construct_name == NULL)
    ffestw_set_name (b, NULL);
  else
    {
      ffestw_set_name (b, ffelex_token_use (construct_name));

      s = ffesymbol_declare_local (construct_name, FALSE);

      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        {
          ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
          ffesymbol_set_info (s,
                              ffeinfo_new (FFEINFO_basictypeNONE,
                                           FFEINFO_kindtypeNONE,
                                           0,
                                           FFEINFO_kindCONSTRUCT,
                                           FFEINFO_whereLOCAL,
                                           FFETARGET_charactersizeNONE));
          s = ffecom_sym_learned (s);
          ffesymbol_signal_unreported (s);
        }
      else
        ffesymbol_error (s, construct_name);
    }

  ffestd_R803 (construct_name, expr);
}

/* ffestc_R804 -- ELSE IF statement

   ffestc_R804(expr,expr_token,name_token);

   Make sure ffestc_kind_ identifies an IF block.  If not
   NULL, make sure name_token gives the correct name.  Implement the else
   of the IF block.  */

void
ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
             ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  if (name != NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name,
                                    ffestw_name (ffestw_stack_top ()))
               != 0)
        {
          ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  if (ffestw_substate (ffestw_stack_top ()) != 0)
    {
      ffebad_start (FFEBAD_AFTER_ELSE);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
      ffebad_finish ();
      return;                   /* Don't upset back end with ELSEIF
                                   after ELSE. */
    }

  ffestd_R804 (expr, name);
}

/* ffestc_R805 -- ELSE statement

   ffestc_R805(name_token);

   Make sure ffestc_kind_ identifies an IF block.  If not
   NULL, make sure name_token gives the correct name.  Implement the ELSE
   of the IF block.  */

void
ffestc_R805 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  if (name != NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
        {
          ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  if (ffestw_substate (ffestw_stack_top ()) != 0)
    {
      ffebad_start (FFEBAD_AFTER_ELSE);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
      ffebad_finish ();
      return;                   /* Tell back end about only one ELSE. */
    }

  ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */

  ffestd_R805 (name);
}

/* ffestc_R806 -- END IF statement

   ffestc_R806(name_token);

   Make sure ffestc_kind_ identifies an IF block.  If not
   NULL, make sure name_token gives the correct name.  Implement the end
   of the IF block.  */

void
ffestc_R806 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_endif_ ();

  if (name == NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) != NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NAMED);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
    }
  else
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
        {
          ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  ffestc_shriek_ifthen_ (TRUE);
}

/* ffestc_R807 -- Logical IF statement

   ffestc_R807(expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
{
  ffestw b;

  ffestc_check_simple_ ();
  if (ffestc_order_action_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
  ffestw_set_state (b, FFESTV_stateIF);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_if_lost_);

  ffestd_R807 (expr);

  /* Do the label finishing in the next statement. */

}

/* ffestc_R809 -- SELECT CASE statement

   ffestc_R809(construct_name,expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
{
  ffestw b;
  mallocPool pool;
  ffestwSelect s;
  ffesymbol sym;

  ffestc_check_simple_ ();
  if (ffestc_order_exec_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
  ffestw_set_state (b, FFESTV_stateSELECT0);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_select_);
  ffestw_set_substate (b, 0);   /* Haven't seen CASE DEFAULT yet. */

  /* Init block to manage CASE list. */

  pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
  s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
  s->first_rel = (ffestwCase) &s->first_rel;
  s->last_rel = (ffestwCase) &s->first_rel;
  s->first_stmt = (ffestwCase) &s->first_rel;
  s->last_stmt = (ffestwCase) &s->first_rel;
  s->pool = pool;
  s->cases = 1;
  s->t = ffelex_token_use (expr_token);
  s->type = ffeinfo_basictype (ffebld_info (expr));
  s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
  ffestw_set_select (b, s);

  if (construct_name == NULL)
    ffestw_set_name (b, NULL);
  else
    {
      ffestw_set_name (b, ffelex_token_use (construct_name));

      sym = ffesymbol_declare_local (construct_name, FALSE);

      if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
        {
          ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
          ffesymbol_set_info (sym,
                              ffeinfo_new (FFEINFO_basictypeNONE,
                                           FFEINFO_kindtypeNONE, 0,
                                           FFEINFO_kindCONSTRUCT,
                                           FFEINFO_whereLOCAL,
                                           FFETARGET_charactersizeNONE));
          sym = ffecom_sym_learned (sym);
          ffesymbol_signal_unreported (sym);
        }
      else
        ffesymbol_error (sym, construct_name);
    }

  ffestd_R809 (construct_name, expr);
}

/* ffestc_R810 -- CASE statement

   ffestc_R810(case_value_range_list,name);

   If case_value_range_list is NULL, it's CASE DEFAULT.  name is the case-
   construct-name.  Make sure no more than one CASE DEFAULT is present for
   a given case-construct and that there aren't any overlapping ranges or
   duplicate case values.  */

void
ffestc_R810 (ffesttCaseList cases, ffelexToken name)
{
  ffesttCaseList caseobj;
  ffestwSelect s;
  ffestwCase c, nc;
  ffebldConstant expr1c, expr2c;

  ffestc_check_simple_ ();
  if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  s = ffestw_select (ffestw_stack_top ());

  if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
    {
#if 0                           /* Not sure we want to have msgs point here
                                   instead of SELECT CASE. */
      ffestw_update (NULL);     /* Update state line/col info. */
#endif
      ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
    }

  if (name != NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name,
                                    ffestw_name (ffestw_stack_top ()))
               != 0)
        {
          ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  if (cases == NULL)
    {
      if (ffestw_substate (ffestw_stack_top ()) != 0)
        {
          ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }

      ffestw_set_substate (ffestw_stack_top (), 1);     /* Saw ELSE. */
    }
  else
    {                           /* For each case, try to fit into sorted list
                                   of ranges. */
      for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
        {
          if ((caseobj->expr1 == NULL)
              && (!caseobj->range
                  || (caseobj->expr2 == NULL)))
            {                   /* "CASE (:)". */
              ffebad_start (FFEBAD_CASE_BAD_RANGE);
              ffebad_here (0, ffelex_token_where_line (caseobj->t),
                           ffelex_token_where_column (caseobj->t));
              ffebad_finish ();
              continue;
            }
          if (((caseobj->expr1 != NULL)
               && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
                    != s->type)
                   || ((ffeinfo_kindtype (ffebld_info (caseobj->expr1))
                       != s->kindtype) 
                       && (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) != FFEINFO_kindtypeINTEGER1 ))
              || ((caseobj->range)
                  && (caseobj->expr2 != NULL)
                  && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
                       != s->type)
                      || ((ffeinfo_kindtype (ffebld_info (caseobj->expr2))
                          != s->kindtype)
                      && (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) != FFEINFO_kindtypeINTEGER1)))))))
            {
              ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
              ffebad_here (0, ffelex_token_where_line (caseobj->t),
                           ffelex_token_where_column (caseobj->t));
              ffebad_here (1, ffelex_token_where_line (s->t),
                           ffelex_token_where_column (s->t));
              ffebad_finish ();
              continue;
            }



          if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
            {
              ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
              ffebad_here (0, ffelex_token_where_line (caseobj->t),
                           ffelex_token_where_column (caseobj->t));
              ffebad_finish ();
              continue;
            }

          if (caseobj->expr1 == NULL)
            expr1c = NULL;
          else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
            continue;           /* opANY. */
          else
            expr1c = ffebld_conter (caseobj->expr1);

          if (!caseobj->range)
            expr2c = expr1c;    /* expr1c and expr2c are NOT NULL in this
                                   case. */
          else if (caseobj->expr2 == NULL)
            expr2c = NULL;
          else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
            continue;           /* opANY. */
          else
            expr2c = ffebld_conter (caseobj->expr2);

          if (expr1c == NULL)
            {                   /* "CASE (:high)", must be first in list. */
              c = s->first_rel;
              if ((c != (ffestwCase) &s->first_rel)
                  && ((c->low == NULL)
                      || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
                {               /* Other "CASE (:high)" or lowest "CASE
                                   (low[:high])" low. */
                  ffebad_start (FFEBAD_CASE_DUPLICATE);
                  ffebad_here (0, ffelex_token_where_line (caseobj->t),
                               ffelex_token_where_column (caseobj->t));
                  ffebad_here (1, ffelex_token_where_line (c->t),
                               ffelex_token_where_column (c->t));
                  ffebad_finish ();
                  continue;
                }
            }
          else if (expr2c == NULL)
            {                   /* "CASE (low:)", must be last in list. */
              c = s->last_rel;
              if ((c != (ffestwCase) &s->first_rel)
                  && ((c->high == NULL)
                      || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
                {               /* Other "CASE (low:)" or lowest "CASE
                                   ([low:]high)" high. */
                  ffebad_start (FFEBAD_CASE_DUPLICATE);
                  ffebad_here (0, ffelex_token_where_line (caseobj->t),
                               ffelex_token_where_column (caseobj->t));
                  ffebad_here (1, ffelex_token_where_line (c->t),
                               ffelex_token_where_column (c->t));
                  ffebad_finish ();
                  continue;
                }
              c = c->next_rel;  /* Same as c = (ffestwCase) &s->first;. */
            }
          else
            {                   /* (expr1c != NULL) && (expr2c != NULL). */
              if (ffebld_constant_cmp (expr1c, expr2c) > 0)
                {               /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
                  ffebad_start (FFEBAD_CASE_RANGE_USELESS);     /* Warn/inform only. */
                  ffebad_here (0, ffelex_token_where_line (caseobj->t),
                               ffelex_token_where_column (caseobj->t));
                  ffebad_finish ();
                  continue;
                }
              for (c = s->first_rel;
                   (c != (ffestwCase) &s->first_rel)
                   && ((c->low == NULL)
                       || (ffebld_constant_cmp (expr1c, c->low) > 0));
                   c = c->next_rel)
                ;
              nc = c;           /* Which one to report? */
              if (((c != (ffestwCase) &s->first_rel)
                   && (ffebld_constant_cmp (expr2c, c->low) >= 0))
                  || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
                      && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
                {               /* Interference with range in case nc. */
                  ffebad_start (FFEBAD_CASE_DUPLICATE);
                  ffebad_here (0, ffelex_token_where_line (caseobj->t),
                               ffelex_token_where_column (caseobj->t));
                  ffebad_here (1, ffelex_token_where_line (nc->t),
                               ffelex_token_where_column (nc->t));
                  ffebad_finish ();
                  continue;
                }
            }

          /* If we reach here for this case range/value, it's ok (sorts into
             the list of ranges/values) so we give it its own case object
             sorted into the list of case statements. */

          nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
          nc->next_rel = c;
          nc->previous_rel = c->previous_rel;
          nc->next_stmt = (ffestwCase) &s->first_rel;
          nc->previous_stmt = s->last_stmt;
          nc->low = expr1c;
          nc->high = expr2c;
          nc->casenum = s->cases;
          nc->t = ffelex_token_use (caseobj->t);
          nc->next_rel->previous_rel = nc;
          nc->previous_rel->next_rel = nc;
          nc->next_stmt->previous_stmt = nc;
          nc->previous_stmt->next_stmt = nc;
        }
    }

  ffestd_R810 ((cases == NULL) ? 0 : s->cases);

  s->cases++;                   /* Increment # of cases. */
}

/* ffestc_R811 -- END SELECT statement

   ffestc_R811(name_token);

   Make sure ffestc_kind_ identifies a SELECT block.  If not
   NULL, make sure name_token gives the correct name.  Implement the end
   of the SELECT block.  */

void
ffestc_R811 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  if (name == NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) != NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NAMED);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
    }
  else
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name,
                                    ffestw_name (ffestw_stack_top ()))
               != 0)
        {
          ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  ffestc_shriek_select_ (TRUE);
}

/* ffestc_R819A -- Iterative labeled DO statement

   ffestc_R819A(construct_name,label_token,expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
   ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
              ffelexToken end_token, ffebld incr, ffelexToken incr_token)
{
  ffestw b;
  ffelab label;
  ffesymbol s;
  ffesymbol varsym;

  ffestc_check_simple_ ();
  if (ffestc_order_exec_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  if (!ffestc_labelref_is_loopend_ (label_token, &label))
    return;

  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, b);
  ffestw_set_state (b, FFESTV_stateDO);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_do_);
  ffestw_set_label (b, label);
  switch (ffebld_op (var))
    {
    case FFEBLD_opSYMTER:
      if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
          && ffe_is_warn_surprising ())
        {
          ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
          ffebad_here (0, ffelex_token_where_line (var_token),
                       ffelex_token_where_column (var_token));
          ffebad_string (ffesymbol_text (ffebld_symter (var)));
          ffebad_finish ();
        }
      if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
        {                       /* Presumably already complained about by
                                   ffeexpr_lhs_. */
          ffesymbol_set_is_doiter (varsym, TRUE);
          ffestw_set_do_iter_var (b, varsym);
          ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
          break;
        }
      /* Fall through. */
    case FFEBLD_opANY:
      ffestw_set_do_iter_var (b, NULL);
      ffestw_set_do_iter_var_t (b, NULL);
      break;

    default:
      assert ("bad iter var" == NULL);
      break;
    }

  if (construct_name == NULL)
    ffestw_set_name (b, NULL);
  else
    {
      ffestw_set_name (b, ffelex_token_use (construct_name));

      s = ffesymbol_declare_local (construct_name, FALSE);

      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        {
          ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
          ffesymbol_set_info (s,
                              ffeinfo_new (FFEINFO_basictypeNONE,
                                           FFEINFO_kindtypeNONE,
                                           0,
                                           FFEINFO_kindCONSTRUCT,
                                           FFEINFO_whereLOCAL,
                                           FFETARGET_charactersizeNONE));
          s = ffecom_sym_learned (s);
          ffesymbol_signal_unreported (s);
        }
      else
        ffesymbol_error (s, construct_name);
    }

  if (incr == NULL)
    {
      incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
      ffebld_set_info (incr, ffeinfo_new
                       (FFEINFO_basictypeINTEGER,
                        FFEINFO_kindtypeINTEGERDEFAULT,
                        0,
                        FFEINFO_kindENTITY,
                        FFEINFO_whereCONSTANT,
                        FFETARGET_charactersizeNONE));
    }

  start = ffeexpr_convert_expr (start, start_token, var, var_token,
                                FFEEXPR_contextLET);
  end = ffeexpr_convert_expr (end, end_token, var, var_token,
                              FFEEXPR_contextLET);
  incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
                               FFEEXPR_contextLET);

  ffestd_R819A (construct_name, label, var,
                start, start_token,
                end, end_token,
                incr, incr_token);
}

/* ffestc_R819B -- Labeled DO WHILE statement

   ffestc_R819B(construct_name,label_token,expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
              ffebld expr, ffelexToken expr_token UNUSED)
{
  ffestw b;
  ffelab label;
  ffesymbol s;

  ffestc_check_simple_ ();
  if (ffestc_order_exec_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  if (!ffestc_labelref_is_loopend_ (label_token, &label))
    return;

  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, b);
  ffestw_set_state (b, FFESTV_stateDO);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_do_);
  ffestw_set_label (b, label);
  ffestw_set_do_iter_var (b, NULL);
  ffestw_set_do_iter_var_t (b, NULL);

  if (construct_name == NULL)
    ffestw_set_name (b, NULL);
  else
    {
      ffestw_set_name (b, ffelex_token_use (construct_name));

      s = ffesymbol_declare_local (construct_name, FALSE);

      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        {
          ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
          ffesymbol_set_info (s,
                              ffeinfo_new (FFEINFO_basictypeNONE,
                                           FFEINFO_kindtypeNONE,
                                           0,
                                           FFEINFO_kindCONSTRUCT,
                                           FFEINFO_whereLOCAL,
                                           FFETARGET_charactersizeNONE));
          s = ffecom_sym_learned (s);
          ffesymbol_signal_unreported (s);
        }
      else
        ffesymbol_error (s, construct_name);
    }

  ffestd_R819B (construct_name, label, expr);
}

/* ffestc_R820A -- Iterative nonlabeled DO statement

   ffestc_R820A(construct_name,expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
   ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
              ffebld incr, ffelexToken incr_token)
{
  ffestw b;
  ffesymbol s;
  ffesymbol varsym;

  ffestc_check_simple_ ();
  if (ffestc_order_exec_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, b);
  ffestw_set_state (b, FFESTV_stateDO);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_do_);
  ffestw_set_label (b, NULL);
  switch (ffebld_op (var))
    {
    case FFEBLD_opSYMTER:
      if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
          && ffe_is_warn_surprising ())
        {
          ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
          ffebad_here (0, ffelex_token_where_line (var_token),
                       ffelex_token_where_column (var_token));
          ffebad_string (ffesymbol_text (ffebld_symter (var)));
          ffebad_finish ();
        }
      if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
        {                       /* Presumably already complained about by
                                   ffeexpr_lhs_. */
          ffesymbol_set_is_doiter (varsym, TRUE);
          ffestw_set_do_iter_var (b, varsym);
          ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
          break;
        }
      /* Fall through. */
    case FFEBLD_opANY:
      ffestw_set_do_iter_var (b, NULL);
      ffestw_set_do_iter_var_t (b, NULL);
      break;

    default:
      assert ("bad iter var" == NULL);
      break;
    }

  if (construct_name == NULL)
    ffestw_set_name (b, NULL);
  else
    {
      ffestw_set_name (b, ffelex_token_use (construct_name));

      s = ffesymbol_declare_local (construct_name, FALSE);

      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        {
          ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
          ffesymbol_set_info (s,
                              ffeinfo_new (FFEINFO_basictypeNONE,
                                           FFEINFO_kindtypeNONE,
                                           0,
                                           FFEINFO_kindCONSTRUCT,
                                           FFEINFO_whereLOCAL,
                                           FFETARGET_charactersizeNONE));
          s = ffecom_sym_learned (s);
          ffesymbol_signal_unreported (s);
        }
      else
        ffesymbol_error (s, construct_name);
    }

  if (incr == NULL)
    {
      incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
      ffebld_set_info (incr, ffeinfo_new
                       (FFEINFO_basictypeINTEGER,
                        FFEINFO_kindtypeINTEGERDEFAULT,
                        0,
                        FFEINFO_kindENTITY,
                        FFEINFO_whereCONSTANT,
                        FFETARGET_charactersizeNONE));
    }

  start = ffeexpr_convert_expr (start, start_token, var, var_token,
                                FFEEXPR_contextLET);
  end = ffeexpr_convert_expr (end, end_token, var, var_token,
                              FFEEXPR_contextLET);
  incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
                               FFEEXPR_contextLET);

#if 0
  if ((ffebld_op (incr) == FFEBLD_opCONTER)
      && (ffebld_constant_is_zero (ffebld_conter (incr))))
    {
      ffebad_start (FFEBAD_DO_STEP_ZERO);
      ffebad_here (0, ffelex_token_where_line (incr_token),
                   ffelex_token_where_column (incr_token));
      ffebad_string ("Iterative DO loop");
      ffebad_finish ();
    }
#endif

  ffestd_R819A (construct_name, NULL, var,
                start, start_token,
                end, end_token,
                incr, incr_token);
}

/* ffestc_R820B -- Nonlabeled DO WHILE statement

   ffestc_R820B(construct_name,expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R820B (ffelexToken construct_name, ffebld expr,
              ffelexToken expr_token UNUSED)
{
  ffestw b;
  ffesymbol s;

  ffestc_check_simple_ ();
  if (ffestc_order_exec_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, b);
  ffestw_set_state (b, FFESTV_stateDO);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_do_);
  ffestw_set_label (b, NULL);
  ffestw_set_do_iter_var (b, NULL);
  ffestw_set_do_iter_var_t (b, NULL);

  if (construct_name == NULL)
    ffestw_set_name (b, NULL);
  else
    {
      ffestw_set_name (b, ffelex_token_use (construct_name));

      s = ffesymbol_declare_local (construct_name, FALSE);

      if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
        {
          ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
          ffesymbol_set_info (s,
                              ffeinfo_new (FFEINFO_basictypeNONE,
                                           FFEINFO_kindtypeNONE,
                                           0,
                                           FFEINFO_kindCONSTRUCT,
                                           FFEINFO_whereLOCAL,
                                           FFETARGET_charactersizeNONE));
          s = ffecom_sym_learned (s);
          ffesymbol_signal_unreported (s);
        }
      else
        ffesymbol_error (s, construct_name);
    }

  ffestd_R819B (construct_name, NULL, expr);
}

/* ffestc_R825 -- END DO statement

   ffestc_R825(name_token);

   Make sure ffestc_kind_ identifies a DO block.  If not
   NULL, make sure name_token gives the correct name.  Implement the end
   of the DO block.  */

void
ffestc_R825 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_do_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (name == NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) != NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NAMED);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
    }
  else
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name,
                                    ffestw_name (ffestw_stack_top ()))
               != 0)
        {
          ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  if (ffesta_label_token == NULL)
    {                           /* If top of stack has label, its an error! */
      if (ffestw_label (ffestw_stack_top ()) != NULL)
        {
          ffebad_start (FFEBAD_DO_HAD_LABEL);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }

      ffestc_shriek_do_ (TRUE);

      ffestc_try_shriek_do_ ();

      return;
    }

  ffestd_R825 (name);

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R834 -- CYCLE statement

   ffestc_R834(name_token);

   Handle a CYCLE within a loop.  */

void
ffestc_R834 (ffelexToken name)
{
  ffestw block;

  ffestc_check_simple_ ();
  if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_begin_ ();

  if (name == NULL)
    block = ffestw_top_do (ffestw_stack_top ());
  else
    {                           /* Search for name. */
      for (block = ffestw_top_do (ffestw_stack_top ());
           (block != NULL) && (ffestw_blocknum (block) != 0);
           block = ffestw_top_do (ffestw_previous (block)))
        {
          if ((ffestw_name (block) != NULL)
              && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
            break;
        }
      if ((block == NULL) || (ffestw_blocknum (block) == 0))
        {
          block = ffestw_top_do (ffestw_stack_top ());
          ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_finish ();
        }
    }

  ffestd_R834 (block);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);

  /* notloop's that are actionif's can be the target of a loop-end
     statement if they're in the "then" part of a logical IF, as
     in "DO 10", "10 IF (...) CYCLE".  */

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R835 -- EXIT statement

   ffestc_R835(name_token);

   Handle a EXIT within a loop.  */

void
ffestc_R835 (ffelexToken name)
{
  ffestw block;

  ffestc_check_simple_ ();
  if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_begin_ ();

  if (name == NULL)
    block = ffestw_top_do (ffestw_stack_top ());
  else
    {                           /* Search for name. */
      for (block = ffestw_top_do (ffestw_stack_top ());
           (block != NULL) && (ffestw_blocknum (block) != 0);
           block = ffestw_top_do (ffestw_previous (block)))
        {
          if ((ffestw_name (block) != NULL)
              && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
            break;
        }
      if ((block == NULL) || (ffestw_blocknum (block) == 0))
        {
          block = ffestw_top_do (ffestw_stack_top ());
          ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_finish ();
        }
    }

  ffestd_R835 (block);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);

  /* notloop's that are actionif's can be the target of a loop-end
     statement if they're in the "then" part of a logical IF, as
     in "DO 10", "10 IF (...) EXIT".  */

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R836 -- GOTO statement

   ffestc_R836(label_token);

   Make sure label_token identifies a valid label for a GOTO.  Update
   that label's info to indicate it is the target of a GOTO.  */

void
ffestc_R836 (ffelexToken label_token)
{
  ffelab label;

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_begin_ ();

  if (ffestc_labelref_is_branch_ (label_token, &label))
    ffestd_R836 (label);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);

  /* notloop's that are actionif's can be the target of a loop-end
     statement if they're in the "then" part of a logical IF, as
     in "DO 10", "10 IF (...) GOTO 100".  */

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R837 -- Computed GOTO statement

   ffestc_R837(label_list,expr,expr_token);

   Make sure label_list identifies valid labels for a GOTO.  Update
   each label's info to indicate it is the target of a GOTO.  */

void
ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
             ffelexToken expr_token UNUSED)
{
  ffesttTokenItem ti;
  bool ok = TRUE;
  int i;
  ffelab *labels;

  assert (label_toks != NULL);

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
                          sizeof (*labels)
                          * ffestt_tokenlist_count (label_toks));

  for (ti = label_toks->first, i = 0;
       ti != (ffesttTokenItem) &label_toks->first;
       ti = ti->next, ++i)
    {
      if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
        {
          ok = FALSE;
          break;
        }
    }

  if (ok)
    ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R838 -- ASSIGN statement

   ffestc_R838(label_token,target_variable,target_token);

   Make sure label_token identifies a valid label for an assignment.  Update
   that label's info to indicate it is the source of an assignment.  Update
   target_variable's info to indicate it is the target the assignment of that
   label.  */

void
ffestc_R838 (ffelexToken label_token, ffebld target,
             ffelexToken target_token UNUSED)
{
  ffelab label;

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  /* Mark target symbol as target of an ASSIGN.  */
  if (ffebld_op (target) == FFEBLD_opSYMTER)
    ffesymbol_set_assigned (ffebld_symter (target), TRUE);

  if (ffestc_labelref_is_assignable_ (label_token, &label))
    ffestd_R838 (label, target);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R839 -- Assigned GOTO statement

   ffestc_R839(target,target_token,label_list);

   Make sure label_list identifies valid labels for a GOTO.  Update
   each label's info to indicate it is the target of a GOTO.  */

void
ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
             ffesttTokenList label_toks)
{
  ffesttTokenItem ti;
  bool ok = TRUE;
  int i;
  ffelab *labels;

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_begin_ ();

  if (label_toks == NULL)
    {
      labels = NULL;
      i = 0;
    }
  else
    {
      labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
                    sizeof (*labels) * ffestt_tokenlist_count (label_toks));

      for (ti = label_toks->first, i = 0;
           ti != (ffesttTokenItem) &label_toks->first;
           ti = ti->next, ++i)
        {
          if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
            {
              ok = FALSE;
              break;
            }
        }
    }

  if (ok)
    ffestd_R839 (target, labels, i);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);

  /* notloop's that are actionif's can be the target of a loop-end
     statement if they're in the "then" part of a logical IF, as
     in "DO 10", "10 IF (...) GOTO I".  */

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R840 -- Arithmetic IF statement

   ffestc_R840(expr,expr_token,neg,zero,pos);

   Make sure the labels are valid; implement.  */

void
ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
             ffelexToken neg_token, ffelexToken zero_token,
             ffelexToken pos_token)
{
  ffelab neg;
  ffelab zero;
  ffelab pos;

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_begin_ ();

  if (ffestc_labelref_is_branch_ (neg_token, &neg)
      && ffestc_labelref_is_branch_ (zero_token, &zero)
      && ffestc_labelref_is_branch_ (pos_token, &pos))
    ffestd_R840 (expr, neg, zero, pos);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);

  /* notloop's that are actionif's can be the target of a loop-end
     statement if they're in the "then" part of a logical IF, as
     in "DO 10", "10 IF (...) GOTO (100,200,300), I".  */

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R841 -- CONTINUE statement

   ffestc_R841();  */

void
ffestc_R841 ()
{
  ffestc_check_simple_ ();

  if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
    return;

  ffestc_labeldef_branch_begin_ ();

  ffestd_R841 (FALSE);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R842 -- STOP statement

   ffestc_R842(expr,expr_token);

   Make sure statement is valid here; implement.  expr and expr_token are
   both NULL if there was no expression.  */

void
ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
{
  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_begin_ ();

  ffestd_R842 (expr);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);

  /* notloop's that are actionif's can be the target of a loop-end
     statement if they're in the "then" part of a logical IF, as
     in "DO 10", "10 IF (...) STOP".  */

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R843 -- PAUSE statement

   ffestc_R843(expr,expr_token);

   Make sure statement is valid here; implement.  expr and expr_token are
   both NULL if there was no expression.  */

void
ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
{
  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  ffestd_R843 (expr);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R904 -- OPEN statement

   ffestc_R904();

   Make sure an OPEN is valid in the current context, and implement it.  */

void
ffestc_R904 ()
{
  int i;
  int expect_file;
  static const char *const status_strs[] =
  {
    "New",
    "Old",
    "Replace",
    "Scratch",
    "Unknown"
  };
  static const char *const access_strs[] =
  {
    "Append",
    "Direct",
    "Keyed",
    "Sequential"
  };
  static const char *const blank_strs[] =
  {
    "Null",
    "Zero"
  };
  static const char *const carriagecontrol_strs[] =
  {
    "Fortran",
    "List",
    "None"
  };
  static const char *const dispose_strs[] =
  {
    "Delete",
    "Keep",
    "Print",
    "Print/Delete",
    "Save",
    "Submit",
    "Submit/Delete"
  };
  static const char *const form_strs[] =
  {
    "Formatted",
    "Unformatted"
  };
  static const char *const organization_strs[] =
  {
    "Indexed",
    "Relative",
    "Sequential"
  };
  static const char *const position_strs[] =
  {
    "Append",
    "AsIs",
    "Rewind"
  };
  static const char *const action_strs[] =
  {
    "Read",
    "ReadWrite",
    "Write"
  };
  static const char *const delim_strs[] =
  {
    "Apostrophe",
    "None",
    "Quote"
  };
  static const char *const recordtype_strs[] =
  {
    "Fixed",
    "Segmented",
    "Stream",
    "Stream_CR",
    "Stream_LF",
    "Variable"
  };
  static const char *const pad_strs[] =
  {
    "No",
    "Yes"
  };

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (ffestc_subr_is_branch_
      (&ffestp_file.open.open_spec[FFESTP_openixERR])
      && ffestc_subr_is_present_ ("UNIT",
                            &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
    {
      i = ffestc_subr_binsrch_ (status_strs,
                                ARRAY_SIZE (status_strs),
                           &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
                                "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
      switch (i)
        {
        case 0:         /* Unknown. */
        case 5:         /* UNKNOWN. */
          expect_file = 2;      /* Unknown, don't care about FILE=. */
          break;

        case 1:         /* NEW. */
        case 2:         /* OLD. */
          if (ffe_is_pedantic ())
            expect_file = 1;    /* Yes, need FILE=. */
          else
            expect_file = 2;    /* f2clib doesn't care about FILE=. */
          break;

        case 3:         /* REPLACE. */
          expect_file = 1;      /* Yes, need FILE=. */
          break;

        case 4:         /* SCRATCH. */
          expect_file = 0;      /* No, disallow FILE=. */
          break;

        default:
          assert ("invalid _binsrch_ result" == NULL);
          expect_file = 0;
          break;
        }
      if ((expect_file == 0)
          && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
        {
          ffebad_start (FFEBAD_CONFLICTING_SPECS);
          assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
          if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
            {
              ffebad_here (0, ffelex_token_where_line
                         (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
                           ffelex_token_where_column
                        (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
            }
          else
            {
              ffebad_here (0, ffelex_token_where_line
                      (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
                           ffelex_token_where_column
                     (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
            }
          assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
          if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
            {
              ffebad_here (1, ffelex_token_where_line
                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
                           ffelex_token_where_column
                      (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
            }
          else
            {
              ffebad_here (1, ffelex_token_where_line
                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
                           ffelex_token_where_column
                   (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
            }
          ffebad_finish ();
        }
      else if ((expect_file == 1)
        && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
        {
          ffebad_start (FFEBAD_MISSING_SPECIFIER);
          assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
          if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
            {
              ffebad_here (0, ffelex_token_where_line
                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
                           ffelex_token_where_column
                      (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
            }
          else
            {
              ffebad_here (0, ffelex_token_where_line
                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
                           ffelex_token_where_column
                   (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
            }
          ffebad_string ("FILE=");
          ffebad_finish ();
        }

      ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
                            &ffestp_file.open.open_spec[FFESTP_openixACCESS],
                            "APPEND, DIRECT, KEYED, or SEQUENTIAL");

      ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
                            &ffestp_file.open.open_spec[FFESTP_openixBLANK],
                            "NULL or ZERO");

      ffestc_subr_binsrch_ (carriagecontrol_strs,
                            ARRAY_SIZE (carriagecontrol_strs),
                  &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
                            "FORTRAN, LIST, or NONE");

      ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
                          &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
       "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");

      ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
                            &ffestp_file.open.open_spec[FFESTP_openixFORM],
                            "FORMATTED or UNFORMATTED");

      ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
                     &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
                            "INDEXED, RELATIVE, or SEQUENTIAL");

      ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
                         &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
                            "APPEND, ASIS, or REWIND");

      ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
                            &ffestp_file.open.open_spec[FFESTP_openixACTION],
                            "READ, READWRITE, or WRITE");

      ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
                            &ffestp_file.open.open_spec[FFESTP_openixDELIM],
                            "APOSTROPHE, NONE, or QUOTE");

      ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
                       &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
             "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");

      ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
                            &ffestp_file.open.open_spec[FFESTP_openixPAD],
                            "NO or YES");

      ffestd_R904 ();
    }

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R907 -- CLOSE statement

   ffestc_R907();

   Make sure a CLOSE is valid in the current context, and implement it.  */

void
ffestc_R907 ()
{
  static const char *const status_strs[] =
  {
    "Delete",
    "Keep",
    "Print",
    "Print/Delete",
    "Save",
    "Submit",
    "Submit/Delete"
  };

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (ffestc_subr_is_branch_
      (&ffestp_file.close.close_spec[FFESTP_closeixERR])
      && ffestc_subr_is_present_ ("UNIT",
                         &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
    {
      ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
                        &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
       "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");

      ffestd_R907 ();
    }

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R909_start -- READ(...) statement list begin

   ffestc_R909_start(FALSE);

   Verify that READ is valid here, and begin accepting items in the
   list.  */

void
ffestc_R909_start (bool only_format)
{
  ffestvUnit unit;
  ffestvFormat format;
  bool rec;
  bool key;
  ffestpReadIx keyn;
  ffestpReadIx spec1;
  ffestpReadIx spec2;

  ffestc_check_start_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_branch_begin_ ();

  if (!ffestc_subr_is_format_
      (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
    {
      ffestc_ok_ = FALSE;
      return;
    }

  format = ffestc_subr_format_
    (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
  ffestc_namelist_ = (format == FFESTV_formatNAMELIST);

  if (only_format)
    {
      ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);

      ffestc_ok_ = TRUE;
      return;
    }

  if (!ffestc_subr_is_branch_
      (&ffestp_file.read.read_spec[FFESTP_readixEOR])
      || !ffestc_subr_is_branch_
      (&ffestp_file.read.read_spec[FFESTP_readixERR])
      || !ffestc_subr_is_branch_
      (&ffestp_file.read.read_spec[FFESTP_readixEND]))
    {
      ffestc_ok_ = FALSE;
      return;
    }

  unit = ffestc_subr_unit_
    (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
  if (unit == FFESTV_unitNONE)
    {
      ffebad_start (FFEBAD_NO_UNIT_SPEC);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_finish ();
      ffestc_ok_ = FALSE;
      return;
    }

  rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;

  if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
    {
      key = TRUE;
      keyn = spec1 = FFESTP_readixKEYEQ;
    }
  else
    {
      key = FALSE;
      keyn = spec1 = FFESTP_readix;
    }

  if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
    {
      if (key)
        {
          spec2 = FFESTP_readixKEYGT;
        whine:                  /* :::::::::::::::::::: */
          ffebad_start (FFEBAD_CONFLICTING_SPECS);
          assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
          if (ffestp_file.read.read_spec[spec1].kw_present)
            {
              ffebad_here (0, ffelex_token_where_line
                           (ffestp_file.read.read_spec[spec1].kw),
                           ffelex_token_where_column
                           (ffestp_file.read.read_spec[spec1].kw));
            }
          else
            {
              ffebad_here (0, ffelex_token_where_line
                           (ffestp_file.read.read_spec[spec1].value),
                           ffelex_token_where_column
                           (ffestp_file.read.read_spec[spec1].value));
            }
          assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
          if (ffestp_file.read.read_spec[spec2].kw_present)
            {
              ffebad_here (1, ffelex_token_where_line
                           (ffestp_file.read.read_spec[spec2].kw),
                           ffelex_token_where_column
                           (ffestp_file.read.read_spec[spec2].kw));
            }
          else
            {
              ffebad_here (1, ffelex_token_where_line
                           (ffestp_file.read.read_spec[spec2].value),
                           ffelex_token_where_column
                           (ffestp_file.read.read_spec[spec2].value));
            }
          ffebad_finish ();
          ffestc_ok_ = FALSE;
          return;
        }
      key = TRUE;
      keyn = spec1 = FFESTP_readixKEYGT;
    }

  if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
    {
      if (key)
        {
          spec2 = FFESTP_readixKEYGT;
          goto whine;           /* :::::::::::::::::::: */
        }
      key = TRUE;
      keyn = FFESTP_readixKEYGT;
    }

  if (rec)
    {
      spec1 = FFESTP_readixREC;
      if (key)
        {
          spec2 = keyn;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (unit == FFESTV_unitCHAREXPR)
        {
          spec2 = FFESTP_readixUNIT;
          goto whine;           /* :::::::::::::::::::: */
        }
      if ((format == FFESTV_formatASTERISK)
          || (format == FFESTV_formatNAMELIST))
        {
          spec2 = FFESTP_readixFORMAT;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
        {
          spec2 = FFESTP_readixADVANCE;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
        {
          spec2 = FFESTP_readixEND;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
        {
          spec2 = FFESTP_readixNULLS;
          goto whine;           /* :::::::::::::::::::: */
        }
    }
  else if (key)
    {
      spec1 = keyn;
      if (unit == FFESTV_unitCHAREXPR)
        {
          spec2 = FFESTP_readixUNIT;
          goto whine;           /* :::::::::::::::::::: */
        }
      if ((format == FFESTV_formatASTERISK)
          || (format == FFESTV_formatNAMELIST))
        {
          spec2 = FFESTP_readixFORMAT;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
        {
          spec2 = FFESTP_readixADVANCE;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
        {
          spec2 = FFESTP_readixEND;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
        {
          spec2 = FFESTP_readixEOR;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
        {
          spec2 = FFESTP_readixNULLS;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
        {
          spec2 = FFESTP_readixREC;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
        {
          spec2 = FFESTP_readixSIZE;
          goto whine;           /* :::::::::::::::::::: */
        }
    }
  else
    {                           /* Sequential/Internal. */
      if (unit == FFESTV_unitCHAREXPR)
        {                       /* Internal file. */
          spec1 = FFESTP_readixUNIT;
          if (format == FFESTV_formatNAMELIST)
            {
              spec2 = FFESTP_readixFORMAT;
              goto whine;       /* :::::::::::::::::::: */
            }
          if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
            {
              spec2 = FFESTP_readixADVANCE;
              goto whine;       /* :::::::::::::::::::: */
            }
        }
      if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
        {                       /* ADVANCE= specified. */
          spec1 = FFESTP_readixADVANCE;
          if (format == FFESTV_formatNONE)
            {
              ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
              ffebad_here (0, ffelex_token_where_line
                           (ffestp_file.read.read_spec[spec1].kw),
                           ffelex_token_where_column
                           (ffestp_file.read.read_spec[spec1].kw));
              ffebad_finish ();

              ffestc_ok_ = FALSE;
              return;
            }
          if (format == FFESTV_formatNAMELIST)
            {
              spec2 = FFESTP_readixFORMAT;
              goto whine;       /* :::::::::::::::::::: */
            }
        }
      if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
        {                       /* EOR= specified. */
          spec1 = FFESTP_readixEOR;
          if (ffestc_subr_speccmp_ ("No",
                          &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
                                    NULL, NULL) != 0)
            {
              goto whine_advance;       /* :::::::::::::::::::: */
            }
        }
      if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
        {                       /* NULLS= specified. */
          spec1 = FFESTP_readixNULLS;
          if (format != FFESTV_formatASTERISK)
            {
              spec2 = FFESTP_readixFORMAT;
              goto whine;       /* :::::::::::::::::::: */
            }
        }
      if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
        {                       /* SIZE= specified. */
          spec1 = FFESTP_readixSIZE;
          if (ffestc_subr_speccmp_ ("No",
                          &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
                                    NULL, NULL) != 0)
            {
            whine_advance:      /* :::::::::::::::::::: */
              if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
                  .kw_or_val_present)
                {
                  ffebad_start (FFEBAD_CONFLICTING_SPECS);
                  ffebad_here (0, ffelex_token_where_line
                               (ffestp_file.read.read_spec[spec1].kw),
                               ffelex_token_where_column
                               (ffestp_file.read.read_spec[spec1].kw));
                  ffebad_here (1, ffelex_token_where_line
                      (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
                               ffelex_token_where_column
                     (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
                  ffebad_finish ();
                }
              else
                {
                  ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
                  ffebad_here (0, ffelex_token_where_line
                               (ffestp_file.read.read_spec[spec1].kw),
                               ffelex_token_where_column
                               (ffestp_file.read.read_spec[spec1].kw));
                  ffebad_finish ();
                }

              ffestc_ok_ = FALSE;
              return;
            }
        }
    }

  if (unit == FFESTV_unitCHAREXPR)
    ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
  else
    ffestc_iolist_context_ = FFEEXPR_contextIOLIST;

  ffestd_R909_start (FALSE, unit, format, rec, key);

  ffestc_ok_ = TRUE;
}

/* ffestc_R909_item -- READ statement i/o item

   ffestc_R909_item(expr,expr_token);

   Implement output-list expression.  */

void
ffestc_R909_item (ffebld expr, ffelexToken expr_token)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  if (ffestc_namelist_ != 0)
    {
      if (ffestc_namelist_ == 1)
        {
          ffestc_namelist_ = 2;
          ffebad_start (FFEBAD_NAMELIST_ITEMS);
          ffebad_here (0, ffelex_token_where_line (expr_token),
                       ffelex_token_where_column (expr_token));
          ffebad_finish ();
        }
      return;
    }

  ffestd_R909_item (expr, expr_token);
}

/* ffestc_R909_finish -- READ statement list complete

   ffestc_R909_finish();

   Just wrap up any local activities.  */

void
ffestc_R909_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R909_finish ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R910_start -- WRITE(...) statement list begin

   ffestc_R910_start();

   Verify that WRITE is valid here, and begin accepting items in the
   list.  */

void
ffestc_R910_start ()
{
  ffestvUnit unit;
  ffestvFormat format;
  bool rec;
  ffestpWriteIx spec1;
  ffestpWriteIx spec2;

  ffestc_check_start_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_branch_begin_ ();

  if (!ffestc_subr_is_branch_
      (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
      || !ffestc_subr_is_branch_
      (&ffestp_file.write.write_spec[FFESTP_writeixERR])
      || !ffestc_subr_is_format_
      (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
    {
      ffestc_ok_ = FALSE;
      return;
    }

  format = ffestc_subr_format_
    (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
  ffestc_namelist_ = (format == FFESTV_formatNAMELIST);

  unit = ffestc_subr_unit_
    (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
  if (unit == FFESTV_unitNONE)
    {
      ffebad_start (FFEBAD_NO_UNIT_SPEC);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_finish ();
      ffestc_ok_ = FALSE;
      return;
    }

  rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;

  if (rec)
    {
      spec1 = FFESTP_writeixREC;
      if (unit == FFESTV_unitCHAREXPR)
        {
          spec2 = FFESTP_writeixUNIT;
        whine:                  /* :::::::::::::::::::: */
          ffebad_start (FFEBAD_CONFLICTING_SPECS);
          assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
          if (ffestp_file.write.write_spec[spec1].kw_present)
            {
              ffebad_here (0, ffelex_token_where_line
                           (ffestp_file.write.write_spec[spec1].kw),
                           ffelex_token_where_column
                           (ffestp_file.write.write_spec[spec1].kw));
            }
          else
            {
              ffebad_here (0, ffelex_token_where_line
                           (ffestp_file.write.write_spec[spec1].value),
                           ffelex_token_where_column
                           (ffestp_file.write.write_spec[spec1].value));
            }
          assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
          if (ffestp_file.write.write_spec[spec2].kw_present)
            {
              ffebad_here (1, ffelex_token_where_line
                           (ffestp_file.write.write_spec[spec2].kw),
                           ffelex_token_where_column
                           (ffestp_file.write.write_spec[spec2].kw));
            }
          else
            {
              ffebad_here (1, ffelex_token_where_line
                           (ffestp_file.write.write_spec[spec2].value),
                           ffelex_token_where_column
                           (ffestp_file.write.write_spec[spec2].value));
            }
          ffebad_finish ();
          ffestc_ok_ = FALSE;
          return;
        }
      if ((format == FFESTV_formatASTERISK)
          || (format == FFESTV_formatNAMELIST))
        {
          spec2 = FFESTP_writeixFORMAT;
          goto whine;           /* :::::::::::::::::::: */
        }
      if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
        {
          spec2 = FFESTP_writeixADVANCE;
          goto whine;           /* :::::::::::::::::::: */
        }
    }
  else
    {                           /* Sequential/Indexed/Internal. */
      if (unit == FFESTV_unitCHAREXPR)
        {                       /* Internal file. */
          spec1 = FFESTP_writeixUNIT;
          if (format == FFESTV_formatNAMELIST)
            {
              spec2 = FFESTP_writeixFORMAT;
              goto whine;       /* :::::::::::::::::::: */
            }
          if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
            {
              spec2 = FFESTP_writeixADVANCE;
              goto whine;       /* :::::::::::::::::::: */
            }
        }
      if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
        {                       /* ADVANCE= specified. */
          spec1 = FFESTP_writeixADVANCE;
          if (format == FFESTV_formatNONE)
            {
              ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
              ffebad_here (0, ffelex_token_where_line
                           (ffestp_file.write.write_spec[spec1].kw),
                           ffelex_token_where_column
                           (ffestp_file.write.write_spec[spec1].kw));
              ffebad_finish ();

              ffestc_ok_ = FALSE;
              return;
            }
          if (format == FFESTV_formatNAMELIST)
            {
              spec2 = FFESTP_writeixFORMAT;
              goto whine;       /* :::::::::::::::::::: */
            }
        }
      if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
        {                       /* EOR= specified. */
          spec1 = FFESTP_writeixEOR;
          if (ffestc_subr_speccmp_ ("No",
                       &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
                                    NULL, NULL) != 0)
            {
              if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
                  .kw_or_val_present)
                {
                  ffebad_start (FFEBAD_CONFLICTING_SPECS);
                  ffebad_here (0, ffelex_token_where_line
                               (ffestp_file.write.write_spec[spec1].kw),
                               ffelex_token_where_column
                               (ffestp_file.write.write_spec[spec1].kw));
                  ffebad_here (1, ffelex_token_where_line
                   (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
                               ffelex_token_where_column
                  (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
                  ffebad_finish ();
                }
              else
                {
                  ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
                  ffebad_here (0, ffelex_token_where_line
                               (ffestp_file.write.write_spec[spec1].kw),
                               ffelex_token_where_column
                               (ffestp_file.write.write_spec[spec1].kw));
                  ffebad_finish ();
                }

              ffestc_ok_ = FALSE;
              return;
            }
        }
    }

  if (unit == FFESTV_unitCHAREXPR)
    ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
  else
    ffestc_iolist_context_ = FFEEXPR_contextIOLIST;

  ffestd_R910_start (unit, format, rec);

  ffestc_ok_ = TRUE;
}

/* ffestc_R910_item -- WRITE statement i/o item

   ffestc_R910_item(expr,expr_token);

   Implement output-list expression.  */

void
ffestc_R910_item (ffebld expr, ffelexToken expr_token)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  if (ffestc_namelist_ != 0)
    {
      if (ffestc_namelist_ == 1)
        {
          ffestc_namelist_ = 2;
          ffebad_start (FFEBAD_NAMELIST_ITEMS);
          ffebad_here (0, ffelex_token_where_line (expr_token),
                       ffelex_token_where_column (expr_token));
          ffebad_finish ();
        }
      return;
    }

  ffestd_R910_item (expr, expr_token);
}

/* ffestc_R910_finish -- WRITE statement list complete

   ffestc_R910_finish();

   Just wrap up any local activities.  */

void
ffestc_R910_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R910_finish ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R911_start -- PRINT(...) statement list begin

   ffestc_R911_start();

   Verify that PRINT is valid here, and begin accepting items in the
   list.  */

void
ffestc_R911_start ()
{
  ffestvFormat format;

  ffestc_check_start_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_branch_begin_ ();

  if (!ffestc_subr_is_format_
      (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
    {
      ffestc_ok_ = FALSE;
      return;
    }

  format = ffestc_subr_format_
    (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
  ffestc_namelist_ = (format == FFESTV_formatNAMELIST);

  ffestd_R911_start (format);

  ffestc_ok_ = TRUE;
}

/* ffestc_R911_item -- PRINT statement i/o item

   ffestc_R911_item(expr,expr_token);

   Implement output-list expression.  */

void
ffestc_R911_item (ffebld expr, ffelexToken expr_token)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  if (ffestc_namelist_ != 0)
    {
      if (ffestc_namelist_ == 1)
        {
          ffestc_namelist_ = 2;
          ffebad_start (FFEBAD_NAMELIST_ITEMS);
          ffebad_here (0, ffelex_token_where_line (expr_token),
                       ffelex_token_where_column (expr_token));
          ffebad_finish ();
        }
      return;
    }

  ffestd_R911_item (expr, expr_token);
}

/* ffestc_R911_finish -- PRINT statement list complete

   ffestc_R911_finish();

   Just wrap up any local activities.  */

void
ffestc_R911_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R911_finish ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R919 -- BACKSPACE statement

   ffestc_R919();

   Make sure a BACKSPACE is valid in the current context, and implement it.  */

void
ffestc_R919 ()
{
  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (ffestc_subr_is_branch_
      (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
      && ffestc_subr_is_present_ ("UNIT",
                            &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
    ffestd_R919 ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R920 -- ENDFILE statement

   ffestc_R920();

   Make sure a ENDFILE is valid in the current context, and implement it.  */

void
ffestc_R920 ()
{
  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (ffestc_subr_is_branch_
      (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
      && ffestc_subr_is_present_ ("UNIT",
                            &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
    ffestd_R920 ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R921 -- REWIND statement

   ffestc_R921();

   Make sure a REWIND is valid in the current context, and implement it.  */

void
ffestc_R921 ()
{
  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (ffestc_subr_is_branch_
      (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
      && ffestc_subr_is_present_ ("UNIT",
                            &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
    ffestd_R921 ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)

   ffestc_R923A();

   Make sure an INQUIRE is valid in the current context, and implement it.  */

void
ffestc_R923A ()
{
  bool by_file;
  bool by_unit;

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (ffestc_subr_is_branch_
      (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
    {
      by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
        .kw_or_val_present;
      by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
        .kw_or_val_present;
      if (by_file && by_unit)
        {
          ffebad_start (FFEBAD_CONFLICTING_SPECS);
          assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
          if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
            {
              ffebad_here (0, ffelex_token_where_line
                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
                           ffelex_token_where_column
               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
            }
          else
            {
              ffebad_here (0, ffelex_token_where_line
              (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
                           ffelex_token_where_column
                           (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
            }
          assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
          if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
            {
              ffebad_here (1, ffelex_token_where_line
                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
                           ffelex_token_where_column
               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
            }
          else
            {
              ffebad_here (1, ffelex_token_where_line
              (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
                           ffelex_token_where_column
                           (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
            }
          ffebad_finish ();
        }
      else if (!by_file && !by_unit)
        {
          ffebad_start (FFEBAD_MISSING_SPECIFIER);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_string ("UNIT= or FILE=");
          ffebad_finish ();
        }
      else
        ffestd_R923A (by_file);
    }

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin

   ffestc_R923B_start();

   Verify that INQUIRE is valid here, and begin accepting items in the
   list.  */

void
ffestc_R923B_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_branch_begin_ ();

  ffestd_R923B_start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_R923B_item -- INQUIRE statement i/o item

   ffestc_R923B_item(expr,expr_token);

   Implement output-list expression.  */

void
ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R923B_item (expr);
}

/* ffestc_R923B_finish -- INQUIRE statement list complete

   ffestc_R923B_finish();

   Just wrap up any local activities.  */

void
ffestc_R923B_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R923B_finish ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R1001 -- FORMAT statement

   ffestc_R1001(format_list);

   Make sure format_list is valid.  Update label's info to indicate it is a
   FORMAT label, and (perhaps) warn if there is no label!  */

void
ffestc_R1001 (ffesttFormatList f)
{
  ffestc_check_simple_ ();
  if (ffestc_order_format_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_format_ ();

  ffestd_R1001 (f);
}

/* ffestc_R1102 -- PROGRAM statement

   ffestc_R1102(name_token);

   Make sure ffestc_kind_ identifies an empty block.  Make sure name_token
   gives a valid name.  Implement the beginning of a main program.  */

void
ffestc_R1102 (ffelexToken name)
{
  ffestw b;
  ffesymbol s;

  assert (name != NULL);

  ffestc_check_simple_ ();
  if (ffestc_order_unit_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  ffestc_blocknum_ = 0;
  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, NULL);
  ffestw_set_state (b, FFESTV_statePROGRAM0);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_end_program_);

  ffestw_set_name (b, ffelex_token_use (name));

  s = ffesymbol_declare_programunit (name,
                                 ffelex_token_where_line (ffesta_tokens[0]),
                              ffelex_token_where_column (ffesta_tokens[0]));

  if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
    {
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_set_info (s,
                          ffeinfo_new (FFEINFO_basictypeNONE,
                                       FFEINFO_kindtypeNONE,
                                       0,
                                       FFEINFO_kindPROGRAM,
                                       FFEINFO_whereLOCAL,
                                       FFETARGET_charactersizeNONE));
      ffesymbol_signal_unreported (s);
    }
  else
    ffesymbol_error (s, name);

  ffestd_R1102 (s, name);
}

/* ffestc_R1103 -- END PROGRAM statement

   ffestc_R1103(name_token);

   Make sure ffestc_kind_ identifies the current kind of program unit.  If not
   NULL, make sure name_token gives the correct name.  Implement the end
   of the current program unit.  */

void
ffestc_R1103 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_program_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  if (name != NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
        {
          ffebad_start (FFEBAD_UNIT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  ffestc_shriek_end_program_ (TRUE);
}

/* ffestc_R1111 -- BLOCK DATA statement

   ffestc_R1111(name_token);

   Make sure ffestc_kind_ identifies no current program unit.  If not
   NULL, make sure name_token gives a valid name.  Implement the beginning
   of a block data program unit.  */

void
ffestc_R1111 (ffelexToken name)
{
  ffestw b;
  ffesymbol s;

  ffestc_check_simple_ ();
  if (ffestc_order_unit_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  ffestc_blocknum_ = 0;
  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, NULL);
  ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_blockdata_);

  if (name == NULL)
    ffestw_set_name (b, NULL);
  else
    ffestw_set_name (b, ffelex_token_use (name));

  s = ffesymbol_declare_blockdataunit (name,
                                 ffelex_token_where_line (ffesta_tokens[0]),
                              ffelex_token_where_column (ffesta_tokens[0]));

  if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
    {
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_set_info (s,
                          ffeinfo_new (FFEINFO_basictypeNONE,
                                       FFEINFO_kindtypeNONE,
                                       0,
                                       FFEINFO_kindBLOCKDATA,
                                       FFEINFO_whereLOCAL,
                                       FFETARGET_charactersizeNONE));
      ffesymbol_signal_unreported (s);
    }
  else
    ffesymbol_error (s, name);

  ffestd_R1111 (s, name);
}

/* ffestc_R1112 -- END BLOCK DATA statement

   ffestc_R1112(name_token);

   Make sure ffestc_kind_ identifies the current kind of program unit.  If not
   NULL, make sure name_token gives the correct name.  Implement the end
   of the current program unit.  */

void
ffestc_R1112 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  if (name != NULL)
    {
      if (ffestw_name (ffestw_stack_top ()) == NULL)
        {
          ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
          ffebad_finish ();
        }
      else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
        {
          ffebad_start (FFEBAD_UNIT_WRONG_NAME);
          ffebad_here (0, ffelex_token_where_line (name),
                       ffelex_token_where_column (name));
          ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
          ffebad_finish ();
        }
    }

  ffestc_shriek_blockdata_ (TRUE);
}

/* ffestc_R1207_start -- EXTERNAL statement list begin

   ffestc_R1207_start();

   Verify that EXTERNAL is valid here, and begin accepting items in the list.  */

void
ffestc_R1207_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_progspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestd_R1207_start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_R1207_item -- EXTERNAL statement for name

   ffestc_R1207_item(name_token);

   Make sure name_token identifies a valid object to be EXTERNALd.  */

void
ffestc_R1207_item (ffelexToken name)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;

  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  s = ffesymbol_declare_local (name, FALSE);
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (s))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
  else if (sa & FFESYMBOL_attrsANY)
    na = FFESYMBOL_attrsANY;
  else if (!(sa & ~(FFESYMBOL_attrsDUMMY
                    | FFESYMBOL_attrsTYPE)))
    na = sa | FFESYMBOL_attrsEXTERNAL;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, name);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_set_explicitwhere (s, TRUE);
      ffesymbol_reference (s, name, FALSE);
      ffesymbol_signal_unreported (s);
    }

  ffestd_R1207_item (name);
}

/* ffestc_R1207_finish -- EXTERNAL statement list complete

   ffestc_R1207_finish();

   Just wrap up any local activities.  */

void
ffestc_R1207_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R1207_finish ();
}

/* ffestc_R1208_start -- INTRINSIC statement list begin

   ffestc_R1208_start();

   Verify that INTRINSIC is valid here, and begin accepting items in the list.  */

void
ffestc_R1208_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_progspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestd_R1208_start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_R1208_item -- INTRINSIC statement for name

   ffestc_R1208_item(name_token);

   Make sure name_token identifies a valid object to be INTRINSICd.  */

void
ffestc_R1208_item (ffelexToken name)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;

  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  s = ffesymbol_declare_local (name, TRUE);
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (s))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
  else if (sa & FFESYMBOL_attrsANY)
    na = sa;
  else if (!(sa & ~FFESYMBOL_attrsTYPE))
    {
      if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
                                  &gen, &spec, &imp)
          && ((imp == FFEINTRIN_impNONE)
#if 0   /* Don't bother with this for now. */
              || ((ffeintrin_basictype (spec)
                   == ffesymbol_basictype (s))
                  && (ffeintrin_kindtype (spec)
                      == ffesymbol_kindtype (s)))
#else
              || 1
#endif
              || !(sa & FFESYMBOL_attrsTYPE)))
        na = sa | FFESYMBOL_attrsINTRINSIC;
      else
        na = FFESYMBOL_attrsetNONE;
    }
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, name);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_set_generic (s, gen);
      ffesymbol_set_specific (s, spec);
      ffesymbol_set_implementation (s, imp);
      ffesymbol_set_info (s,
                          ffeinfo_new (ffesymbol_basictype (s),
                                       ffesymbol_kindtype (s),
                                       0,
                                       FFEINFO_kindNONE,
                                       FFEINFO_whereINTRINSIC,
                                       ffesymbol_size (s)));
      ffesymbol_set_explicitwhere (s, TRUE);
      ffesymbol_reference (s, name, TRUE);
    }

  ffesymbol_signal_unreported (s);

  ffestd_R1208_item (name);
}

/* ffestc_R1208_finish -- INTRINSIC statement list complete

   ffestc_R1208_finish();

   Just wrap up any local activities.  */

void
ffestc_R1208_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_R1208_finish ();
}

/* ffestc_R1212 -- CALL statement

   ffestc_R1212(expr,expr_token);

   Make sure statement is valid here; implement.  */

void
ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
{
  ffebld item;                  /* ITEM. */
  ffebld labexpr;               /* LABTOK=>LABTER. */
  ffelab label;
  bool ok;                      /* TRUE if all LABTOKs were ok. */
  bool ok1;                     /* TRUE if a particular LABTOK is ok. */

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_branch_begin_ ();

  if (ffebld_op (expr) != FFEBLD_opSUBRREF)
    ffestd_R841 (FALSE);        /* CONTINUE. */
  else
    {
      ok = TRUE;

      for (item = ffebld_right (expr);
           item != NULL;
           item = ffebld_trail (item))
        {
          if (((labexpr = ffebld_head (item)) != NULL)
              && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
            {
              ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
                                                &label);
              ffelex_token_kill (ffebld_labtok (labexpr));
              if (!ok1)
                {
                  label = NULL;
                  ok = FALSE;
                }
              ffebld_set_op (labexpr, FFEBLD_opLABTER);
              ffebld_set_labter (labexpr, label);
            }
        }

      if (ok)
        ffestd_R1212 (expr);
    }

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R1219 -- FUNCTION statement

   ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
         recursive);

   Make sure statement is valid here, register arguments for the
   function name, and so on.

   06-Apr-90  JCB  2.0
      Added the kind, len, and recursive arguments.  */

void
ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
              ffelexToken final UNUSED, ffestpType type, ffebld kind,
              ffelexToken kindt, ffebld len, ffelexToken lent,
              ffelexToken recursive, ffelexToken result)
{
  ffestw b;
  ffesymbol s;
  ffesymbol fs;                 /* FUNCTION symbol when dealing with RESULT
                                   symbol. */
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffelexToken res;
  bool separate_result;

  assert ((funcname != NULL)
          && (ffelex_token_type (funcname) == FFELEX_typeNAME));

  ffestc_check_simple_ ();
  if (ffestc_order_iface_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  ffestc_blocknum_ = 0;
  ffesta_is_entry_valid =
    (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, NULL);
  ffestw_set_state (b, FFESTV_stateFUNCTION0);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_function_);
  ffestw_set_name (b, ffelex_token_use (funcname));

  if (type == FFESTP_typeNone)
    {
      ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
      ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
      ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
    }
  else
    {
      ffestc_establish_declstmt_ (type, ffesta_tokens[0],
                                  kind, kindt, len, lent);
      ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
    }

  separate_result = (result != NULL)
    && (ffelex_token_strcmp (funcname, result) != 0);

  if (separate_result)
    fs = ffesymbol_declare_funcnotresunit (funcname);   /* Global/local. */
  else
    fs = ffesymbol_declare_funcunit (funcname); /* Global only. */

  if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
    {
      ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_signal_unreported (fs);

      /* Note that .basic_type and .kind_type might be NONE here. */

      ffesymbol_set_info (fs,
                          ffeinfo_new (ffestc_local_.decl.basic_type,
                                       ffestc_local_.decl.kind_type,
                                       0,
                                       FFEINFO_kindFUNCTION,
                                       FFEINFO_whereLOCAL,
                                       ffestc_local_.decl.size));

      /* Check whether the type info fits the filewide expectations;
         set ok flag accordingly.  */

      ffesymbol_reference (fs, funcname, FALSE);
      if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
        ffestc_parent_ok_ = FALSE;
      else
        ffestc_parent_ok_ = TRUE;
    }
  else
    {
      if (ffesymbol_kind (fs) != FFEINFO_kindANY)
        ffesymbol_error (fs, funcname);
      ffestc_parent_ok_ = FALSE;
    }

  if (ffestc_parent_ok_)
    {
      ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
      ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
      ffebld_end_list (&ffestc_local_.dummy.list_bottom);
    }

  if (result == NULL)
    res = funcname;
  else
    res = result;

  s = ffesymbol_declare_funcresult (res);
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & FFESYMBOL_attrsANY)
    na = FFESYMBOL_attrsANY;
  else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
    na = FFESYMBOL_attrsetNONE;
  else
    {
      na = FFESYMBOL_attrsRESULT;
      if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
        {
          na |= FFESYMBOL_attrsTYPE;
          if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
              && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
            na |= FFESYMBOL_attrsANYLEN;
        }
    }

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
    {
      if (!(na & FFESYMBOL_attrsANY))
        ffesymbol_error (s, res);
      ffesymbol_set_funcresult (fs, NULL);
      ffesymbol_set_funcresult (s, NULL);
      ffestc_parent_ok_ = FALSE;
    }
  else
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      ffesymbol_set_funcresult (fs, s);
      ffesymbol_set_funcresult (s, fs);
      if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
        {
          ffesymbol_set_info (s,
                              ffeinfo_new (ffestc_local_.decl.basic_type,
                                           ffestc_local_.decl.kind_type,
                                           0,
                                           FFEINFO_kindNONE,
                                           FFEINFO_whereNONE,
                                           ffestc_local_.decl.size));
        }
    }

  ffesymbol_signal_unreported (fs);

  ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
                (recursive != NULL), result, separate_result);
}

/* ffestc_R1221 -- END FUNCTION statement

   ffestc_R1221(name_token);

   Make sure ffestc_kind_ identifies the current kind of program unit.  If
   not NULL, make sure name_token gives the correct name.  Implement the end
   of the current program unit.  */

void
ffestc_R1221 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_function_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  if ((name != NULL)
    && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
    {
      ffebad_start (FFEBAD_UNIT_WRONG_NAME);
      ffebad_here (0, ffelex_token_where_line (name),
                   ffelex_token_where_column (name));
      ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
      ffebad_finish ();
    }

  ffestc_shriek_function_ (TRUE);
}

/* ffestc_R1223 -- SUBROUTINE statement

   ffestc_R1223(subrname,arglist,ending_token,recursive_token);

   Make sure statement is valid here, register arguments for the
   subroutine name, and so on.

   06-Apr-90  JCB  2.0
      Added the recursive argument.  */

void
ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
              ffelexToken final, ffelexToken recursive)
{
  ffestw b;
  ffesymbol s;

  assert ((subrname != NULL)
          && (ffelex_token_type (subrname) == FFELEX_typeNAME));

  ffestc_check_simple_ ();
  if (ffestc_order_iface_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  ffestc_blocknum_ = 0;
  ffesta_is_entry_valid
    = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
  b = ffestw_update (ffestw_push (NULL));
  ffestw_set_top_do (b, NULL);
  ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
  ffestw_set_blocknum (b, ffestc_blocknum_++);
  ffestw_set_shriek (b, ffestc_shriek_subroutine_);
  ffestw_set_name (b, ffelex_token_use (subrname));

  s = ffesymbol_declare_subrunit (subrname);
  if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
    {
      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
      ffesymbol_set_info (s,
                          ffeinfo_new (FFEINFO_basictypeNONE,
                                       FFEINFO_kindtypeNONE,
                                       0,
                                       FFEINFO_kindSUBROUTINE,
                                       FFEINFO_whereLOCAL,
                                       FFETARGET_charactersizeNONE));
      ffestc_parent_ok_ = TRUE;
    }
  else
    {
      if (ffesymbol_kind (s) != FFEINFO_kindANY)
        ffesymbol_error (s, subrname);
      ffestc_parent_ok_ = FALSE;
    }

  if (ffestc_parent_ok_)
    {
      ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
      ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
      ffebld_end_list (&ffestc_local_.dummy.list_bottom);
    }

  ffesymbol_signal_unreported (s);

  ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
}

/* ffestc_R1225 -- END SUBROUTINE statement

   ffestc_R1225(name_token);

   Make sure ffestc_kind_ identifies the current kind of program unit.  If
   not NULL, make sure name_token gives the correct name.  Implement the end
   of the current program unit.  */

void
ffestc_R1225 (ffelexToken name)
{
  ffestc_check_simple_ ();
  if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_ ();

  if ((name != NULL)
    && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
    {
      ffebad_start (FFEBAD_UNIT_WRONG_NAME);
      ffebad_here (0, ffelex_token_where_line (name),
                   ffelex_token_where_column (name));
      ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
             ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
      ffebad_finish ();
    }

  ffestc_shriek_subroutine_ (TRUE);
}

/* ffestc_R1226 -- ENTRY statement

   ffestc_R1226(entryname,arglist,ending_token);

   Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
   entry point name, and so on.  */

void
ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
              ffelexToken final UNUSED)
{
  ffesymbol s;
  ffesymbol fs;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  bool in_spec;                 /* TRUE if further specification statements
                                   may follow, FALSE if executable stmts. */
  bool in_func;                 /* TRUE if ENTRY is a FUNCTION, not
                                   SUBROUTINE. */

  assert ((entryname != NULL)
          && (ffelex_token_type (entryname) == FFELEX_typeNAME));

  ffestc_check_simple_ ();
  if (ffestc_order_entry_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_useless_ ();

  switch (ffestw_state (ffestw_stack_top ()))
    {
    case FFESTV_stateFUNCTION1:
    case FFESTV_stateFUNCTION2:
    case FFESTV_stateFUNCTION3:
      in_func = TRUE;
      in_spec = TRUE;
      break;

    case FFESTV_stateFUNCTION4:
      in_func = TRUE;
      in_spec = FALSE;
      break;

    case FFESTV_stateSUBROUTINE1:
    case FFESTV_stateSUBROUTINE2:
    case FFESTV_stateSUBROUTINE3:
      in_func = FALSE;
      in_spec = TRUE;
      break;

    case FFESTV_stateSUBROUTINE4:
      in_func = FALSE;
      in_spec = FALSE;
      break;

    default:
      assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
      in_func = FALSE;
      in_spec = FALSE;
      break;
    }

  if (in_func)
    fs = ffesymbol_declare_funcunit (entryname);
  else
    fs = ffesymbol_declare_subrunit (entryname);

  if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
    ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
  else
    {
      if (ffesymbol_kind (fs) != FFEINFO_kindANY)
        ffesymbol_error (fs, entryname);
    }

  ++ffestc_entry_num_;

  ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
  if (in_spec)
    ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
  else
    ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
  ffebld_end_list (&ffestc_local_.dummy.list_bottom);

  if (in_func)
    {
      s = ffesymbol_declare_funcresult (entryname);
      ffesymbol_set_funcresult (fs, s);
      ffesymbol_set_funcresult (s, fs);
      sa = ffesymbol_attrs (s);

      /* Figure out what kind of object we've got based on previous
         declarations of or references to the object. */

      if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
        na = FFESYMBOL_attrsetNONE;
      else if (sa & FFESYMBOL_attrsANY)
        na = FFESYMBOL_attrsANY;
      else if (!(sa & ~(FFESYMBOL_attrsANYLEN
                        | FFESYMBOL_attrsTYPE)))
        na = sa | FFESYMBOL_attrsRESULT;
      else
        na = FFESYMBOL_attrsetNONE;

      /* Now see what we've got for a new object: NONE means a new error
         cropped up; ANY means an old error to be ignored; otherwise,
         everything's ok, update the object (symbol) and continue on. */

      if (na == FFESYMBOL_attrsetNONE)
        {
          ffesymbol_error (s, entryname);
          ffestc_parent_ok_ = FALSE;
        }
      else if (na & FFESYMBOL_attrsANY)
        {
          ffestc_parent_ok_ = FALSE;
        }
      else
        {
          ffesymbol_set_attrs (s, na);
          if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
            ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
          else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
            {
              ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
              ffesymbol_set_info (s,
                                  ffeinfo_new (ffesymbol_basictype (s),
                                               ffesymbol_kindtype (s),
                                               0,
                                               FFEINFO_kindENTITY,
                                               FFEINFO_whereRESULT,
                                               ffesymbol_size (s)));
              ffesymbol_resolve_intrin (s);
              ffestorag_exec_layout (s);
            }
        }

      /* Since ENTRY might appear after executable stmts, do what would have
         been done if it hadn't -- give symbol implicit type and
         exec-transition it.  */

      if (!in_spec && ffesymbol_is_specable (s))
        {
          if (!ffeimplic_establish_symbol (s))  /* Do implicit typing. */
            ffesymbol_error (s, entryname);
          s = ffecom_sym_exec_transition (s);
        }

      /* Use whatever type info is available for ENTRY to set up type for its
         global-name-space function symbol relative.  */

      ffesymbol_set_info (fs,
                          ffeinfo_new (ffesymbol_basictype (s),
                                       ffesymbol_kindtype (s),
                                       0,
                                       FFEINFO_kindFUNCTION,
                                       FFEINFO_whereLOCAL,
                                       ffesymbol_size (s)));


      /* Check whether the type info fits the filewide expectations;
         set ok flag accordingly.  */

      ffesymbol_reference (fs, entryname, FALSE);

      /* ~~Question??:
         When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
         if FOO and IBAR would normally end up with different types?  I think
         the answer is that FOO is always given whatever type would be chosen
         for IBAR, rather than the other way around, and I think it ends up
         working that way for FUNCTION FOO() RESULT(IBAR), but this should be
         checked out in all its different combos. Related question is, is
         there any way that FOO in either case ends up without type info
         filled in?  Does anyone care?  */

      ffesymbol_signal_unreported (s);
    }
  else
    {
      ffesymbol_set_info (fs,
                          ffeinfo_new (FFEINFO_basictypeNONE,
                                       FFEINFO_kindtypeNONE,
                                       0,
                                       FFEINFO_kindSUBROUTINE,
                                       FFEINFO_whereLOCAL,
                                       FFETARGET_charactersizeNONE));
    }

  if (!in_spec)
    fs = ffecom_sym_exec_transition (fs);

  ffesymbol_signal_unreported (fs);

  ffestd_R1226 (fs);
}

/* ffestc_R1227 -- RETURN statement

   ffestc_R1227(expr,expr_token);

   Make sure statement is valid here; implement.  expr and expr_token are
   both NULL if there was no expression.  */

void
ffestc_R1227 (ffebld expr, ffelexToken expr_token)
{
  ffestw b;

  ffestc_check_simple_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    return;
  ffestc_labeldef_notloop_begin_ ();

  for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
    {
      switch (ffestw_state (b))
        {
        case FFESTV_statePROGRAM4:
        case FFESTV_stateSUBROUTINE4:
        case FFESTV_stateFUNCTION4:
          goto base;            /* :::::::::::::::::::: */

        case FFESTV_stateNIL:
          assert ("bad state" == NULL);
          break;

        default:
          break;
        }
    }

 base:
  switch (ffestw_state (b))
    {
    case FFESTV_statePROGRAM4:
      if (ffe_is_pedantic ())
        {
          ffebad_start (FFEBAD_RETURN_IN_MAIN);
          ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
                       ffelex_token_where_column (ffesta_tokens[0]));
          ffebad_finish ();
        }
      if (expr != NULL)
        {
          ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
          ffebad_here (0, ffelex_token_where_line (expr_token),
                       ffelex_token_where_column (expr_token));
          ffebad_finish ();
          expr = NULL;
        }
      break;

    case FFESTV_stateSUBROUTINE4:
      break;

    case FFESTV_stateFUNCTION4:
      if (expr != NULL)
        {
          ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
          ffebad_here (0, ffelex_token_where_line (expr_token),
                       ffelex_token_where_column (expr_token));
          ffebad_finish ();
          expr = NULL;
        }
      break;

    default:
      assert ("bad state #2" == NULL);
      break;
    }

  ffestd_R1227 (expr);

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);

  /* notloop's that are actionif's can be the target of a loop-end
     statement if they're in the "then" part of a logical IF, as
     in "DO 10", "10 IF (...) RETURN".  */

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_R1229_start -- STMTFUNCTION statement begin

   ffestc_R1229_start(func_name,func_arg_list,close_paren);

   Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
   "live" scope within the current scope, and expect the actual expression
   (or NULL) in ffestc_R1229_finish.  The reason there are two ffestc
   functions to handle this is so the scope can be established, allowing
   ffeexpr to assign proper characteristics to references to the dummy
   arguments.  */

void
ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
                    ffelexToken final UNUSED)
{
  ffesymbol s;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;

  ffestc_check_start_ ();
  if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  assert (name != NULL);
  assert (args != NULL);

  s = ffesymbol_declare_local (name, FALSE);
  sa = ffesymbol_attrs (s);

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (!ffesymbol_is_specable (s))
    na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
  else if (sa & FFESYMBOL_attrsANY)
    na = FFESYMBOL_attrsANY;
  else if (!(sa & ~FFESYMBOL_attrsTYPE))
    na = sa | FFESYMBOL_attrsSFUNC;
  else
    na = FFESYMBOL_attrsetNONE;

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    {
      ffesymbol_error (s, name);
      ffestc_parent_ok_ = FALSE;
    }
  else if (na & FFESYMBOL_attrsANY)
    ffestc_parent_ok_ = FALSE;
  else
    {
      ffesymbol_set_attrs (s, na);
      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
      if (!ffeimplic_establish_symbol (s)
          || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
              && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
        {
          ffesymbol_error (s, ffesta_tokens[0]);
          ffestc_parent_ok_ = FALSE;
        }
      else
        {
          /* Tell ffeexpr that sfunc def is in progress.  */
          ffesymbol_set_sfexpr (s, ffebld_new_any ());
          ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
          ffestc_parent_ok_ = TRUE;
        }
    }

  ffe_init_4 ();

  if (ffestc_parent_ok_)
    {
      ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
      ffestc_sfdummy_argno_ = 0;
      ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
      ffebld_end_list (&ffestc_local_.dummy.list_bottom);
    }

  ffestc_local_.sfunc.symbol = s;

  ffestd_R1229_start (name, args);

  ffestc_ok_ = TRUE;
}

/* ffestc_R1229_finish -- STMTFUNCTION statement list complete

   ffestc_R1229_finish(expr,expr_token);

   If expr is NULL, an error occurred parsing the expansion expression, so
   just cancel the effects of ffestc_R1229_start and pretend nothing
   happened.  Otherwise, install the expression as the expansion for the
   statement function named in _start_, then clean up.  */

void
ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  if (ffestc_parent_ok_ && (expr != NULL))
    ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
                          ffeexpr_convert_to_sym (expr,
                                                  expr_token,
                                                  ffestc_local_.sfunc.symbol,
                                                  ffesta_tokens[0]));

  ffestd_R1229_finish (ffestc_local_.sfunc.symbol);

  ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);

  ffe_terminate_4 ();
}

/* ffestc_S3P4 -- INCLUDE line

   ffestc_S3P4(filename,filename_token);

   Make sure INCLUDE not preceded by any semicolons or a label def; implement.  */

void
ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
{
  ffestc_check_simple_ ();
  ffestc_labeldef_invalid_ ();

  ffestd_S3P4 (filename);
}

/* ffestc_V014_start -- VOLATILE statement list begin

   ffestc_V014_start();

   Verify that VOLATILE is valid here, and begin accepting items in the
   list.  */

void
ffestc_V014_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_progspec_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestd_V014_start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_V014_item_object -- VOLATILE statement for object-name

   ffestc_V014_item_object(name_token);

   Make sure name_token identifies a valid object to be VOLATILEd.  */

void
ffestc_V014_item_object (ffelexToken name)
{
  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  ffestd_V014_item_object (name);
}

/* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name

   ffestc_V014_item_cblock(name_token);

   Make sure name_token identifies a valid common block to be VOLATILEd.  */

void
ffestc_V014_item_cblock (ffelexToken name)
{
  ffestc_check_item_ ();
  assert (name != NULL);
  if (!ffestc_ok_)
    return;

  ffestd_V014_item_cblock (name);
}

/* ffestc_V014_finish -- VOLATILE statement list complete

   ffestc_V014_finish();

   Just wrap up any local activities.  */

void
ffestc_V014_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_V014_finish ();
}

/* ffestc_V020_start -- TYPE statement list begin

   ffestc_V020_start();

   Verify that TYPE is valid here, and begin accepting items in the
   list.  */

void
ffestc_V020_start ()
{
  ffestvFormat format;

  ffestc_check_start_ ();
  if (ffestc_order_actionif_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_branch_begin_ ();

  if (!ffestc_subr_is_format_
      (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
    {
      ffestc_ok_ = FALSE;
      return;
    }

  format = ffestc_subr_format_
    (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
  ffestc_namelist_ = (format == FFESTV_formatNAMELIST);

  ffestd_V020_start (format);

  ffestc_ok_ = TRUE;
}

/* ffestc_V020_item -- TYPE statement i/o item

   ffestc_V020_item(expr,expr_token);

   Implement output-list expression.  */

void
ffestc_V020_item (ffebld expr, ffelexToken expr_token)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  if (ffestc_namelist_ != 0)
    {
      if (ffestc_namelist_ == 1)
        {
          ffestc_namelist_ = 2;
          ffebad_start (FFEBAD_NAMELIST_ITEMS);
          ffebad_here (0, ffelex_token_where_line (expr_token),
                       ffelex_token_where_column (expr_token));
          ffebad_finish ();
        }
      return;
    }

  ffestd_V020_item (expr);
}

/* ffestc_V020_finish -- TYPE statement list complete

   ffestc_V020_finish();

   Just wrap up any local activities.  */

void
ffestc_V020_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_V020_finish ();

  if (ffestc_shriek_after1_ != NULL)
    (*ffestc_shriek_after1_) (TRUE);
  ffestc_labeldef_branch_end_ ();
}

/* ffestc_V027_start -- VXT PARAMETER statement list begin

   ffestc_V027_start();

   Verify that PARAMETER is valid here, and begin accepting items in the list.  */

void
ffestc_V027_start ()
{
  ffestc_check_start_ ();
  if (ffestc_order_parameter_ () != FFESTC_orderOK_)
    {
      ffestc_ok_ = FALSE;
      return;
    }
  ffestc_labeldef_useless_ ();

  ffestd_V027_start ();

  ffestc_ok_ = TRUE;
}

/* ffestc_V027_item -- VXT PARAMETER statement assignment

   ffestc_V027_item(dest,dest_token,source,source_token);

   Make sure the source is a valid source for the destination; make the
   assignment.  */

void
ffestc_V027_item (ffelexToken dest_token, ffebld source,
                  ffelexToken source_token UNUSED)
{
  ffestc_check_item_ ();
  if (!ffestc_ok_)
    return;

  ffestd_V027_item (dest_token, source);
}

/* ffestc_V027_finish -- VXT PARAMETER statement list complete

   ffestc_V027_finish();

   Just wrap up any local activities.  */

void
ffestc_V027_finish ()
{
  ffestc_check_finish_ ();
  if (!ffestc_ok_)
    return;

  ffestd_V027_finish ();
}

/* Any executable statement.  Mainly make sure that one-shot things
   like the statement for a logical IF are reset.  */

void
ffestc_any ()
{
  ffestc_check_simple_ ();

  ffestc_order_any_ ();

  ffestc_labeldef_any_ ();

  if (ffestc_shriek_after1_ == NULL)
    return;

  ffestd_any ();

  (*ffestc_shriek_after1_) (TRUE);
}