gcc/f/stc.c

   1 /* stc.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 2003 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       st.c
  24
  25    Description:
  26       Verifies the proper semantics for statements, checking expressions already
  27       semantically analyzed individually, collectively, checking label defs and
  28       refs, and so on.  Uses ffebad to indicate errors in semantics.
  29
  30       In many cases, both a token and a keyword (ffestrFirst, ffestrSecond,
  31       or ffestrOther) is provided.  ONLY USE THE TOKEN as a pointer to the
  32       source-code location for an error message or similar; use the keyword
  33       as the semantic matching for the token, since the token's text might
  34       not match the keyword's code.  For example, INTENT(IN OUT) A in free
  35       source form passes to ffestc_R519_start the token "IN" but the keyword
  36       FFESTR_otherINOUT, and the latter is correct.
  37
  38       Generally, either a single ffestc function handles an entire statement,
  39       in which case its name is ffestc_xyz_, or more than one function is
  40       needed, in which case its names are ffestc_xyz_start_,
  41       ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_.
  42       The caller must call _start_ before calling any _item_ functions, and
  43       must call _finish_ afterwards.  If it is clearly a syntactic matter as
  44       to restrictions on the number and variety of _item_ calls, then the caller
  45       should report any errors and ffestc_ should presume it has been taken
  46       care of and handle any semantic problems with grace and no error messages.
  47       If the permitted number and variety of _item_ calls has some basis in
  48       semantics, then the caller should not generate any messages and ffestc
  49       should do all the checking.
  50
  51       A few ffestc functions have names rather than grammar numbers, like
  52       ffestc_elsewhere and ffestc_end.  These are cases where the actual
  53       statement depends on its context rather than just its form; ELSE WHERE
  54       may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little
  55       more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE).  The actual
  56       ffestc functions do exist and do work, but may or may not be invoked
  57       by ffestb depending on whether some form of resolution is possible.
  58       For example, ffestc_R1103 end-program-stmt is reachable directly when
  59       END PROGRAM [name] is specified, or via ffestc_end when END is specified
  60       and the context is a main program.  So ffestc_xyz_ should make a quick
  61       determination of the context and pick the appropriate ffestc_Nxyz_
  62       function to invoke, without a lot of ceremony.
  63
  64    Modifications:
  65 */
  66
  67 /* Include files. */
  68
  69 #include "proj.h"
  70 #include "stc.h"
  71 #include "bad.h"
  72 #include "bld.h"
  73 #include "data.h"
  74 #include "expr.h"
  75 #include "global.h"
  76 #include "implic.h"
  77 #include "lex.h"
  78 #include "malloc.h"
  79 #include "src.h"
  80 #include "sta.h"
  81 #include "std.h"
  82 #include "stp.h"
  83 #include "str.h"
  84 #include "stt.h"
  85 #include "stw.h"
  86
  87 /* Externals defined here. */
  88
  89 ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
  90 /* Valid only from READ/WRITE start to finish. */
  91
  92 /* Simple definitions and enumerations. */
  93
  94 typedef enum
  95   {
  96     FFESTC_orderOK_,            /* Statement ok in this context, process. */
  97     FFESTC_orderBAD_,           /* Statement not ok in this context, don't
  98                                    process. */
  99     FFESTC_orderBADOK_,         /* Don't process but push block if
 100                                    applicable. */
 101     FFESTC
 102   } ffestcOrder_;
 103
 104 typedef enum
 105   {
 106     FFESTC_stateletSIMPLE_,     /* Expecting simple/start. */
 107     FFESTC_stateletATTRIB_,     /* Expecting attrib/item/itemstart. */
 108     FFESTC_stateletITEM_,       /* Expecting item/itemstart/finish. */
 109     FFESTC_stateletITEMVALS_,   /* Expecting itemvalue/itemendvals. */
 110     FFESTC_
 111   } ffestcStatelet_;
 112
 113 /* Internal typedefs. */
 114
 115
 116 /* Private include files. */
 117
 118
 119 /* Internal structure definitions. */
 120
 121 union ffestc_local_u_
 122   {
 123     struct
 124       {
 125         ffebld initlist;        /* For list of one sym in INTEGER I/3/ case. */
 126         ffetargetCharacterSize stmt_size;
 127         ffetargetCharacterSize size;
 128         ffeinfoBasictype basic_type;
 129         ffeinfoKindtype stmt_kind_type;
 130         ffeinfoKindtype kind_type;
 131         bool per_var_kind_ok;
 132         char is_R426;           /* 1=R426, 2=R501. */
 133       }
 134     decl;
 135     struct
 136       {
 137         ffebld objlist;         /* For list of target objects. */
 138         ffebldListBottom list_bottom;   /* For building lists. */
 139       }
 140     data;
 141     struct
 142       {
 143         ffebldListBottom list_bottom;   /* For building lists. */
 144         int entry_num;
 145       }
 146     dummy;
 147     struct
 148       {
 149         ffesymbol symbol;       /* NML symbol. */
 150       }
 151     namelist;
 152     struct
 153       {
 154         ffelexToken t;          /* First token in list. */
 155         ffeequiv eq;            /* Current equivalence being built up. */
 156         ffebld list;            /* List of expressions in equivalence. */
 157         ffebldListBottom bottom;
 158         bool ok;                /* TRUE while current list still being
 159                                    processed. */
 160         bool save;              /* TRUE if any var in list is SAVEd. */
 161       }
 162     equiv;
 163     struct
 164       {
 165         ffesymbol symbol;       /* BCB/NCB symbol. */
 166       }
 167     common;
 168     struct
 169       {
 170         ffesymbol symbol;       /* SFN symbol. */
 171       }
 172     sfunc;
 173   };                            /* Merge with the one in ffestc later. */
 174
 175 /* Static objects accessed by functions in this module. */
 176
 177 static bool ffestc_ok_;         /* _start_ fn's send this to _xyz_ fn's. */
 178 static bool ffestc_parent_ok_;  /* Parent sym for baby sym fn's ok. */
 179 static char ffestc_namelist_;   /* 0=>not namelist, 1=>namelist, 2=>error. */
 180 static union ffestc_local_u_ ffestc_local_;
 181 static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_;
 182 static ffestwShriek ffestc_shriek_after1_ = NULL;
 183 static unsigned long ffestc_blocknum_ = 0;      /* Next block# to assign. */
 184 static int ffestc_entry_num_;
 185 static int ffestc_sfdummy_argno_;
 186 static int ffestc_saved_entry_num_;
 187 static ffelab ffestc_label_;
 188
 189 /* Static functions (internal). */
 190
 191 static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t);
 192 static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt,
 193                                         ffebld len, ffelexToken lent);
 194 static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet,
 195                                         ffebld kind, ffelexToken kindt,
 196                                         ffebld len, ffelexToken lent);
 197 static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last);
 198 static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt,
 199                                               ffetargetCharacterSize val);
 200 static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt,
 201                                               ffetargetCharacterSize val);
 202 static void ffestc_labeldef_any_ (void);
 203 static bool ffestc_labeldef_begin_ (void);
 204 static void ffestc_labeldef_branch_begin_ (void);
 205 static void ffestc_labeldef_branch_end_ (void);
 206 static void ffestc_labeldef_endif_ (void);
 207 static void ffestc_labeldef_format_ (void);
 208 static void ffestc_labeldef_invalid_ (void);
 209 static void ffestc_labeldef_notloop_ (void);
 210 static void ffestc_labeldef_notloop_begin_ (void);
 211 static void ffestc_labeldef_useless_ (void);
 212 static bool ffestc_labelref_is_assignable_ (ffelexToken label_token,
 213                                             ffelab *label);
 214 static bool ffestc_labelref_is_branch_ (ffelexToken label_token,
 215                                         ffelab *label);
 216 static bool ffestc_labelref_is_format_ (ffelexToken label_token,
 217                                         ffelab *label);
 218 static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
 219                                          ffelab *label);
 220 static ffestcOrder_ ffestc_order_actiondo_ (void);
 221 static ffestcOrder_ ffestc_order_actionif_ (void);
 222 static ffestcOrder_ ffestc_order_actionwhere_ (void);
 223 static void ffestc_order_any_ (void);
 224 static void ffestc_order_bad_ (void);
 225 static ffestcOrder_ ffestc_order_blockdata_ (void);
 226 static ffestcOrder_ ffestc_order_blockspec_ (void);
 227 static ffestcOrder_ ffestc_order_data_ (void);
 228 static ffestcOrder_ ffestc_order_data77_ (void);
 229 static ffestcOrder_ ffestc_order_do_ (void);
 230 static ffestcOrder_ ffestc_order_entry_ (void);
 231 static ffestcOrder_ ffestc_order_exec_ (void);
 232 static ffestcOrder_ ffestc_order_format_ (void);
 233 static ffestcOrder_ ffestc_order_function_ (void);
 234 static ffestcOrder_ ffestc_order_iface_ (void);
 235 static ffestcOrder_ ffestc_order_ifthen_ (void);
 236 static ffestcOrder_ ffestc_order_implicit_ (void);
 237 static ffestcOrder_ ffestc_order_implicitnone_ (void);
 238 static ffestcOrder_ ffestc_order_parameter_ (void);
 239 static ffestcOrder_ ffestc_order_program_ (void);
 240 static ffestcOrder_ ffestc_order_progspec_ (void);
 241 static ffestcOrder_ ffestc_order_selectcase_ (void);
 242 static ffestcOrder_ ffestc_order_sfunc_ (void);
 243 static ffestcOrder_ ffestc_order_subroutine_ (void);
 244 static ffestcOrder_ ffestc_order_typedecl_ (void);
 245 static ffestcOrder_ ffestc_order_unit_ (void);
 246 static void ffestc_promote_dummy_ (ffelexToken t);
 247 static void ffestc_promote_execdummy_ (ffelexToken t);
 248 static void ffestc_promote_sfdummy_ (ffelexToken t);
 249 static void ffestc_shriek_begin_program_ (void);
 250 static void ffestc_shriek_blockdata_ (bool ok);
 251 static void ffestc_shriek_do_ (bool ok);
 252 static void ffestc_shriek_end_program_ (bool ok);
 253 static void ffestc_shriek_function_ (bool ok);
 254 static void ffestc_shriek_if_ (bool ok);
 255 static void ffestc_shriek_ifthen_ (bool ok);
 256 static void ffestc_shriek_select_ (bool ok);
 257 static void ffestc_shriek_subroutine_ (bool ok);
 258 static int ffestc_subr_binsrch_ (const char *const *list, int size,
 259                                  ffestpFile *spec, const char *whine);
 260 static ffestvFormat ffestc_subr_format_ (ffestpFile *spec);
 261 static bool ffestc_subr_is_branch_ (ffestpFile *spec);
 262 static bool ffestc_subr_is_format_ (ffestpFile *spec);
 263 static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec);
 264 static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec,
 265                                  const char **target, int *length);
 266 static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec);
 267 static void ffestc_try_shriek_do_ (void);
 268
 269 /* Internal macros. */
 270
 271 #define ffestc_check_simple_() \
 272       assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_)
 273 #define ffestc_check_start_() \
 274       assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \
 275       ffestc_statelet_ = FFESTC_stateletATTRIB_
 276 #define ffestc_check_attrib_() \
 277       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_)
 278 #define ffestc_check_item_() \
 279       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
 280             || ffestc_statelet_ == FFESTC_stateletITEM_); \
 281       ffestc_statelet_ = FFESTC_stateletITEM_
 282 #define ffestc_check_item_startvals_() \
 283       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
 284             || ffestc_statelet_ == FFESTC_stateletITEM_); \
 285       ffestc_statelet_ = FFESTC_stateletITEMVALS_
 286 #define ffestc_check_item_value_() \
 287       assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_)
 288 #define ffestc_check_item_endvals_() \
 289       assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \
 290       ffestc_statelet_ = FFESTC_stateletITEM_
 291 #define ffestc_check_finish_() \
 292       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
 293             || ffestc_statelet_ == FFESTC_stateletITEM_); \
 294       ffestc_statelet_ = FFESTC_stateletSIMPLE_
 295 #define ffestc_order_action_() ffestc_order_exec_()
 296 #define ffestc_shriek_if_lost_ ffestc_shriek_if_
 297 \f
 298 /* ffestc_establish_declinfo_ -- Determine specific type/params info for entity
 299
 300    ffestc_establish_declinfo_(kind,kind_token,len,len_token);
 301
 302    Must be called after _declstmt_ called to establish base type.  */
 303
 304 static void
 305 ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len,
 306                             ffelexToken lent)
 307 {
 308   ffeinfoBasictype bt = ffestc_local_.decl.basic_type;
 309   ffeinfoKindtype kt;
 310   ffetargetCharacterSize val;
 311
 312   if (kindt == NULL)
 313     kt = ffestc_local_.decl.stmt_kind_type;
 314   else if (!ffestc_local_.decl.per_var_kind_ok)
 315     {
 316       ffebad_start (FFEBAD_KINDTYPE);
 317       ffebad_here (0, ffelex_token_where_line (kindt),
 318                    ffelex_token_where_column (kindt));
 319       ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
 320                    ffelex_token_where_column (ffesta_tokens[0]));
 321       ffebad_finish ();
 322       kt = ffestc_local_.decl.stmt_kind_type;
 323     }
 324   else
 325     {
 326       if (kind == NULL)
 327         {
 328           assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
 329           val = atol (ffelex_token_text (kindt));
 330           kt = ffestc_kindtype_star_ (bt, val);
 331         }
 332       else if (ffebld_op (kind) == FFEBLD_opANY)
 333         kt = ffestc_local_.decl.stmt_kind_type;
 334       else
 335         {
 336           assert (ffebld_op (kind) == FFEBLD_opCONTER);
 337           assert (ffeinfo_basictype (ffebld_info (kind))
 338                   == FFEINFO_basictypeINTEGER);
 339           assert (ffeinfo_kindtype (ffebld_info (kind))
 340                   == FFEINFO_kindtypeINTEGERDEFAULT);
 341           val = ffebld_constant_integerdefault (ffebld_conter (kind));
 342           kt = ffestc_kindtype_kind_ (bt, val);
 343         }
 344
 345       if (kt == FFEINFO_kindtypeNONE)
 346         {                       /* Not valid kind type. */
 347           ffebad_start (FFEBAD_KINDTYPE);
 348           ffebad_here (0, ffelex_token_where_line (kindt),
 349                        ffelex_token_where_column (kindt));
 350           ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
 351                        ffelex_token_where_column (ffesta_tokens[0]));
 352           ffebad_finish ();
 353           kt = ffestc_local_.decl.stmt_kind_type;
 354         }
 355     }
 356
 357   ffestc_local_.decl.kind_type = kt;
 358
 359   /* Now check length specification for CHARACTER data type. */
 360
 361   if (((len == NULL) && (lent == NULL))
 362       || (bt != FFEINFO_basictypeCHARACTER))
 363     val = ffestc_local_.decl.stmt_size;
 364   else
 365     {
 366       if (len == NULL)
 367         {
 368           assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
 369           val = atol (ffelex_token_text (lent));
 370         }
 371       else if (ffebld_op (len) == FFEBLD_opSTAR)
 372         val = FFETARGET_charactersizeNONE;
 373       else if (ffebld_op (len) == FFEBLD_opANY)
 374         val = FFETARGET_charactersizeNONE;
 375       else
 376         {
 377           assert (ffebld_op (len) == FFEBLD_opCONTER);
 378           assert (ffeinfo_basictype (ffebld_info (len))
 379                   == FFEINFO_basictypeINTEGER);
 380           assert (ffeinfo_kindtype (ffebld_info (len))
 381                   == FFEINFO_kindtypeINTEGERDEFAULT);
 382           val = ffebld_constant_integerdefault (ffebld_conter (len));
 383         }
 384     }
 385
 386   if ((val == 0) && !(0 && ffe_is_90 ()))
 387     {
 388       val = 1;
 389       ffebad_start (FFEBAD_ZERO_SIZE);
 390       ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
 391       ffebad_finish ();
 392     }
 393   ffestc_local_.decl.size = val;
 394 }
 395
 396 /* ffestc_establish_declstmt_ -- Establish host-specific type/params info
 397
 398    ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
 399          len_token);  */
 400
 401 static void
 402 ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
 403                             ffelexToken kindt, ffebld len, ffelexToken lent)
 404 {
 405   ffeinfoBasictype bt;
 406   ffeinfoKindtype ktd;          /* Default kindtype. */
 407   ffeinfoKindtype kt;
 408   ffetargetCharacterSize val;
 409   bool per_var_kind_ok = TRUE;
 410
 411   /* Determine basictype and default kindtype. */
 412
 413   switch (type)
 414     {
 415     case FFESTP_typeINTEGER:
 416       bt = FFEINFO_basictypeINTEGER;
 417       ktd = FFEINFO_kindtypeINTEGERDEFAULT;
 418       break;
 419
 420     case FFESTP_typeBYTE:
 421       bt = FFEINFO_basictypeINTEGER;
 422       ktd = FFEINFO_kindtypeINTEGER2;
 423       break;
 424
 425     case FFESTP_typeWORD:
 426       bt = FFEINFO_basictypeINTEGER;
 427       ktd = FFEINFO_kindtypeINTEGER3;
 428       break;
 429
 430     case FFESTP_typeREAL:
 431       bt = FFEINFO_basictypeREAL;
 432       ktd = FFEINFO_kindtypeREALDEFAULT;
 433       break;
 434
 435     case FFESTP_typeCOMPLEX:
 436       bt = FFEINFO_basictypeCOMPLEX;
 437       ktd = FFEINFO_kindtypeREALDEFAULT;
 438       break;
 439
 440     case FFESTP_typeLOGICAL:
 441       bt = FFEINFO_basictypeLOGICAL;
 442       ktd = FFEINFO_kindtypeLOGICALDEFAULT;
 443       break;
 444
 445     case FFESTP_typeCHARACTER:
 446       bt = FFEINFO_basictypeCHARACTER;
 447       ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
 448       break;
 449
 450     case FFESTP_typeDBLPRCSN:
 451       bt = FFEINFO_basictypeREAL;
 452       ktd = FFEINFO_kindtypeREALDOUBLE;
 453       per_var_kind_ok = FALSE;
 454       break;
 455
 456     case FFESTP_typeDBLCMPLX:
 457       bt = FFEINFO_basictypeCOMPLEX;
 458 #if FFETARGET_okCOMPLEX2
 459       ktd = FFEINFO_kindtypeREALDOUBLE;
 460 #else
 461       ktd = FFEINFO_kindtypeREALDEFAULT;
 462       ffebad_start (FFEBAD_BAD_DBLCMPLX);
 463       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
 464                    ffelex_token_where_column (ffesta_tokens[0]));
 465       ffebad_finish ();
 466 #endif
 467       per_var_kind_ok = FALSE;
 468       break;
 469
 470     default:
 471       assert ("Unexpected type (F90 TYPE?)!" == NULL);
 472       bt = FFEINFO_basictypeNONE;
 473       ktd = FFEINFO_kindtypeNONE;
 474       break;
 475     }
 476
 477   if (kindt == NULL)
 478     kt = ktd;
 479   else
 480     {                           /* Not necessarily default kind type. */
 481       if (kind == NULL)
 482         {                       /* Shouldn't happen for CHARACTER. */
 483           assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
 484           val = atol (ffelex_token_text (kindt));
 485           kt = ffestc_kindtype_star_ (bt, val);
 486         }
 487       else if (ffebld_op (kind) == FFEBLD_opANY)
 488         kt = ktd;
 489       else
 490         {
 491           assert (ffebld_op (kind) == FFEBLD_opCONTER);
 492           assert (ffeinfo_basictype (ffebld_info (kind))
 493                   == FFEINFO_basictypeINTEGER);
 494           assert (ffeinfo_kindtype (ffebld_info (kind))
 495                   == FFEINFO_kindtypeINTEGERDEFAULT);
 496           val = ffebld_constant_integerdefault (ffebld_conter (kind));
 497           kt = ffestc_kindtype_kind_ (bt, val);
 498         }
 499
 500       if (kt == FFEINFO_kindtypeNONE)
 501         {                       /* Not valid kind type. */
 502           ffebad_start (FFEBAD_KINDTYPE);
 503           ffebad_here (0, ffelex_token_where_line (kindt),
 504                        ffelex_token_where_column (kindt));
 505           ffebad_here (1, ffelex_token_where_line (typet),
 506                        ffelex_token_where_column (typet));
 507           ffebad_finish ();
 508           kt = ktd;
 509         }
 510     }
 511
 512   ffestc_local_.decl.basic_type = bt;
 513   ffestc_local_.decl.stmt_kind_type = kt;
 514   ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok;
 515
 516   /* Now check length specification for CHARACTER data type. */
 517
 518   if (((len == NULL) && (lent == NULL))
 519       || (type != FFESTP_typeCHARACTER))
 520     val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
 521   else
 522     {
 523       if (len == NULL)
 524         {
 525           assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
 526           val = atol (ffelex_token_text (lent));
 527         }
 528       else if (ffebld_op (len) == FFEBLD_opSTAR)
 529         val = FFETARGET_charactersizeNONE;
 530       else if (ffebld_op (len) == FFEBLD_opANY)
 531         val = FFETARGET_charactersizeNONE;
 532       else
 533         {
 534           assert (ffebld_op (len) == FFEBLD_opCONTER);
 535           assert (ffeinfo_basictype (ffebld_info (len))
 536                   == FFEINFO_basictypeINTEGER);
 537           assert (ffeinfo_kindtype (ffebld_info (len))
 538                   == FFEINFO_kindtypeINTEGERDEFAULT);
 539           val = ffebld_constant_integerdefault (ffebld_conter (len));
 540         }
 541     }
 542
 543   if ((val == 0) && !(0 && ffe_is_90 ()))
 544     {
 545       val = 1;
 546       ffebad_start (FFEBAD_ZERO_SIZE);
 547       ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
 548       ffebad_finish ();
 549     }
 550   ffestc_local_.decl.stmt_size = val;
 551 }
 552
 553 /* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)
 554
 555    ffestc_establish_impletter_(first_letter_token,last_letter_token);  */
 556
 557 static void
 558 ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
 559 {
 560   bool ok = FALSE;              /* Stays FALSE if first letter > last. */
 561   char c;
 562
 563   if (last == NULL)
 564     ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)),
 565                                       ffestc_local_.decl.basic_type,
 566                                       ffestc_local_.decl.kind_type,
 567                                       ffestc_local_.decl.size);
 568   else
 569     {
 570       for (c = *(ffelex_token_text (first));
 571            c <= *(ffelex_token_text (last));
 572            c++)
 573         {
 574           ok = ffeimplic_establish_initial (c,
 575                                             ffestc_local_.decl.basic_type,
 576                                             ffestc_local_.decl.kind_type,
 577                                             ffestc_local_.decl.size);
 578           if (!ok)
 579             break;
 580         }
 581     }
 582
 583   if (!ok)
 584     {
 585       char cs[2];
 586
 587       cs[0] = c;
 588       cs[1] = '\0';
 589
 590       ffebad_start (FFEBAD_BAD_IMPLICIT);
 591       ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
 592       ffebad_string (cs);
 593       ffebad_finish ();
 594     }
 595 }
 596
 597 /* ffestc_init_3 -- Initialize ffestc for new program unit
 598
 599    ffestc_init_3();  */
 600
 601 void
 602 ffestc_init_3 (void)
 603 {
 604   ffestv_save_state_ = FFESTV_savestateNONE;
 605   ffestc_entry_num_ = 0;
 606   ffestv_num_label_defines_ = 0;
 607 }
 608
 609 /* ffestc_init_4 -- Initialize ffestc for new scoping unit
 610
 611    ffestc_init_4();
 612
 613    For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
 614    defs, and statement function defs.  */
 615
 616 void
 617 ffestc_init_4 (void)
 618 {
 619   ffestc_saved_entry_num_ = ffestc_entry_num_;
 620   ffestc_entry_num_ = 0;
 621 }
 622
 623 /* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value
 624
 625    ffeinfoKindtype kt;
 626    ffeinfoBasictype bt;
 627    ffetargetCharacterSize val;
 628    kt = ffestc_kindtype_kind_(bt,val);
 629    if (kt == FFEINFO_kindtypeNONE)
 630        // unsupported/invalid KIND= value for type  */
 631
 632 static ffeinfoKindtype
 633 ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
 634 {
 635   ffetype type;
 636   ffetype base_type;
 637   ffeinfoKindtype kt;
 638
 639   base_type = ffeinfo_type (bt, 1);     /* ~~ */
 640   assert (base_type != NULL);
 641
 642   type = ffetype_lookup_kind (base_type, (int) val);
 643   if (type == NULL)
 644     return FFEINFO_kindtypeNONE;
 645
 646   for (kt = 1; kt < FFEINFO_kindtype; ++kt)
 647     if (ffeinfo_type (bt, kt) == type)
 648       return kt;
 649
 650   return FFEINFO_kindtypeNONE;
 651 }
 652
 653 /* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value
 654
 655    ffeinfoKindtype kt;
 656    ffeinfoBasictype bt;
 657    ffetargetCharacterSize val;
 658    kt = ffestc_kindtype_star_(bt,val);
 659    if (kt == FFEINFO_kindtypeNONE)
 660        // unsupported/invalid * value for type  */
 661
 662 static ffeinfoKindtype
 663 ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
 664 {
 665   ffetype type;
 666   ffetype base_type;
 667   ffeinfoKindtype kt;
 668
 669   base_type = ffeinfo_type (bt, 1);     /* ~~ */
 670   assert (base_type != NULL);
 671
 672   type = ffetype_lookup_star (base_type, (int) val);
 673   if (type == NULL)
 674     return FFEINFO_kindtypeNONE;
 675
 676   for (kt = 1; kt < FFEINFO_kindtype; ++kt)
 677     if (ffeinfo_type (bt, kt) == type)
 678       return kt;
 679
 680   return FFEINFO_kindtypeNONE;
 681 }
 682
 683 /* Define label as usable for anything without complaint.  */
 684
 685 static void
 686 ffestc_labeldef_any_ (void)
 687 {
 688   if ((ffesta_label_token == NULL)
 689       || !ffestc_labeldef_begin_ ())
 690     return;
 691
 692   ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 693   ffestd_labeldef_any (ffestc_label_);
 694
 695   ffestc_labeldef_branch_end_ ();
 696 }
 697
 698 /* ffestc_labeldef_begin_ -- Define label as unknown, initially
 699
 700    ffestc_labeldef_begin_();  */
 701
 702 static bool
 703 ffestc_labeldef_begin_ (void)
 704 {
 705   ffelabValue label_value;
 706   ffelab label;
 707
 708   label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
 709   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
 710     {
 711       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
 712       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 713                    ffelex_token_where_column (ffesta_label_token));
 714       ffebad_finish ();
 715     }
 716
 717   label = ffelab_find (label_value);
 718   if (label == NULL)
 719     {
 720       label = ffestc_label_ = ffelab_new (label_value);
 721       ffestv_num_label_defines_++;
 722       ffelab_set_definition_line (label,
 723           ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
 724       ffelab_set_definition_column (label,
 725       ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
 726
 727       return TRUE;
 728     }
 729
 730   if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
 731     {
 732       ffestv_num_label_defines_++;
 733       ffestc_label_ = label;
 734       ffelab_set_definition_line (label,
 735           ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
 736       ffelab_set_definition_column (label,
 737       ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
 738
 739       return TRUE;
 740     }
 741
 742   ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED);
 743   ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 744                ffelex_token_where_column (ffesta_label_token));
 745   ffebad_here (1, ffelab_definition_line (label),
 746                ffelab_definition_column (label));
 747   ffebad_string (ffelex_token_text (ffesta_label_token));
 748   ffebad_finish ();
 749
 750   ffelex_token_kill (ffesta_label_token);
 751   ffesta_label_token = NULL;
 752   return FALSE;
 753 }
 754
 755 /* ffestc_labeldef_branch_begin_ -- Define label as a branch target one
 756
 757    ffestc_labeldef_branch_begin_();  */
 758
 759 static void
 760 ffestc_labeldef_branch_begin_ (void)
 761 {
 762   if ((ffesta_label_token == NULL)
 763       || (ffestc_shriek_after1_ != NULL)
 764       || !ffestc_labeldef_begin_ ())
 765     return;
 766
 767   switch (ffelab_type (ffestc_label_))
 768     {
 769     case FFELAB_typeUNKNOWN:
 770     case FFELAB_typeASSIGNABLE:
 771       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
 772       ffelab_set_blocknum (ffestc_label_,
 773                            ffestw_blocknum (ffestw_stack_top ()));
 774       ffestd_labeldef_branch (ffestc_label_);
 775       break;
 776
 777     case FFELAB_typeNOTLOOP:
 778       if (ffelab_blocknum (ffestc_label_)
 779           < ffestw_blocknum (ffestw_stack_top ()))
 780         {
 781           ffebad_start (FFEBAD_LABEL_BLOCK);
 782           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 783                        ffelex_token_where_column (ffesta_label_token));
 784           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
 785                        ffelab_firstref_column (ffestc_label_));
 786           ffebad_finish ();
 787         }
 788       ffelab_set_blocknum (ffestc_label_,
 789                            ffestw_blocknum (ffestw_stack_top ()));
 790       ffestd_labeldef_branch (ffestc_label_);
 791       break;
 792
 793     case FFELAB_typeLOOPEND:
 794       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
 795           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
 796         {                       /* Unterminated block. */
 797           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 798           ffestd_labeldef_any (ffestc_label_);
 799
 800           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
 801           ffebad_here (0, ffelab_doref_line (ffestc_label_),
 802                        ffelab_doref_column (ffestc_label_));
 803           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
 804           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
 805                        ffelex_token_where_column (ffesta_label_token));
 806           ffebad_finish ();
 807           break;
 808         }
 809       ffestd_labeldef_branch (ffestc_label_);
 810       /* Leave something around for _branch_end_() to handle. */
 811       return;
 812
 813     case FFELAB_typeFORMAT:
 814       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 815       ffestd_labeldef_any (ffestc_label_);
 816
 817       ffebad_start (FFEBAD_LABEL_USE_DEF);
 818       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 819                    ffelex_token_where_column (ffesta_label_token));
 820       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
 821                    ffelab_firstref_column (ffestc_label_));
 822       ffebad_finish ();
 823       break;
 824
 825     default:
 826       assert ("bad label" == NULL);
 827       /* Fall through.  */
 828     case FFELAB_typeANY:
 829       break;
 830     }
 831
 832   ffestc_try_shriek_do_ ();
 833
 834   ffelex_token_kill (ffesta_label_token);
 835   ffesta_label_token = NULL;
 836 }
 837
 838 /* Define possible end of labeled-DO-loop.  Call only after calling
 839    ffestc_labeldef_branch_begin_, or when other branch_* functions
 840    recognize that a label might also be serving as a branch end (in
 841    which case they must issue a diagnostic).  */
 842
 843 static void
 844 ffestc_labeldef_branch_end_ (void)
 845 {
 846   if (ffesta_label_token == NULL)
 847     return;
 848
 849   assert (ffestc_label_ != NULL);
 850   assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND)
 851           || (ffelab_type (ffestc_label_) == FFELAB_typeANY));
 852
 853   while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
 854          && (ffestw_label (ffestw_stack_top ()) == ffestc_label_))
 855     ffestc_shriek_do_ (TRUE);
 856
 857   ffestc_try_shriek_do_ ();
 858
 859   ffelex_token_kill (ffesta_label_token);
 860   ffesta_label_token = NULL;
 861 }
 862
 863 /* ffestc_labeldef_endif_ -- Define label as an END IF one
 864
 865    ffestc_labeldef_endif_();  */
 866
 867 static void
 868 ffestc_labeldef_endif_ (void)
 869 {
 870   if ((ffesta_label_token == NULL)
 871       || (ffestc_shriek_after1_ != NULL)
 872       || !ffestc_labeldef_begin_ ())
 873     return;
 874
 875   switch (ffelab_type (ffestc_label_))
 876     {
 877     case FFELAB_typeUNKNOWN:
 878     case FFELAB_typeASSIGNABLE:
 879       ffelab_set_type (ffestc_label_, FFELAB_typeENDIF);
 880       ffelab_set_blocknum (ffestc_label_,
 881                    ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
 882       ffestd_labeldef_endif (ffestc_label_);
 883       break;
 884
 885     case FFELAB_typeNOTLOOP:
 886       if (ffelab_blocknum (ffestc_label_)
 887           < ffestw_blocknum (ffestw_previous (ffestw_stack_top ())))
 888         {
 889           ffebad_start (FFEBAD_LABEL_BLOCK);
 890           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 891                        ffelex_token_where_column (ffesta_label_token));
 892           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
 893                        ffelab_firstref_column (ffestc_label_));
 894           ffebad_finish ();
 895         }
 896       ffelab_set_blocknum (ffestc_label_,
 897                    ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
 898       ffestd_labeldef_endif (ffestc_label_);
 899       break;
 900
 901     case FFELAB_typeLOOPEND:
 902       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
 903           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
 904         {                       /* Unterminated block. */
 905           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 906           ffestd_labeldef_any (ffestc_label_);
 907
 908           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
 909           ffebad_here (0, ffelab_doref_line (ffestc_label_),
 910                        ffelab_doref_column (ffestc_label_));
 911           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
 912           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
 913                        ffelex_token_where_column (ffesta_label_token));
 914           ffebad_finish ();
 915           break;
 916         }
 917       ffestd_labeldef_endif (ffestc_label_);
 918       ffebad_start (FFEBAD_LABEL_USE_DEF);
 919       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 920                    ffelex_token_where_column (ffesta_label_token));
 921       ffebad_here (1, ffelab_doref_line (ffestc_label_),
 922                    ffelab_doref_column (ffestc_label_));
 923       ffebad_finish ();
 924       ffestc_labeldef_branch_end_ ();
 925       return;
 926
 927     case FFELAB_typeFORMAT:
 928       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 929       ffestd_labeldef_any (ffestc_label_);
 930
 931       ffebad_start (FFEBAD_LABEL_USE_DEF);
 932       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 933                    ffelex_token_where_column (ffesta_label_token));
 934       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
 935                    ffelab_firstref_column (ffestc_label_));
 936       ffebad_finish ();
 937       break;
 938
 939     default:
 940       assert ("bad label" == NULL);
 941       /* Fall through.  */
 942     case FFELAB_typeANY:
 943       break;
 944     }
 945
 946   ffestc_try_shriek_do_ ();
 947
 948   ffelex_token_kill (ffesta_label_token);
 949   ffesta_label_token = NULL;
 950 }
 951
 952 /* ffestc_labeldef_format_ -- Define label as a FORMAT one
 953
 954    ffestc_labeldef_format_();  */
 955
 956 static void
 957 ffestc_labeldef_format_ (void)
 958 {
 959   if ((ffesta_label_token == NULL)
 960       || (ffestc_shriek_after1_ != NULL))
 961     {
 962       ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF);
 963       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
 964                    ffelex_token_where_column (ffesta_tokens[0]));
 965       ffebad_finish ();
 966       return;
 967     }
 968
 969   if (!ffestc_labeldef_begin_ ())
 970     return;
 971
 972   switch (ffelab_type (ffestc_label_))
 973     {
 974     case FFELAB_typeUNKNOWN:
 975     case FFELAB_typeASSIGNABLE:
 976       ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT);
 977       ffestd_labeldef_format (ffestc_label_);
 978       break;
 979
 980     case FFELAB_typeFORMAT:
 981       ffestd_labeldef_format (ffestc_label_);
 982       break;
 983
 984     case FFELAB_typeLOOPEND:
 985       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
 986           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
 987         {                       /* Unterminated block. */
 988           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 989           ffestd_labeldef_any (ffestc_label_);
 990
 991           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
 992           ffebad_here (0, ffelab_doref_line (ffestc_label_),
 993                        ffelab_doref_column (ffestc_label_));
 994           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
 995           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
 996                        ffelex_token_where_column (ffesta_label_token));
 997           ffebad_finish ();
 998           break;
 999         }
1000       ffestd_labeldef_format (ffestc_label_);
1001       ffebad_start (FFEBAD_LABEL_USE_DEF);
1002       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1003                    ffelex_token_where_column (ffesta_label_token));
1004       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1005                    ffelab_doref_column (ffestc_label_));
1006       ffebad_finish ();
1007       ffestc_labeldef_branch_end_ ();
1008       return;
1009
1010     case FFELAB_typeNOTLOOP:
1011       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1012       ffestd_labeldef_any (ffestc_label_);
1013
1014       ffebad_start (FFEBAD_LABEL_USE_DEF);
1015       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1016                    ffelex_token_where_column (ffesta_label_token));
1017       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1018                    ffelab_firstref_column (ffestc_label_));
1019       ffebad_finish ();
1020       break;
1021
1022     default:
1023       assert ("bad label" == NULL);
1024       /* Fall through.  */
1025     case FFELAB_typeANY:
1026       break;
1027     }
1028
1029   ffestc_try_shriek_do_ ();
1030
1031   ffelex_token_kill (ffesta_label_token);
1032   ffesta_label_token = NULL;
1033 }
1034
1035 /* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present
1036
1037    ffestc_labeldef_invalid_();  */
1038
1039 static void
1040 ffestc_labeldef_invalid_ (void)
1041 {
1042   if ((ffesta_label_token == NULL)
1043       || (ffestc_shriek_after1_ != NULL)
1044       || !ffestc_labeldef_begin_ ())
1045     return;
1046
1047   ffebad_start (FFEBAD_INVALID_LABEL_DEF);
1048   ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1049                ffelex_token_where_column (ffesta_label_token));
1050   ffebad_finish ();
1051
1052   ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1053   ffestd_labeldef_any (ffestc_label_);
1054
1055   ffestc_try_shriek_do_ ();
1056
1057   ffelex_token_kill (ffesta_label_token);
1058   ffesta_label_token = NULL;
1059 }
1060
1061 /* Define label as a non-loop-ending one on a statement that can't
1062    be in the "then" part of a logical IF, such as a block-IF statement.  */
1063
1064 static void
1065 ffestc_labeldef_notloop_ (void)
1066 {
1067   if (ffesta_label_token == NULL)
1068     return;
1069
1070   assert (ffestc_shriek_after1_ == NULL);
1071
1072   if (!ffestc_labeldef_begin_ ())
1073     return;
1074
1075   switch (ffelab_type (ffestc_label_))
1076     {
1077     case FFELAB_typeUNKNOWN:
1078     case FFELAB_typeASSIGNABLE:
1079       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
1080       ffelab_set_blocknum (ffestc_label_,
1081                            ffestw_blocknum (ffestw_stack_top ()));
1082       ffestd_labeldef_notloop (ffestc_label_);
1083       break;
1084
1085     case FFELAB_typeNOTLOOP:
1086       if (ffelab_blocknum (ffestc_label_)
1087           < ffestw_blocknum (ffestw_stack_top ()))
1088         {
1089           ffebad_start (FFEBAD_LABEL_BLOCK);
1090           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1091                        ffelex_token_where_column (ffesta_label_token));
1092           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1093                        ffelab_firstref_column (ffestc_label_));
1094           ffebad_finish ();
1095         }
1096       ffelab_set_blocknum (ffestc_label_,
1097                            ffestw_blocknum (ffestw_stack_top ()));
1098       ffestd_labeldef_notloop (ffestc_label_);
1099       break;
1100
1101     case FFELAB_typeLOOPEND:
1102       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1103           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1104         {                       /* Unterminated block. */
1105           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1106           ffestd_labeldef_any (ffestc_label_);
1107
1108           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1109           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1110                        ffelab_doref_column (ffestc_label_));
1111           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1112           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1113                        ffelex_token_where_column (ffesta_label_token));
1114           ffebad_finish ();
1115           break;
1116         }
1117       ffestd_labeldef_notloop (ffestc_label_);
1118       ffebad_start (FFEBAD_LABEL_USE_DEF);
1119       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1120                    ffelex_token_where_column (ffesta_label_token));
1121       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1122                    ffelab_doref_column (ffestc_label_));
1123       ffebad_finish ();
1124       ffestc_labeldef_branch_end_ ();
1125       return;
1126
1127     case FFELAB_typeFORMAT:
1128       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1129       ffestd_labeldef_any (ffestc_label_);
1130
1131       ffebad_start (FFEBAD_LABEL_USE_DEF);
1132       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1133                    ffelex_token_where_column (ffesta_label_token));
1134       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1135                    ffelab_firstref_column (ffestc_label_));
1136       ffebad_finish ();
1137       break;
1138
1139     default:
1140       assert ("bad label" == NULL);
1141       /* Fall through.  */
1142     case FFELAB_typeANY:
1143       break;
1144     }
1145
1146   ffestc_try_shriek_do_ ();
1147
1148   ffelex_token_kill (ffesta_label_token);
1149   ffesta_label_token = NULL;
1150 }
1151
1152 /* Define label as a non-loop-ending one.  Use this when it is
1153    possible that the pending label is inhibited because we're in
1154    the midst of a logical-IF, and thus _branch_end_ is going to
1155    be called after the current statement to resolve a potential
1156    loop-ending label.  */
1157
1158 static void
1159 ffestc_labeldef_notloop_begin_ (void)
1160 {
1161   if ((ffesta_label_token == NULL)
1162       || (ffestc_shriek_after1_ != NULL)
1163       || !ffestc_labeldef_begin_ ())
1164     return;
1165
1166   switch (ffelab_type (ffestc_label_))
1167     {
1168     case FFELAB_typeUNKNOWN:
1169     case FFELAB_typeASSIGNABLE:
1170       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
1171       ffelab_set_blocknum (ffestc_label_,
1172                            ffestw_blocknum (ffestw_stack_top ()));
1173       ffestd_labeldef_notloop (ffestc_label_);
1174       break;
1175
1176     case FFELAB_typeNOTLOOP:
1177       if (ffelab_blocknum (ffestc_label_)
1178           < ffestw_blocknum (ffestw_stack_top ()))
1179         {
1180           ffebad_start (FFEBAD_LABEL_BLOCK);
1181           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1182                        ffelex_token_where_column (ffesta_label_token));
1183           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1184                        ffelab_firstref_column (ffestc_label_));
1185           ffebad_finish ();
1186         }
1187       ffelab_set_blocknum (ffestc_label_,
1188                            ffestw_blocknum (ffestw_stack_top ()));
1189       ffestd_labeldef_notloop (ffestc_label_);
1190       break;
1191
1192     case FFELAB_typeLOOPEND:
1193       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1194           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1195         {                       /* Unterminated block. */
1196           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1197           ffestd_labeldef_any (ffestc_label_);
1198
1199           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1200           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1201                        ffelab_doref_column (ffestc_label_));
1202           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1203           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1204                        ffelex_token_where_column (ffesta_label_token));
1205           ffebad_finish ();
1206           break;
1207         }
1208       ffestd_labeldef_branch (ffestc_label_);
1209       ffebad_start (FFEBAD_LABEL_USE_DEF);
1210       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1211                    ffelex_token_where_column (ffesta_label_token));
1212       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1213                    ffelab_doref_column (ffestc_label_));
1214       ffebad_finish ();
1215       return;
1216
1217     case FFELAB_typeFORMAT:
1218       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1219       ffestd_labeldef_any (ffestc_label_);
1220
1221       ffebad_start (FFEBAD_LABEL_USE_DEF);
1222       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1223                    ffelex_token_where_column (ffesta_label_token));
1224       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1225                    ffelab_firstref_column (ffestc_label_));
1226       ffebad_finish ();
1227       break;
1228
1229     default:
1230       assert ("bad label" == NULL);
1231       /* Fall through.  */
1232     case FFELAB_typeANY:
1233       break;
1234     }
1235
1236   ffestc_try_shriek_do_ ();
1237
1238   ffelex_token_kill (ffesta_label_token);
1239   ffesta_label_token = NULL;
1240 }
1241
1242 /* ffestc_labeldef_useless_ -- Define label as a useless one
1243
1244    ffestc_labeldef_useless_();  */
1245
1246 static void
1247 ffestc_labeldef_useless_ (void)
1248 {
1249   if ((ffesta_label_token == NULL)
1250       || (ffestc_shriek_after1_ != NULL)
1251       || !ffestc_labeldef_begin_ ())
1252     return;
1253
1254   switch (ffelab_type (ffestc_label_))
1255     {
1256     case FFELAB_typeUNKNOWN:
1257       ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS);
1258       ffestd_labeldef_useless (ffestc_label_);
1259       break;
1260
1261     case FFELAB_typeLOOPEND:
1262       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1263       ffestd_labeldef_any (ffestc_label_);
1264
1265       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1266           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1267         {                       /* Unterminated block. */
1268           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1269           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1270                        ffelab_doref_column (ffestc_label_));
1271           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1272           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1273                        ffelex_token_where_column (ffesta_label_token));
1274           ffebad_finish ();
1275           break;
1276         }
1277       ffebad_start (FFEBAD_LABEL_USE_DEF);
1278       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1279                    ffelex_token_where_column (ffesta_label_token));
1280       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1281                    ffelab_doref_column (ffestc_label_));
1282       ffebad_finish ();
1283       ffestc_labeldef_branch_end_ ();
1284       return;
1285
1286     case FFELAB_typeASSIGNABLE:
1287     case FFELAB_typeFORMAT:
1288     case FFELAB_typeNOTLOOP:
1289       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1290       ffestd_labeldef_any (ffestc_label_);
1291
1292       ffebad_start (FFEBAD_LABEL_USE_DEF);
1293       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1294                    ffelex_token_where_column (ffesta_label_token));
1295       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1296                    ffelab_firstref_column (ffestc_label_));
1297       ffebad_finish ();
1298       break;
1299
1300     default:
1301       assert ("bad label" == NULL);
1302       /* Fall through.  */
1303     case FFELAB_typeANY:
1304       break;
1305     }
1306
1307   ffestc_try_shriek_do_ ();
1308
1309   ffelex_token_kill (ffesta_label_token);
1310   ffesta_label_token = NULL;
1311 }
1312
1313 /* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt
1314
1315    if (ffestc_labelref_is_assignable_(label_token,&label))
1316        // label ref is ok, label is filled in with ffelab object  */
1317
1318 static bool
1319 ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label)
1320 {
1321   ffelab label;
1322   ffelabValue label_value;
1323
1324   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1325   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1326     {
1327       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1328       ffebad_here (0, ffelex_token_where_line (label_token),
1329                    ffelex_token_where_column (label_token));
1330       ffebad_finish ();
1331       return FALSE;
1332     }
1333
1334   label = ffelab_find (label_value);
1335   if (label == NULL)
1336     {
1337       label = ffelab_new (label_value);
1338       ffelab_set_firstref_line (label,
1339                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1340       ffelab_set_firstref_column (label,
1341              ffewhere_column_use (ffelex_token_where_column (label_token)));
1342     }
1343
1344   switch (ffelab_type (label))
1345     {
1346     case FFELAB_typeUNKNOWN:
1347       ffelab_set_type (label, FFELAB_typeASSIGNABLE);
1348       break;
1349
1350     case FFELAB_typeASSIGNABLE:
1351     case FFELAB_typeLOOPEND:
1352     case FFELAB_typeFORMAT:
1353     case FFELAB_typeNOTLOOP:
1354     case FFELAB_typeENDIF:
1355       break;
1356
1357     case FFELAB_typeUSELESS:
1358       ffelab_set_type (label, FFELAB_typeANY);
1359       ffestd_labeldef_any (label);
1360
1361       ffebad_start (FFEBAD_LABEL_USE_DEF);
1362       ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1363       ffebad_here (1, ffelex_token_where_line (label_token),
1364                    ffelex_token_where_column (label_token));
1365       ffebad_finish ();
1366
1367       ffestc_try_shriek_do_ ();
1368
1369       return FALSE;
1370
1371     default:
1372       assert ("bad label" == NULL);
1373       /* Fall through.  */
1374     case FFELAB_typeANY:
1375       break;
1376     }
1377
1378   *x_label = label;
1379   return TRUE;
1380 }
1381
1382 /* ffestc_labelref_is_branch_ -- Reference to label in branch stmt
1383
1384    if (ffestc_labelref_is_branch_(label_token,&label))
1385        // label ref is ok, label is filled in with ffelab object  */
1386
1387 static bool
1388 ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label)
1389 {
1390   ffelab label;
1391   ffelabValue label_value;
1392   ffestw block;
1393   unsigned long blocknum;
1394
1395   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1396   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1397     {
1398       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1399       ffebad_here (0, ffelex_token_where_line (label_token),
1400                    ffelex_token_where_column (label_token));
1401       ffebad_finish ();
1402       return FALSE;
1403     }
1404
1405   label = ffelab_find (label_value);
1406   if (label == NULL)
1407     {
1408       label = ffelab_new (label_value);
1409       ffelab_set_firstref_line (label,
1410                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1411       ffelab_set_firstref_column (label,
1412              ffewhere_column_use (ffelex_token_where_column (label_token)));
1413     }
1414
1415   switch (ffelab_type (label))
1416     {
1417     case FFELAB_typeUNKNOWN:
1418     case FFELAB_typeASSIGNABLE:
1419       ffelab_set_type (label, FFELAB_typeNOTLOOP);
1420       ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ()));
1421       break;
1422
1423     case FFELAB_typeLOOPEND:
1424       if (ffelab_blocknum (label) != 0)
1425         break;                  /* Already taken care of. */
1426       for (block = ffestw_top_do (ffestw_stack_top ());
1427            (block != NULL) && (ffestw_label (block) != label);
1428            block = ffestw_top_do (ffestw_previous (block)))
1429         ;                       /* Find most recent DO <label> ancestor. */
1430       if (block == NULL)
1431         {                       /* Reference to within a (dead) block. */
1432           ffebad_start (FFEBAD_LABEL_BLOCK);
1433           ffebad_here (0, ffelab_definition_line (label),
1434                        ffelab_definition_column (label));
1435           ffebad_here (1, ffelex_token_where_line (label_token),
1436                        ffelex_token_where_column (label_token));
1437           ffebad_finish ();
1438           break;
1439         }
1440       ffelab_set_blocknum (label, ffestw_blocknum (block));
1441       ffelab_set_firstref_line (label,
1442                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1443       ffelab_set_firstref_column (label,
1444              ffewhere_column_use (ffelex_token_where_column (label_token)));
1445       break;
1446
1447     case FFELAB_typeNOTLOOP:
1448     case FFELAB_typeENDIF:
1449       if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
1450         break;
1451       blocknum = ffelab_blocknum (label);
1452       for (block = ffestw_stack_top ();
1453            ffestw_blocknum (block) > blocknum;
1454            block = ffestw_previous (block))
1455         ;                       /* Find most recent common ancestor. */
1456       if (ffelab_blocknum (label) == ffestw_blocknum (block))
1457         break;                  /* Check again. */
1458       if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
1459         {                       /* Reference to within a (dead) block. */
1460           ffebad_start (FFEBAD_LABEL_BLOCK);
1461           ffebad_here (0, ffelab_definition_line (label),
1462                        ffelab_definition_column (label));
1463           ffebad_here (1, ffelex_token_where_line (label_token),
1464                        ffelex_token_where_column (label_token));
1465           ffebad_finish ();
1466           break;
1467         }
1468       ffelab_set_blocknum (label, ffestw_blocknum (block));
1469       break;
1470
1471     case FFELAB_typeFORMAT:
1472       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1473         {
1474           ffelab_set_type (label, FFELAB_typeANY);
1475           ffestd_labeldef_any (label);
1476
1477           ffebad_start (FFEBAD_LABEL_USE_USE);
1478           ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1479           ffebad_here (1, ffelex_token_where_line (label_token),
1480                        ffelex_token_where_column (label_token));
1481           ffebad_finish ();
1482
1483           ffestc_try_shriek_do_ ();
1484
1485           return FALSE;
1486         }
1487       /* Fall through. */
1488     case FFELAB_typeUSELESS:
1489       ffelab_set_type (label, FFELAB_typeANY);
1490       ffestd_labeldef_any (label);
1491
1492       ffebad_start (FFEBAD_LABEL_USE_DEF);
1493       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1494       ffebad_here (1, ffelex_token_where_line (label_token),
1495                    ffelex_token_where_column (label_token));
1496       ffebad_finish ();
1497
1498       ffestc_try_shriek_do_ ();
1499
1500       return FALSE;
1501
1502     default:
1503       assert ("bad label" == NULL);
1504       /* Fall through.  */
1505     case FFELAB_typeANY:
1506       break;
1507     }
1508
1509   *x_label = label;
1510   return TRUE;
1511 }
1512
1513 /* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification
1514
1515    if (ffestc_labelref_is_format_(label_token,&label))
1516        // label ref is ok, label is filled in with ffelab object  */
1517
1518 static bool
1519 ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
1520 {
1521   ffelab label;
1522   ffelabValue label_value;
1523
1524   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1525   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1526     {
1527       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1528       ffebad_here (0, ffelex_token_where_line (label_token),
1529                    ffelex_token_where_column (label_token));
1530       ffebad_finish ();
1531       return FALSE;
1532     }
1533
1534   label = ffelab_find (label_value);
1535   if (label == NULL)
1536     {
1537       label = ffelab_new (label_value);
1538       ffelab_set_firstref_line (label,
1539                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1540       ffelab_set_firstref_column (label,
1541              ffewhere_column_use (ffelex_token_where_column (label_token)));
1542     }
1543
1544   switch (ffelab_type (label))
1545     {
1546     case FFELAB_typeUNKNOWN:
1547     case FFELAB_typeASSIGNABLE:
1548       ffelab_set_type (label, FFELAB_typeFORMAT);
1549       break;
1550
1551     case FFELAB_typeFORMAT:
1552       break;
1553
1554     case FFELAB_typeLOOPEND:
1555     case FFELAB_typeNOTLOOP:
1556       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1557         {
1558           ffelab_set_type (label, FFELAB_typeANY);
1559           ffestd_labeldef_any (label);
1560
1561           ffebad_start (FFEBAD_LABEL_USE_USE);
1562           ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1563           ffebad_here (1, ffelex_token_where_line (label_token),
1564                        ffelex_token_where_column (label_token));
1565           ffebad_finish ();
1566
1567           ffestc_try_shriek_do_ ();
1568
1569           return FALSE;
1570         }
1571       /* Fall through. */
1572     case FFELAB_typeUSELESS:
1573     case FFELAB_typeENDIF:
1574       ffelab_set_type (label, FFELAB_typeANY);
1575       ffestd_labeldef_any (label);
1576
1577       ffebad_start (FFEBAD_LABEL_USE_DEF);
1578       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1579       ffebad_here (1, ffelex_token_where_line (label_token),
1580                    ffelex_token_where_column (label_token));
1581       ffebad_finish ();
1582
1583       ffestc_try_shriek_do_ ();
1584
1585       return FALSE;
1586
1587     default:
1588       assert ("bad label" == NULL);
1589       /* Fall through.  */
1590     case FFELAB_typeANY:
1591       break;
1592     }
1593
1594   ffestc_try_shriek_do_ ();
1595
1596   *x_label = label;
1597   return TRUE;
1598 }
1599
1600 /* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt
1601
1602    if (ffestc_labelref_is_loopend_(label_token,&label))
1603        // label ref is ok, label is filled in with ffelab object  */
1604
1605 static bool
1606 ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
1607 {
1608   ffelab label;
1609   ffelabValue label_value;
1610
1611   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1612   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1613     {
1614       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1615       ffebad_here (0, ffelex_token_where_line (label_token),
1616                    ffelex_token_where_column (label_token));
1617       ffebad_finish ();
1618       return FALSE;
1619     }
1620
1621   label = ffelab_find (label_value);
1622   if (label == NULL)
1623     {
1624       label = ffelab_new (label_value);
1625       ffelab_set_doref_line (label,
1626                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1627       ffelab_set_doref_column (label,
1628              ffewhere_column_use (ffelex_token_where_column (label_token)));
1629     }
1630
1631   switch (ffelab_type (label))
1632     {
1633     case FFELAB_typeASSIGNABLE:
1634       ffelab_set_doref_line (label,
1635                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1636       ffelab_set_doref_column (label,
1637              ffewhere_column_use (ffelex_token_where_column (label_token)));
1638       ffewhere_line_kill (ffelab_firstref_line (label));
1639       ffelab_set_firstref_line (label, ffewhere_line_unknown ());
1640       ffewhere_column_kill (ffelab_firstref_column (label));
1641       ffelab_set_firstref_column (label, ffewhere_column_unknown ());
1642       /* Fall through. */
1643     case FFELAB_typeUNKNOWN:
1644       ffelab_set_type (label, FFELAB_typeLOOPEND);
1645       ffelab_set_blocknum (label, 0);
1646       break;
1647
1648     case FFELAB_typeLOOPEND:
1649       if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
1650         {                       /* Def must follow all refs. */
1651           ffelab_set_type (label, FFELAB_typeANY);
1652           ffestd_labeldef_any (label);
1653
1654           ffebad_start (FFEBAD_LABEL_DEF_DO);
1655           ffebad_here (0, ffelab_definition_line (label),
1656                        ffelab_definition_column (label));
1657           ffebad_here (1, ffelex_token_where_line (label_token),
1658                        ffelex_token_where_column (label_token));
1659           ffebad_finish ();
1660
1661           ffestc_try_shriek_do_ ();
1662
1663           return FALSE;
1664         }
1665       if (ffelab_blocknum (label) != 0)
1666         {                       /* Had a branch ref earlier, can't go inside
1667                                    this new block! */
1668           ffelab_set_type (label, FFELAB_typeANY);
1669           ffestd_labeldef_any (label);
1670
1671           ffebad_start (FFEBAD_LABEL_USE_USE);
1672           ffebad_here (0, ffelab_firstref_line (label),
1673                        ffelab_firstref_column (label));
1674           ffebad_here (1, ffelex_token_where_line (label_token),
1675                        ffelex_token_where_column (label_token));
1676           ffebad_finish ();
1677
1678           ffestc_try_shriek_do_ ();
1679
1680           return FALSE;
1681         }
1682       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1683           || (ffestw_label (ffestw_stack_top ()) != label))
1684         {                       /* Top of stack interrupts flow between two
1685                                    DOs specifying label. */
1686           ffelab_set_type (label, FFELAB_typeANY);
1687           ffestd_labeldef_any (label);
1688
1689           ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO);
1690           ffebad_here (0, ffelab_doref_line (label),
1691                        ffelab_doref_column (label));
1692           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1693           ffebad_here (2, ffelex_token_where_line (label_token),
1694                        ffelex_token_where_column (label_token));
1695           ffebad_finish ();
1696
1697           ffestc_try_shriek_do_ ();
1698
1699           return FALSE;
1700         }
1701       break;
1702
1703     case FFELAB_typeNOTLOOP:
1704     case FFELAB_typeFORMAT:
1705       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1706         {
1707           ffelab_set_type (label, FFELAB_typeANY);
1708           ffestd_labeldef_any (label);
1709
1710           ffebad_start (FFEBAD_LABEL_USE_USE);
1711           ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1712           ffebad_here (1, ffelex_token_where_line (label_token),
1713                        ffelex_token_where_column (label_token));
1714           ffebad_finish ();
1715
1716           ffestc_try_shriek_do_ ();
1717
1718           return FALSE;
1719         }
1720       /* Fall through. */
1721     case FFELAB_typeUSELESS:
1722     case FFELAB_typeENDIF:
1723       ffelab_set_type (label, FFELAB_typeANY);
1724       ffestd_labeldef_any (label);
1725
1726       ffebad_start (FFEBAD_LABEL_USE_DEF);
1727       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1728       ffebad_here (1, ffelex_token_where_line (label_token),
1729                    ffelex_token_where_column (label_token));
1730       ffebad_finish ();
1731
1732       ffestc_try_shriek_do_ ();
1733
1734       return FALSE;
1735
1736     default:
1737       assert ("bad label" == NULL);
1738       /* Fall through.  */
1739     case FFELAB_typeANY:
1740       break;
1741     }
1742
1743   *x_label = label;
1744   return TRUE;
1745 }
1746
1747 /* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
1748
1749    if (ffestc_order_actiondo_() != FFESTC_orderOK_)
1750        return;  */
1751
1752 static ffestcOrder_
1753 ffestc_order_actiondo_ (void)
1754 {
1755   recurse:
1756
1757   switch (ffestw_state (ffestw_stack_top ()))
1758     {
1759     case FFESTV_stateNIL:
1760       ffestc_shriek_begin_program_ ();
1761       goto recurse;             /* :::::::::::::::::::: */
1762
1763     case FFESTV_stateDO:
1764       return FFESTC_orderOK_;
1765
1766     case FFESTV_stateIFTHEN:
1767     case FFESTV_stateSELECT1:
1768       if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1769         break;
1770       return FFESTC_orderOK_;
1771
1772     case FFESTV_stateIF:
1773       if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1774         break;
1775       ffestc_shriek_after1_ = ffestc_shriek_if_;
1776       return FFESTC_orderOK_;
1777
1778     case FFESTV_stateUSE:
1779       goto recurse;             /* :::::::::::::::::::: */
1780
1781     case FFESTV_stateWHERE:
1782       ffestc_order_bad_ ();
1783       return FFESTC_orderBAD_;
1784
1785     default:
1786       break;
1787     }
1788   ffestc_order_bad_ ();
1789   return FFESTC_orderBAD_;
1790 }
1791
1792 /* ffestc_order_actionif_ -- Check ordering on <actionif> statement
1793
1794    if (ffestc_order_actionif_() != FFESTC_orderOK_)
1795        return;  */
1796
1797 static ffestcOrder_
1798 ffestc_order_actionif_ (void)
1799 {
1800   bool update;
1801
1802 recurse:
1803
1804   switch (ffestw_state (ffestw_stack_top ()))
1805     {
1806     case FFESTV_stateNIL:
1807       ffestc_shriek_begin_program_ ();
1808       goto recurse;             /* :::::::::::::::::::: */
1809
1810     case FFESTV_statePROGRAM0:
1811     case FFESTV_statePROGRAM1:
1812     case FFESTV_statePROGRAM2:
1813     case FFESTV_statePROGRAM3:
1814       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
1815       update = TRUE;
1816       break;
1817
1818     case FFESTV_stateSUBROUTINE0:
1819     case FFESTV_stateSUBROUTINE1:
1820     case FFESTV_stateSUBROUTINE2:
1821     case FFESTV_stateSUBROUTINE3:
1822       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
1823       update = TRUE;
1824       break;
1825
1826     case FFESTV_stateFUNCTION0:
1827     case FFESTV_stateFUNCTION1:
1828     case FFESTV_stateFUNCTION2:
1829     case FFESTV_stateFUNCTION3:
1830       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
1831       update = TRUE;
1832       break;
1833
1834     case FFESTV_statePROGRAM4:
1835     case FFESTV_stateSUBROUTINE4:
1836     case FFESTV_stateFUNCTION4:
1837       update = FALSE;
1838       break;
1839
1840     case FFESTV_stateIFTHEN:
1841     case FFESTV_stateDO:
1842     case FFESTV_stateSELECT1:
1843       return FFESTC_orderOK_;
1844
1845     case FFESTV_stateIF:
1846       ffestc_shriek_after1_ = ffestc_shriek_if_;
1847       return FFESTC_orderOK_;
1848
1849     case FFESTV_stateUSE:
1850       goto recurse;             /* :::::::::::::::::::: */
1851
1852     case FFESTV_stateWHERE:
1853       ffestc_order_bad_ ();
1854       return FFESTC_orderBAD_;
1855
1856     default:
1857       ffestc_order_bad_ ();
1858       return FFESTC_orderBAD_;
1859     }
1860
1861   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
1862     {
1863     case FFESTV_stateINTERFACE0:
1864       ffestc_order_bad_ ();
1865       if (update)
1866         ffestw_update (NULL);
1867       return FFESTC_orderBAD_;
1868
1869     default:
1870       if (update)
1871         ffestw_update (NULL);
1872       return FFESTC_orderOK_;
1873     }
1874 }
1875
1876 /* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement
1877
1878    if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
1879        return;  */
1880
1881 static ffestcOrder_
1882 ffestc_order_actionwhere_ (void)
1883 {
1884   bool update;
1885
1886 recurse:
1887
1888   switch (ffestw_state (ffestw_stack_top ()))
1889     {
1890     case FFESTV_stateNIL:
1891       ffestc_shriek_begin_program_ ();
1892       goto recurse;             /* :::::::::::::::::::: */
1893
1894     case FFESTV_statePROGRAM0:
1895     case FFESTV_statePROGRAM1:
1896     case FFESTV_statePROGRAM2:
1897     case FFESTV_statePROGRAM3:
1898       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
1899       update = TRUE;
1900       break;
1901
1902     case FFESTV_stateSUBROUTINE0:
1903     case FFESTV_stateSUBROUTINE1:
1904     case FFESTV_stateSUBROUTINE2:
1905     case FFESTV_stateSUBROUTINE3:
1906       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
1907       update = TRUE;
1908       break;
1909
1910     case FFESTV_stateFUNCTION0:
1911     case FFESTV_stateFUNCTION1:
1912     case FFESTV_stateFUNCTION2:
1913     case FFESTV_stateFUNCTION3:
1914       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
1915       update = TRUE;
1916       break;
1917
1918     case FFESTV_statePROGRAM4:
1919     case FFESTV_stateSUBROUTINE4:
1920     case FFESTV_stateFUNCTION4:
1921       update = FALSE;
1922       break;
1923
1924     case FFESTV_stateWHERETHEN:
1925     case FFESTV_stateIFTHEN:
1926     case FFESTV_stateDO:
1927     case FFESTV_stateSELECT1:
1928       return FFESTC_orderOK_;
1929
1930     case FFESTV_stateWHERE:
1931       return FFESTC_orderOK_;
1932
1933     case FFESTV_stateIF:
1934       ffestc_shriek_after1_ = ffestc_shriek_if_;
1935       return FFESTC_orderOK_;
1936
1937     case FFESTV_stateUSE:
1938       goto recurse;             /* :::::::::::::::::::: */
1939
1940     default:
1941       ffestc_order_bad_ ();
1942       return FFESTC_orderBAD_;
1943     }
1944
1945   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
1946     {
1947     case FFESTV_stateINTERFACE0:
1948       ffestc_order_bad_ ();
1949       if (update)
1950         ffestw_update (NULL);
1951       return FFESTC_orderBAD_;
1952
1953     default:
1954       if (update)
1955         ffestw_update (NULL);
1956       return FFESTC_orderOK_;
1957     }
1958 }
1959
1960 /* Check ordering on "any" statement.  Like _actionwhere_, but
1961    doesn't produce any diagnostics.  */
1962
1963 static void
1964 ffestc_order_any_ (void)
1965 {
1966   bool update;
1967
1968 recurse:
1969
1970   switch (ffestw_state (ffestw_stack_top ()))
1971     {
1972     case FFESTV_stateNIL:
1973       ffestc_shriek_begin_program_ ();
1974       goto recurse;             /* :::::::::::::::::::: */
1975
1976     case FFESTV_statePROGRAM0:
1977     case FFESTV_statePROGRAM1:
1978     case FFESTV_statePROGRAM2:
1979     case FFESTV_statePROGRAM3:
1980       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
1981       update = TRUE;
1982       break;
1983
1984     case FFESTV_stateSUBROUTINE0:
1985     case FFESTV_stateSUBROUTINE1:
1986     case FFESTV_stateSUBROUTINE2:
1987     case FFESTV_stateSUBROUTINE3:
1988       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
1989       update = TRUE;
1990       break;
1991
1992     case FFESTV_stateFUNCTION0:
1993     case FFESTV_stateFUNCTION1:
1994     case FFESTV_stateFUNCTION2:
1995     case FFESTV_stateFUNCTION3:
1996       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
1997       update = TRUE;
1998       break;
1999
2000     case FFESTV_statePROGRAM4:
2001     case FFESTV_stateSUBROUTINE4:
2002     case FFESTV_stateFUNCTION4:
2003       update = FALSE;
2004       break;
2005
2006     case FFESTV_stateWHERETHEN:
2007     case FFESTV_stateIFTHEN:
2008     case FFESTV_stateDO:
2009     case FFESTV_stateSELECT1:
2010       return;
2011
2012     case FFESTV_stateWHERE:
2013       return;
2014
2015     case FFESTV_stateIF:
2016       ffestc_shriek_after1_ = ffestc_shriek_if_;
2017       return;
2018
2019     case FFESTV_stateUSE:
2020       goto recurse;             /* :::::::::::::::::::: */
2021
2022     default:
2023       return;
2024     }
2025
2026   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2027     {
2028     case FFESTV_stateINTERFACE0:
2029       if (update)
2030         ffestw_update (NULL);
2031       return;
2032
2033     default:
2034       if (update)
2035         ffestw_update (NULL);
2036       return;
2037     }
2038 }
2039
2040 /* ffestc_order_bad_ -- Whine about statement ordering violation
2041
2042    ffestc_order_bad_();
2043
2044    Uses current ffesta_tokens[0] and, if available, info on where current
2045    state started to produce generic message.  Someday we should do
2046    fancier things than this, but this just gets things creaking along for
2047    now.  */
2048
2049 static void
2050 ffestc_order_bad_ (void)
2051 {
2052   if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
2053     {
2054       ffebad_start (FFEBAD_ORDER_1);
2055       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2056                    ffelex_token_where_column (ffesta_tokens[0]));
2057       ffebad_finish ();
2058     }
2059   else
2060     {
2061       ffebad_start (FFEBAD_ORDER_2);
2062       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2063                    ffelex_token_where_column (ffesta_tokens[0]));
2064       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
2065       ffebad_finish ();
2066     }
2067   ffestc_labeldef_useless_ ();  /* Any label definition is useless. */
2068 }
2069
2070 /* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement
2071
2072    if (ffestc_order_blockdata_() != FFESTC_orderOK_)
2073        return;  */
2074
2075 static ffestcOrder_
2076 ffestc_order_blockdata_ (void)
2077 {
2078   recurse:
2079
2080   switch (ffestw_state (ffestw_stack_top ()))
2081     {
2082     case FFESTV_stateBLOCKDATA0:
2083     case FFESTV_stateBLOCKDATA1:
2084     case FFESTV_stateBLOCKDATA2:
2085     case FFESTV_stateBLOCKDATA3:
2086     case FFESTV_stateBLOCKDATA4:
2087     case FFESTV_stateBLOCKDATA5:
2088       return FFESTC_orderOK_;
2089
2090     case FFESTV_stateUSE:
2091       goto recurse;             /* :::::::::::::::::::: */
2092
2093     case FFESTV_stateWHERE:
2094       ffestc_order_bad_ ();
2095       return FFESTC_orderBAD_;
2096
2097     case FFESTV_stateIF:
2098       ffestc_order_bad_ ();
2099       ffestc_shriek_if_ (FALSE);
2100       return FFESTC_orderBAD_;
2101
2102     default:
2103       ffestc_order_bad_ ();
2104       return FFESTC_orderBAD_;
2105     }
2106 }
2107
2108 /* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement
2109
2110    if (ffestc_order_blockspec_() != FFESTC_orderOK_)
2111        return;  */
2112
2113 static ffestcOrder_
2114 ffestc_order_blockspec_ (void)
2115 {
2116   recurse:
2117
2118   switch (ffestw_state (ffestw_stack_top ()))
2119     {
2120     case FFESTV_stateNIL:
2121       ffestc_shriek_begin_program_ ();
2122       goto recurse;             /* :::::::::::::::::::: */
2123
2124     case FFESTV_statePROGRAM0:
2125     case FFESTV_statePROGRAM1:
2126     case FFESTV_statePROGRAM2:
2127       ffestw_update (NULL);
2128       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
2129       return FFESTC_orderOK_;
2130
2131     case FFESTV_stateSUBROUTINE0:
2132     case FFESTV_stateSUBROUTINE1:
2133     case FFESTV_stateSUBROUTINE2:
2134       ffestw_update (NULL);
2135       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
2136       return FFESTC_orderOK_;
2137
2138     case FFESTV_stateFUNCTION0:
2139     case FFESTV_stateFUNCTION1:
2140     case FFESTV_stateFUNCTION2:
2141       ffestw_update (NULL);
2142       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
2143       return FFESTC_orderOK_;
2144
2145     case FFESTV_stateMODULE0:
2146     case FFESTV_stateMODULE1:
2147     case FFESTV_stateMODULE2:
2148       ffestw_update (NULL);
2149       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
2150       return FFESTC_orderOK_;
2151
2152     case FFESTV_stateBLOCKDATA0:
2153     case FFESTV_stateBLOCKDATA1:
2154     case FFESTV_stateBLOCKDATA2:
2155       ffestw_update (NULL);
2156       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
2157       return FFESTC_orderOK_;
2158
2159     case FFESTV_statePROGRAM3:
2160     case FFESTV_stateSUBROUTINE3:
2161     case FFESTV_stateFUNCTION3:
2162     case FFESTV_stateMODULE3:
2163     case FFESTV_stateBLOCKDATA3:
2164       return FFESTC_orderOK_;
2165
2166     case FFESTV_stateUSE:
2167       goto recurse;             /* :::::::::::::::::::: */
2168
2169     case FFESTV_stateWHERE:
2170       ffestc_order_bad_ ();
2171       return FFESTC_orderBAD_;
2172
2173     case FFESTV_stateIF:
2174       ffestc_order_bad_ ();
2175       ffestc_shriek_if_ (FALSE);
2176       return FFESTC_orderBAD_;
2177
2178     default:
2179       ffestc_order_bad_ ();
2180       return FFESTC_orderBAD_;
2181     }
2182 }
2183 /* ffestc_order_data_ -- Check ordering on DATA statement
2184
2185    if (ffestc_order_data_() != FFESTC_orderOK_)
2186        return;  */
2187
2188 static ffestcOrder_
2189 ffestc_order_data_ (void)
2190 {
2191   recurse:
2192
2193   switch (ffestw_state (ffestw_stack_top ()))
2194     {
2195     case FFESTV_stateNIL:
2196       ffestc_shriek_begin_program_ ();
2197       goto recurse;             /* :::::::::::::::::::: */
2198
2199     case FFESTV_statePROGRAM0:
2200     case FFESTV_statePROGRAM1:
2201       ffestw_update (NULL);
2202       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
2203       return FFESTC_orderOK_;
2204
2205     case FFESTV_stateSUBROUTINE0:
2206     case FFESTV_stateSUBROUTINE1:
2207       ffestw_update (NULL);
2208       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
2209       return FFESTC_orderOK_;
2210
2211     case FFESTV_stateFUNCTION0:
2212     case FFESTV_stateFUNCTION1:
2213       ffestw_update (NULL);
2214       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
2215       return FFESTC_orderOK_;
2216
2217     case FFESTV_stateBLOCKDATA0:
2218     case FFESTV_stateBLOCKDATA1:
2219       ffestw_update (NULL);
2220       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
2221       return FFESTC_orderOK_;
2222
2223     case FFESTV_statePROGRAM2:
2224     case FFESTV_stateSUBROUTINE2:
2225     case FFESTV_stateFUNCTION2:
2226     case FFESTV_stateBLOCKDATA2:
2227     case FFESTV_statePROGRAM3:
2228     case FFESTV_stateSUBROUTINE3:
2229     case FFESTV_stateFUNCTION3:
2230     case FFESTV_stateBLOCKDATA3:
2231     case FFESTV_statePROGRAM4:
2232     case FFESTV_stateSUBROUTINE4:
2233     case FFESTV_stateFUNCTION4:
2234     case FFESTV_stateBLOCKDATA4:
2235     case FFESTV_stateWHERETHEN:
2236     case FFESTV_stateIFTHEN:
2237     case FFESTV_stateDO:
2238     case FFESTV_stateSELECT0:
2239     case FFESTV_stateSELECT1:
2240       return FFESTC_orderOK_;
2241
2242     case FFESTV_stateUSE:
2243       goto recurse;             /* :::::::::::::::::::: */
2244
2245     case FFESTV_stateWHERE:
2246       ffestc_order_bad_ ();
2247       return FFESTC_orderBAD_;
2248
2249     case FFESTV_stateIF:
2250       ffestc_order_bad_ ();
2251       ffestc_shriek_if_ (FALSE);
2252       return FFESTC_orderBAD_;
2253
2254     default:
2255       ffestc_order_bad_ ();
2256       return FFESTC_orderBAD_;
2257     }
2258 }
2259
2260 /* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement
2261
2262    if (ffestc_order_data77_() != FFESTC_orderOK_)
2263        return;  */
2264
2265 static ffestcOrder_
2266 ffestc_order_data77_ (void)
2267 {
2268   recurse:
2269
2270   switch (ffestw_state (ffestw_stack_top ()))
2271     {
2272     case FFESTV_stateNIL:
2273       ffestc_shriek_begin_program_ ();
2274       goto recurse;             /* :::::::::::::::::::: */
2275
2276     case FFESTV_statePROGRAM0:
2277     case FFESTV_statePROGRAM1:
2278     case FFESTV_statePROGRAM2:
2279     case FFESTV_statePROGRAM3:
2280       ffestw_update (NULL);
2281       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2282       return FFESTC_orderOK_;
2283
2284     case FFESTV_stateSUBROUTINE0:
2285     case FFESTV_stateSUBROUTINE1:
2286     case FFESTV_stateSUBROUTINE2:
2287     case FFESTV_stateSUBROUTINE3:
2288       ffestw_update (NULL);
2289       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2290       return FFESTC_orderOK_;
2291
2292     case FFESTV_stateFUNCTION0:
2293     case FFESTV_stateFUNCTION1:
2294     case FFESTV_stateFUNCTION2:
2295     case FFESTV_stateFUNCTION3:
2296       ffestw_update (NULL);
2297       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2298       return FFESTC_orderOK_;
2299
2300     case FFESTV_stateBLOCKDATA0:
2301     case FFESTV_stateBLOCKDATA1:
2302     case FFESTV_stateBLOCKDATA2:
2303     case FFESTV_stateBLOCKDATA3:
2304       ffestw_update (NULL);
2305       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4);
2306       return FFESTC_orderOK_;
2307
2308     case FFESTV_statePROGRAM4:
2309     case FFESTV_stateSUBROUTINE4:
2310     case FFESTV_stateFUNCTION4:
2311     case FFESTV_stateBLOCKDATA4:
2312       return FFESTC_orderOK_;
2313
2314     case FFESTV_stateWHERETHEN:
2315     case FFESTV_stateIFTHEN:
2316     case FFESTV_stateDO:
2317     case FFESTV_stateSELECT0:
2318     case FFESTV_stateSELECT1:
2319       return FFESTC_orderOK_;
2320
2321     case FFESTV_stateUSE:
2322       goto recurse;             /* :::::::::::::::::::: */
2323
2324     case FFESTV_stateWHERE:
2325       ffestc_order_bad_ ();
2326       return FFESTC_orderBAD_;
2327
2328     case FFESTV_stateIF:
2329       ffestc_order_bad_ ();
2330       ffestc_shriek_if_ (FALSE);
2331       return FFESTC_orderBAD_;
2332
2333     default:
2334       ffestc_order_bad_ ();
2335       return FFESTC_orderBAD_;
2336     }
2337 }
2338 /* ffestc_order_do_ -- Check ordering on <do> statement
2339
2340    if (ffestc_order_do_() != FFESTC_orderOK_)
2341        return;  */
2342
2343 static ffestcOrder_
2344 ffestc_order_do_ (void)
2345 {
2346   switch (ffestw_state (ffestw_stack_top ()))
2347     {
2348     case FFESTV_stateDO:
2349       return FFESTC_orderOK_;
2350
2351     case FFESTV_stateWHERE:
2352       ffestc_order_bad_ ();
2353       return FFESTC_orderBAD_;
2354
2355     case FFESTV_stateIF:
2356       ffestc_order_bad_ ();
2357       ffestc_shriek_if_ (FALSE);
2358       return FFESTC_orderBAD_;
2359
2360     default:
2361       ffestc_order_bad_ ();
2362       return FFESTC_orderBAD_;
2363     }
2364 }
2365
2366 /* ffestc_order_entry_ -- Check ordering on ENTRY statement
2367
2368    if (ffestc_order_entry_() != FFESTC_orderOK_)
2369        return;  */
2370
2371 static ffestcOrder_
2372 ffestc_order_entry_ (void)
2373 {
2374   recurse:
2375
2376   switch (ffestw_state (ffestw_stack_top ()))
2377     {
2378     case FFESTV_stateNIL:
2379       ffestc_shriek_begin_program_ ();
2380       goto recurse;             /* :::::::::::::::::::: */
2381
2382     case FFESTV_stateSUBROUTINE0:
2383       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2384       break;
2385
2386     case FFESTV_stateFUNCTION0:
2387       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2388       break;
2389
2390     case FFESTV_stateSUBROUTINE1:
2391     case FFESTV_stateSUBROUTINE2:
2392     case FFESTV_stateFUNCTION1:
2393     case FFESTV_stateFUNCTION2:
2394     case FFESTV_stateSUBROUTINE3:
2395     case FFESTV_stateFUNCTION3:
2396     case FFESTV_stateSUBROUTINE4:
2397     case FFESTV_stateFUNCTION4:
2398       break;
2399
2400     case FFESTV_stateUSE:
2401       goto recurse;             /* :::::::::::::::::::: */
2402
2403     case FFESTV_stateWHERE:
2404       ffestc_order_bad_ ();
2405       return FFESTC_orderBAD_;
2406
2407     case FFESTV_stateIF:
2408       ffestc_order_bad_ ();
2409       ffestc_shriek_if_ (FALSE);
2410       return FFESTC_orderBAD_;
2411
2412     default:
2413       ffestc_order_bad_ ();
2414       return FFESTC_orderBAD_;
2415     }
2416
2417   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2418     {
2419     case FFESTV_stateNIL:
2420     case FFESTV_stateMODULE5:
2421       ffestw_update (NULL);
2422       return FFESTC_orderOK_;
2423
2424     default:
2425       ffestc_order_bad_ ();
2426       ffestw_update (NULL);
2427       return FFESTC_orderBAD_;
2428     }
2429 }
2430
2431 /* ffestc_order_exec_ -- Check ordering on <exec> statement
2432
2433    if (ffestc_order_exec_() != FFESTC_orderOK_)
2434        return;  */
2435
2436 static ffestcOrder_
2437 ffestc_order_exec_ (void)
2438 {
2439   bool update;
2440
2441 recurse:
2442
2443   switch (ffestw_state (ffestw_stack_top ()))
2444     {
2445     case FFESTV_stateNIL:
2446       ffestc_shriek_begin_program_ ();
2447       goto recurse;             /* :::::::::::::::::::: */
2448
2449     case FFESTV_statePROGRAM0:
2450     case FFESTV_statePROGRAM1:
2451     case FFESTV_statePROGRAM2:
2452     case FFESTV_statePROGRAM3:
2453       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2454       update = TRUE;
2455       break;
2456
2457     case FFESTV_stateSUBROUTINE0:
2458     case FFESTV_stateSUBROUTINE1:
2459     case FFESTV_stateSUBROUTINE2:
2460     case FFESTV_stateSUBROUTINE3:
2461       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2462       update = TRUE;
2463       break;
2464
2465     case FFESTV_stateFUNCTION0:
2466     case FFESTV_stateFUNCTION1:
2467     case FFESTV_stateFUNCTION2:
2468     case FFESTV_stateFUNCTION3:
2469       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2470       update = TRUE;
2471       break;
2472
2473     case FFESTV_statePROGRAM4:
2474     case FFESTV_stateSUBROUTINE4:
2475     case FFESTV_stateFUNCTION4:
2476       update = FALSE;
2477       break;
2478
2479     case FFESTV_stateIFTHEN:
2480     case FFESTV_stateDO:
2481     case FFESTV_stateSELECT1:
2482       return FFESTC_orderOK_;
2483
2484     case FFESTV_stateUSE:
2485       goto recurse;             /* :::::::::::::::::::: */
2486
2487     case FFESTV_stateWHERE:
2488       ffestc_order_bad_ ();
2489       return FFESTC_orderBAD_;
2490
2491     case FFESTV_stateIF:
2492       ffestc_order_bad_ ();
2493       ffestc_shriek_if_ (FALSE);
2494       return FFESTC_orderBAD_;
2495
2496     default:
2497       ffestc_order_bad_ ();
2498       return FFESTC_orderBAD_;
2499     }
2500
2501   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2502     {
2503     case FFESTV_stateINTERFACE0:
2504       ffestc_order_bad_ ();
2505       if (update)
2506         ffestw_update (NULL);
2507       return FFESTC_orderBAD_;
2508
2509     default:
2510       if (update)
2511         ffestw_update (NULL);
2512       return FFESTC_orderOK_;
2513     }
2514 }
2515
2516 /* ffestc_order_format_ -- Check ordering on FORMAT statement
2517
2518    if (ffestc_order_format_() != FFESTC_orderOK_)
2519        return;  */
2520
2521 static ffestcOrder_
2522 ffestc_order_format_ (void)
2523 {
2524   recurse:
2525
2526   switch (ffestw_state (ffestw_stack_top ()))
2527     {
2528     case FFESTV_stateNIL:
2529       ffestc_shriek_begin_program_ ();
2530       goto recurse;             /* :::::::::::::::::::: */
2531
2532     case FFESTV_statePROGRAM0:
2533       ffestw_update (NULL);
2534       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
2535       return FFESTC_orderOK_;
2536
2537     case FFESTV_stateSUBROUTINE0:
2538       ffestw_update (NULL);
2539       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2540       return FFESTC_orderOK_;
2541
2542     case FFESTV_stateFUNCTION0:
2543       ffestw_update (NULL);
2544       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2545       return FFESTC_orderOK_;
2546
2547     case FFESTV_statePROGRAM1:
2548     case FFESTV_statePROGRAM2:
2549     case FFESTV_stateSUBROUTINE1:
2550     case FFESTV_stateSUBROUTINE2:
2551     case FFESTV_stateFUNCTION1:
2552     case FFESTV_stateFUNCTION2:
2553     case FFESTV_statePROGRAM3:
2554     case FFESTV_stateSUBROUTINE3:
2555     case FFESTV_stateFUNCTION3:
2556     case FFESTV_statePROGRAM4:
2557     case FFESTV_stateSUBROUTINE4:
2558     case FFESTV_stateFUNCTION4:
2559     case FFESTV_stateWHERETHEN:
2560     case FFESTV_stateIFTHEN:
2561     case FFESTV_stateDO:
2562     case FFESTV_stateSELECT0:
2563     case FFESTV_stateSELECT1:
2564       return FFESTC_orderOK_;
2565
2566     case FFESTV_stateUSE:
2567       goto recurse;             /* :::::::::::::::::::: */
2568
2569     case FFESTV_stateWHERE:
2570       ffestc_order_bad_ ();
2571       return FFESTC_orderBAD_;
2572
2573     case FFESTV_stateIF:
2574       ffestc_order_bad_ ();
2575       ffestc_shriek_if_ (FALSE);
2576       return FFESTC_orderBAD_;
2577
2578     default:
2579       ffestc_order_bad_ ();
2580       return FFESTC_orderBAD_;
2581     }
2582 }
2583
2584 /* ffestc_order_function_ -- Check ordering on <function> statement
2585
2586    if (ffestc_order_function_() != FFESTC_orderOK_)
2587        return;  */
2588
2589 static ffestcOrder_
2590 ffestc_order_function_ (void)
2591 {
2592   recurse:
2593
2594   switch (ffestw_state (ffestw_stack_top ()))
2595     {
2596     case FFESTV_stateFUNCTION0:
2597     case FFESTV_stateFUNCTION1:
2598     case FFESTV_stateFUNCTION2:
2599     case FFESTV_stateFUNCTION3:
2600     case FFESTV_stateFUNCTION4:
2601     case FFESTV_stateFUNCTION5:
2602       return FFESTC_orderOK_;
2603
2604     case FFESTV_stateUSE:
2605       goto recurse;             /* :::::::::::::::::::: */
2606
2607     case FFESTV_stateWHERE:
2608       ffestc_order_bad_ ();
2609       return FFESTC_orderBAD_;
2610
2611     case FFESTV_stateIF:
2612       ffestc_order_bad_ ();
2613       ffestc_shriek_if_ (FALSE);
2614       return FFESTC_orderBAD_;
2615
2616     default:
2617       ffestc_order_bad_ ();
2618       return FFESTC_orderBAD_;
2619     }
2620 }
2621
2622 /* ffestc_order_iface_ -- Check ordering on <iface> statement
2623
2624    if (ffestc_order_iface_() != FFESTC_orderOK_)
2625        return;  */
2626
2627 static ffestcOrder_
2628 ffestc_order_iface_ (void)
2629 {
2630   switch (ffestw_state (ffestw_stack_top ()))
2631     {
2632     case FFESTV_stateNIL:
2633     case FFESTV_statePROGRAM5:
2634     case FFESTV_stateSUBROUTINE5:
2635     case FFESTV_stateFUNCTION5:
2636     case FFESTV_stateMODULE5:
2637     case FFESTV_stateINTERFACE0:
2638       return FFESTC_orderOK_;
2639
2640     case FFESTV_stateWHERE:
2641       ffestc_order_bad_ ();
2642       return FFESTC_orderBAD_;
2643
2644     case FFESTV_stateIF:
2645       ffestc_order_bad_ ();
2646       ffestc_shriek_if_ (FALSE);
2647       return FFESTC_orderBAD_;
2648
2649     default:
2650       ffestc_order_bad_ ();
2651       return FFESTC_orderBAD_;
2652     }
2653 }
2654
2655 /* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement
2656
2657    if (ffestc_order_ifthen_() != FFESTC_orderOK_)
2658        return;  */
2659
2660 static ffestcOrder_
2661 ffestc_order_ifthen_ (void)
2662 {
2663   switch (ffestw_state (ffestw_stack_top ()))
2664     {
2665     case FFESTV_stateIFTHEN:
2666       return FFESTC_orderOK_;
2667
2668     case FFESTV_stateWHERE:
2669       ffestc_order_bad_ ();
2670       return FFESTC_orderBAD_;
2671
2672     case FFESTV_stateIF:
2673       ffestc_order_bad_ ();
2674       ffestc_shriek_if_ (FALSE);
2675       return FFESTC_orderBAD_;
2676
2677     default:
2678       ffestc_order_bad_ ();
2679       return FFESTC_orderBAD_;
2680     }
2681 }
2682
2683 /* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement
2684
2685    if (ffestc_order_implicit_() != FFESTC_orderOK_)
2686        return;  */
2687
2688 static ffestcOrder_
2689 ffestc_order_implicit_ (void)
2690 {
2691   recurse:
2692
2693   switch (ffestw_state (ffestw_stack_top ()))
2694     {
2695     case FFESTV_stateNIL:
2696       ffestc_shriek_begin_program_ ();
2697       goto recurse;             /* :::::::::::::::::::: */
2698
2699     case FFESTV_statePROGRAM0:
2700     case FFESTV_statePROGRAM1:
2701       ffestw_update (NULL);
2702       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
2703       return FFESTC_orderOK_;
2704
2705     case FFESTV_stateSUBROUTINE0:
2706     case FFESTV_stateSUBROUTINE1:
2707       ffestw_update (NULL);
2708       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
2709       return FFESTC_orderOK_;
2710
2711     case FFESTV_stateFUNCTION0:
2712     case FFESTV_stateFUNCTION1:
2713       ffestw_update (NULL);
2714       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
2715       return FFESTC_orderOK_;
2716
2717     case FFESTV_stateMODULE0:
2718     case FFESTV_stateMODULE1:
2719       ffestw_update (NULL);
2720       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
2721       return FFESTC_orderOK_;
2722
2723     case FFESTV_stateBLOCKDATA0:
2724     case FFESTV_stateBLOCKDATA1:
2725       ffestw_update (NULL);
2726       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
2727       return FFESTC_orderOK_;
2728
2729     case FFESTV_statePROGRAM2:
2730     case FFESTV_stateSUBROUTINE2:
2731     case FFESTV_stateFUNCTION2:
2732     case FFESTV_stateMODULE2:
2733     case FFESTV_stateBLOCKDATA2:
2734       return FFESTC_orderOK_;
2735
2736     case FFESTV_stateUSE:
2737       goto recurse;             /* :::::::::::::::::::: */
2738
2739     case FFESTV_stateWHERE:
2740       ffestc_order_bad_ ();
2741       return FFESTC_orderBAD_;
2742
2743     case FFESTV_stateIF:
2744       ffestc_order_bad_ ();
2745       ffestc_shriek_if_ (FALSE);
2746       return FFESTC_orderBAD_;
2747
2748     default:
2749       ffestc_order_bad_ ();
2750       return FFESTC_orderBAD_;
2751     }
2752 }
2753
2754 /* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement
2755
2756    if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
2757        return;  */
2758
2759 static ffestcOrder_
2760 ffestc_order_implicitnone_ (void)
2761 {
2762   recurse:
2763
2764   switch (ffestw_state (ffestw_stack_top ()))
2765     {
2766     case FFESTV_stateNIL:
2767       ffestc_shriek_begin_program_ ();
2768       goto recurse;             /* :::::::::::::::::::: */
2769
2770     case FFESTV_statePROGRAM0:
2771     case FFESTV_statePROGRAM1:
2772       ffestw_update (NULL);
2773       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
2774       return FFESTC_orderOK_;
2775
2776     case FFESTV_stateSUBROUTINE0:
2777     case FFESTV_stateSUBROUTINE1:
2778       ffestw_update (NULL);
2779       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
2780       return FFESTC_orderOK_;
2781
2782     case FFESTV_stateFUNCTION0:
2783     case FFESTV_stateFUNCTION1:
2784       ffestw_update (NULL);
2785       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
2786       return FFESTC_orderOK_;
2787
2788     case FFESTV_stateMODULE0:
2789     case FFESTV_stateMODULE1:
2790       ffestw_update (NULL);
2791       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
2792       return FFESTC_orderOK_;
2793
2794     case FFESTV_stateBLOCKDATA0:
2795     case FFESTV_stateBLOCKDATA1:
2796       ffestw_update (NULL);
2797       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
2798       return FFESTC_orderOK_;
2799
2800     case FFESTV_stateUSE:
2801       goto recurse;             /* :::::::::::::::::::: */
2802
2803     case FFESTV_stateWHERE:
2804       ffestc_order_bad_ ();
2805       return FFESTC_orderBAD_;
2806
2807     case FFESTV_stateIF:
2808       ffestc_order_bad_ ();
2809       ffestc_shriek_if_ (FALSE);
2810       return FFESTC_orderBAD_;
2811
2812     default:
2813       ffestc_order_bad_ ();
2814       return FFESTC_orderBAD_;
2815     }
2816 }
2817
2818 /* ffestc_order_parameter_ -- Check ordering on <parameter> statement
2819
2820    if (ffestc_order_parameter_() != FFESTC_orderOK_)
2821        return;  */
2822
2823 static ffestcOrder_
2824 ffestc_order_parameter_ (void)
2825 {
2826   recurse:
2827
2828   switch (ffestw_state (ffestw_stack_top ()))
2829     {
2830     case FFESTV_stateNIL:
2831       ffestc_shriek_begin_program_ ();
2832       goto recurse;             /* :::::::::::::::::::: */
2833
2834     case FFESTV_statePROGRAM0:
2835     case FFESTV_statePROGRAM1:
2836       ffestw_update (NULL);
2837       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
2838       return FFESTC_orderOK_;
2839
2840     case FFESTV_stateSUBROUTINE0:
2841     case FFESTV_stateSUBROUTINE1:
2842       ffestw_update (NULL);
2843       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
2844       return FFESTC_orderOK_;
2845
2846     case FFESTV_stateFUNCTION0:
2847     case FFESTV_stateFUNCTION1:
2848       ffestw_update (NULL);
2849       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
2850       return FFESTC_orderOK_;
2851
2852     case FFESTV_stateMODULE0:
2853     case FFESTV_stateMODULE1:
2854       ffestw_update (NULL);
2855       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
2856       return FFESTC_orderOK_;
2857
2858     case FFESTV_stateBLOCKDATA0:
2859     case FFESTV_stateBLOCKDATA1:
2860       ffestw_update (NULL);
2861       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
2862       return FFESTC_orderOK_;
2863
2864     case FFESTV_statePROGRAM2:
2865     case FFESTV_stateSUBROUTINE2:
2866     case FFESTV_stateFUNCTION2:
2867     case FFESTV_stateMODULE2:
2868     case FFESTV_stateBLOCKDATA2:
2869     case FFESTV_statePROGRAM3:
2870     case FFESTV_stateSUBROUTINE3:
2871     case FFESTV_stateFUNCTION3:
2872     case FFESTV_stateMODULE3:
2873     case FFESTV_stateBLOCKDATA3:
2874     case FFESTV_stateTYPE:      /* GNU extension here! */
2875     case FFESTV_stateSTRUCTURE:
2876     case FFESTV_stateUNION:
2877     case FFESTV_stateMAP:
2878       return FFESTC_orderOK_;
2879
2880     case FFESTV_stateUSE:
2881       goto recurse;             /* :::::::::::::::::::: */
2882
2883     case FFESTV_stateWHERE:
2884       ffestc_order_bad_ ();
2885       return FFESTC_orderBAD_;
2886
2887     case FFESTV_stateIF:
2888       ffestc_order_bad_ ();
2889       ffestc_shriek_if_ (FALSE);
2890       return FFESTC_orderBAD_;
2891
2892     default:
2893       ffestc_order_bad_ ();
2894       return FFESTC_orderBAD_;
2895     }
2896 }
2897
2898 /* ffestc_order_program_ -- Check ordering on <program> statement
2899
2900    if (ffestc_order_program_() != FFESTC_orderOK_)
2901        return;  */
2902
2903 static ffestcOrder_
2904 ffestc_order_program_ (void)
2905 {
2906   recurse:
2907
2908   switch (ffestw_state (ffestw_stack_top ()))
2909     {
2910     case FFESTV_stateNIL:
2911       ffestc_shriek_begin_program_ ();
2912       goto recurse;             /* :::::::::::::::::::: */
2913
2914     case FFESTV_statePROGRAM0:
2915     case FFESTV_statePROGRAM1:
2916     case FFESTV_statePROGRAM2:
2917     case FFESTV_statePROGRAM3:
2918     case FFESTV_statePROGRAM4:
2919     case FFESTV_statePROGRAM5:
2920       return FFESTC_orderOK_;
2921
2922     case FFESTV_stateUSE:
2923       goto recurse;             /* :::::::::::::::::::: */
2924
2925     case FFESTV_stateWHERE:
2926       ffestc_order_bad_ ();
2927       return FFESTC_orderBAD_;
2928
2929     case FFESTV_stateIF:
2930       ffestc_order_bad_ ();
2931       ffestc_shriek_if_ (FALSE);
2932       return FFESTC_orderBAD_;
2933
2934     default:
2935       ffestc_order_bad_ ();
2936       return FFESTC_orderBAD_;
2937     }
2938 }
2939
2940 /* ffestc_order_progspec_ -- Check ordering on <progspec> statement
2941
2942    if (ffestc_order_progspec_() != FFESTC_orderOK_)
2943        return;  */
2944
2945 static ffestcOrder_
2946 ffestc_order_progspec_ (void)
2947 {
2948   recurse:
2949
2950   switch (ffestw_state (ffestw_stack_top ()))
2951     {
2952     case FFESTV_stateNIL:
2953       ffestc_shriek_begin_program_ ();
2954       goto recurse;             /* :::::::::::::::::::: */
2955
2956     case FFESTV_statePROGRAM0:
2957     case FFESTV_statePROGRAM1:
2958     case FFESTV_statePROGRAM2:
2959       ffestw_update (NULL);
2960       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
2961       return FFESTC_orderOK_;
2962
2963     case FFESTV_stateSUBROUTINE0:
2964     case FFESTV_stateSUBROUTINE1:
2965     case FFESTV_stateSUBROUTINE2:
2966       ffestw_update (NULL);
2967       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
2968       return FFESTC_orderOK_;
2969
2970     case FFESTV_stateFUNCTION0:
2971     case FFESTV_stateFUNCTION1:
2972     case FFESTV_stateFUNCTION2:
2973       ffestw_update (NULL);
2974       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
2975       return FFESTC_orderOK_;
2976
2977     case FFESTV_stateMODULE0:
2978     case FFESTV_stateMODULE1:
2979     case FFESTV_stateMODULE2:
2980       ffestw_update (NULL);
2981       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
2982       return FFESTC_orderOK_;
2983
2984     case FFESTV_statePROGRAM3:
2985     case FFESTV_stateSUBROUTINE3:
2986     case FFESTV_stateFUNCTION3:
2987     case FFESTV_stateMODULE3:
2988       return FFESTC_orderOK_;
2989
2990     case FFESTV_stateBLOCKDATA0:
2991     case FFESTV_stateBLOCKDATA1:
2992     case FFESTV_stateBLOCKDATA2:
2993       ffestw_update (NULL);
2994       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
2995       if (ffe_is_pedantic ())
2996         {
2997           ffebad_start (FFEBAD_BLOCKDATA_STMT);
2998           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2999                        ffelex_token_where_column (ffesta_tokens[0]));
3000           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
3001           ffebad_finish ();
3002         }
3003       return FFESTC_orderOK_;
3004
3005     case FFESTV_stateUSE:
3006       goto recurse;             /* :::::::::::::::::::: */
3007
3008     case FFESTV_stateWHERE:
3009       ffestc_order_bad_ ();
3010       return FFESTC_orderBAD_;
3011
3012     case FFESTV_stateIF:
3013       ffestc_order_bad_ ();
3014       ffestc_shriek_if_ (FALSE);
3015       return FFESTC_orderBAD_;
3016
3017     default:
3018       ffestc_order_bad_ ();
3019       return FFESTC_orderBAD_;
3020     }
3021 }
3022 /* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
3023
3024    if (ffestc_order_selectcase_() != FFESTC_orderOK_)
3025        return;  */
3026
3027 static ffestcOrder_
3028 ffestc_order_selectcase_ (void)
3029 {
3030   switch (ffestw_state (ffestw_stack_top ()))
3031     {
3032     case FFESTV_stateSELECT0:
3033     case FFESTV_stateSELECT1:
3034       return FFESTC_orderOK_;
3035
3036     case FFESTV_stateWHERE:
3037       ffestc_order_bad_ ();
3038       return FFESTC_orderBAD_;
3039
3040     case FFESTV_stateIF:
3041       ffestc_order_bad_ ();
3042       ffestc_shriek_if_ (FALSE);
3043       return FFESTC_orderBAD_;
3044
3045     default:
3046       ffestc_order_bad_ ();
3047       return FFESTC_orderBAD_;
3048     }
3049 }
3050
3051 /* ffestc_order_sfunc_ -- Check ordering on statement-function definition
3052
3053    if (ffestc_order_sfunc_() != FFESTC_orderOK_)
3054        return;  */
3055
3056 static ffestcOrder_
3057 ffestc_order_sfunc_ (void)
3058 {
3059   recurse:
3060
3061   switch (ffestw_state (ffestw_stack_top ()))
3062     {
3063     case FFESTV_stateNIL:
3064       ffestc_shriek_begin_program_ ();
3065       goto recurse;             /* :::::::::::::::::::: */
3066
3067     case FFESTV_statePROGRAM0:
3068     case FFESTV_statePROGRAM1:
3069     case FFESTV_statePROGRAM2:
3070       ffestw_update (NULL);
3071       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3072       return FFESTC_orderOK_;
3073
3074     case FFESTV_stateSUBROUTINE0:
3075     case FFESTV_stateSUBROUTINE1:
3076     case FFESTV_stateSUBROUTINE2:
3077       ffestw_update (NULL);
3078       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3079       return FFESTC_orderOK_;
3080
3081     case FFESTV_stateFUNCTION0:
3082     case FFESTV_stateFUNCTION1:
3083     case FFESTV_stateFUNCTION2:
3084       ffestw_update (NULL);
3085       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3086       return FFESTC_orderOK_;
3087
3088     case FFESTV_statePROGRAM3:
3089     case FFESTV_stateSUBROUTINE3:
3090     case FFESTV_stateFUNCTION3:
3091       return FFESTC_orderOK_;
3092
3093     case FFESTV_stateUSE:
3094       goto recurse;             /* :::::::::::::::::::: */
3095
3096     case FFESTV_stateWHERE:
3097       ffestc_order_bad_ ();
3098       return FFESTC_orderBAD_;
3099
3100     case FFESTV_stateIF:
3101       ffestc_order_bad_ ();
3102       ffestc_shriek_if_ (FALSE);
3103       return FFESTC_orderBAD_;
3104
3105     default:
3106       ffestc_order_bad_ ();
3107       return FFESTC_orderBAD_;
3108     }
3109 }
3110 /* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
3111
3112    if (ffestc_order_subroutine_() != FFESTC_orderOK_)
3113        return;  */
3114
3115 static ffestcOrder_
3116 ffestc_order_subroutine_ (void)
3117 {
3118   recurse:
3119
3120   switch (ffestw_state (ffestw_stack_top ()))
3121     {
3122     case FFESTV_stateSUBROUTINE0:
3123     case FFESTV_stateSUBROUTINE1:
3124     case FFESTV_stateSUBROUTINE2:
3125     case FFESTV_stateSUBROUTINE3:
3126     case FFESTV_stateSUBROUTINE4:
3127     case FFESTV_stateSUBROUTINE5:
3128       return FFESTC_orderOK_;
3129
3130     case FFESTV_stateUSE:
3131       goto recurse;             /* :::::::::::::::::::: */
3132
3133     case FFESTV_stateWHERE:
3134       ffestc_order_bad_ ();
3135       return FFESTC_orderBAD_;
3136
3137     case FFESTV_stateIF:
3138       ffestc_order_bad_ ();
3139       ffestc_shriek_if_ (FALSE);
3140       return FFESTC_orderBAD_;
3141
3142     default:
3143       ffestc_order_bad_ ();
3144       return FFESTC_orderBAD_;
3145     }
3146 }
3147
3148 /* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
3149
3150    if (ffestc_order_typedecl_() != FFESTC_orderOK_)
3151        return;  */
3152
3153 static ffestcOrder_
3154 ffestc_order_typedecl_ (void)
3155 {
3156   recurse:
3157
3158   switch (ffestw_state (ffestw_stack_top ()))
3159     {
3160     case FFESTV_stateNIL:
3161       ffestc_shriek_begin_program_ ();
3162       goto recurse;             /* :::::::::::::::::::: */
3163
3164     case FFESTV_statePROGRAM0:
3165     case FFESTV_statePROGRAM1:
3166     case FFESTV_statePROGRAM2:
3167       ffestw_update (NULL);
3168       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3169       return FFESTC_orderOK_;
3170
3171     case FFESTV_stateSUBROUTINE0:
3172     case FFESTV_stateSUBROUTINE1:
3173     case FFESTV_stateSUBROUTINE2:
3174       ffestw_update (NULL);
3175       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3176       return FFESTC_orderOK_;
3177
3178     case FFESTV_stateFUNCTION0:
3179     case FFESTV_stateFUNCTION1:
3180     case FFESTV_stateFUNCTION2:
3181       ffestw_update (NULL);
3182       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3183       return FFESTC_orderOK_;
3184
3185     case FFESTV_stateMODULE0:
3186     case FFESTV_stateMODULE1:
3187     case FFESTV_stateMODULE2:
3188       ffestw_update (NULL);
3189       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3190       return FFESTC_orderOK_;
3191
3192     case FFESTV_stateBLOCKDATA0:
3193     case FFESTV_stateBLOCKDATA1:
3194     case FFESTV_stateBLOCKDATA2:
3195       ffestw_update (NULL);
3196       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
3197       return FFESTC_orderOK_;
3198
3199     case FFESTV_statePROGRAM3:
3200     case FFESTV_stateSUBROUTINE3:
3201     case FFESTV_stateFUNCTION3:
3202     case FFESTV_stateMODULE3:
3203     case FFESTV_stateBLOCKDATA3:
3204       return FFESTC_orderOK_;
3205
3206     case FFESTV_stateUSE:
3207       goto recurse;             /* :::::::::::::::::::: */
3208
3209     case FFESTV_stateWHERE:
3210       ffestc_order_bad_ ();
3211       return FFESTC_orderBAD_;
3212
3213     case FFESTV_stateIF:
3214       ffestc_order_bad_ ();
3215       ffestc_shriek_if_ (FALSE);
3216       return FFESTC_orderBAD_;
3217
3218     default:
3219       ffestc_order_bad_ ();
3220       return FFESTC_orderBAD_;
3221     }
3222 }
3223 /* ffestc_order_unit_ -- Check ordering on <unit> statement
3224
3225    if (ffestc_order_unit_() != FFESTC_orderOK_)
3226        return;  */
3227
3228 static ffestcOrder_
3229 ffestc_order_unit_ (void)
3230 {
3231   switch (ffestw_state (ffestw_stack_top ()))
3232     {
3233     case FFESTV_stateNIL:
3234       return FFESTC_orderOK_;
3235
3236     case FFESTV_stateWHERE:
3237       ffestc_order_bad_ ();
3238       return FFESTC_orderBAD_;
3239
3240     case FFESTV_stateIF:
3241       ffestc_order_bad_ ();
3242       ffestc_shriek_if_ (FALSE);
3243       return FFESTC_orderBAD_;
3244
3245     default:
3246       ffestc_order_bad_ ();
3247       return FFESTC_orderBAD_;
3248     }
3249 }
3250 /* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
3251    ENTRY (prior to the first executable statement).  */
3252
3253 static void
3254 ffestc_promote_dummy_ (ffelexToken t)
3255 {
3256   ffesymbol s;
3257   ffesymbolAttrs sa;
3258   ffesymbolAttrs na;
3259   ffebld e;
3260   bool sfref_ok;
3261
3262   assert (t != NULL);
3263
3264   if (ffelex_token_type (t) == FFELEX_typeASTERISK)
3265     {
3266       ffebld_append_item (&ffestc_local_.dummy.list_bottom,
3267                           ffebld_new_star ());
3268       return;                   /* Don't bother with alternate returns! */
3269     }
3270
3271   s = ffesymbol_declare_local (t, FALSE);
3272   sa = ffesymbol_attrs (s);
3273
3274   /* Figure out what kind of object we've got based on previous declarations
3275      of or references to the object. */
3276
3277   sfref_ok = FALSE;
3278
3279   if (sa & FFESYMBOL_attrsANY)
3280     na = sa;
3281   else if (sa & FFESYMBOL_attrsDUMMY)
3282     {
3283       if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
3284         {                       /* Seen this one twice in this list! */
3285           na = FFESYMBOL_attrsetNONE;
3286         }
3287       else
3288         na = sa;
3289       sfref_ok = TRUE;          /* Ok for sym to be ref'd in sfuncdef
3290                                    previously, since already declared as a
3291                                    dummy arg. */
3292     }
3293   else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
3294                     | FFESYMBOL_attrsADJUSTS
3295                     | FFESYMBOL_attrsANY
3296                     | FFESYMBOL_attrsANYLEN
3297                     | FFESYMBOL_attrsANYSIZE
3298                     | FFESYMBOL_attrsARRAY
3299                     | FFESYMBOL_attrsDUMMY
3300                     | FFESYMBOL_attrsEXTERNAL
3301                     | FFESYMBOL_attrsSFARG
3302                     | FFESYMBOL_attrsTYPE)))
3303     na = sa | FFESYMBOL_attrsDUMMY;
3304   else
3305     na = FFESYMBOL_attrsetNONE;
3306
3307   if (!ffesymbol_is_specable (s)
3308       && (!sfref_ok
3309           || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
3310     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
3311
3312   /* Now see what we've got for a new object: NONE means a new error cropped
3313      up; ANY means an old error to be ignored; otherwise, everything's ok,
3314      update the object (symbol) and continue on. */
3315
3316   if (na == FFESYMBOL_attrsetNONE)
3317     ffesymbol_error (s, t);
3318   else if (!(na & FFESYMBOL_attrsANY))
3319     {
3320       ffesymbol_set_attrs (s, na);
3321       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
3322         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
3323       ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
3324       ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
3325       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
3326                              FFEINTRIN_impNONE);
3327       ffebld_set_info (e,
3328                        ffeinfo_new (FFEINFO_basictypeNONE,
3329                                     FFEINFO_kindtypeNONE,
3330                                     0,
3331                                     FFEINFO_kindNONE,
3332                                     FFEINFO_whereNONE,
3333                                     FFETARGET_charactersizeNONE));
3334       ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
3335       ffesymbol_signal_unreported (s);
3336     }
3337 }
3338
3339 /* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
3340
3341    ffestc_promote_execdummy_(t);
3342
3343    Invoked for each token in dummy arg list of ENTRY when the statement
3344    follows the first executable statement.  */
3345
3346 static void
3347 ffestc_promote_execdummy_ (ffelexToken t)
3348 {
3349   ffesymbol s;
3350   ffesymbolAttrs sa;
3351   ffesymbolAttrs na;
3352   ffesymbolState ss;
3353   ffesymbolState ns;
3354   ffeinfoKind kind;
3355   ffeinfoWhere where;
3356   ffebld e;
3357
3358   assert (t != NULL);
3359
3360   if (ffelex_token_type (t) == FFELEX_typeASTERISK)
3361     {
3362       ffebld_append_item (&ffestc_local_.dummy.list_bottom,
3363                           ffebld_new_star ());
3364       return;                   /* Don't bother with alternate returns! */
3365     }
3366
3367   s = ffesymbol_declare_local (t, FALSE);
3368   na = sa = ffesymbol_attrs (s);
3369   ss = ffesymbol_state (s);
3370   kind = ffesymbol_kind (s);
3371   where = ffesymbol_where (s);
3372
3373   if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
3374     {                           /* Seen this one twice in this list! */
3375       na = FFESYMBOL_attrsetNONE;
3376     }
3377
3378   /* Figure out what kind of object we've got based on previous declarations
3379      of or references to the object. */
3380
3381   ns = FFESYMBOL_stateUNDERSTOOD;       /* Assume we know it all know. */
3382
3383   switch (kind)
3384     {
3385     case FFEINFO_kindENTITY:
3386     case FFEINFO_kindFUNCTION:
3387     case FFEINFO_kindSUBROUTINE:
3388       break;                    /* These are fine, as far as we know. */
3389
3390     case FFEINFO_kindNONE:
3391       if (sa & FFESYMBOL_attrsDUMMY)
3392         ns = FFESYMBOL_stateUNCERTAIN;  /* Learned nothing new. */
3393       else if (sa & FFESYMBOL_attrsANYLEN)
3394         {
3395           kind = FFEINFO_kindENTITY;
3396           where = FFEINFO_whereDUMMY;
3397         }
3398       else if (sa & FFESYMBOL_attrsACTUALARG)
3399         na = FFESYMBOL_attrsetNONE;
3400       else
3401         {
3402           na = sa | FFESYMBOL_attrsDUMMY;
3403           ns = FFESYMBOL_stateUNCERTAIN;
3404         }
3405       break;
3406
3407     default:
3408       na = FFESYMBOL_attrsetNONE;       /* Error. */
3409       break;
3410     }
3411
3412   switch (where)
3413     {
3414     case FFEINFO_whereDUMMY:
3415       break;                    /* This is fine. */
3416
3417     case FFEINFO_whereNONE:
3418       where = FFEINFO_whereDUMMY;
3419       break;
3420
3421     default:
3422       na = FFESYMBOL_attrsetNONE;       /* Error. */
3423       break;
3424     }
3425
3426   /* Now see what we've got for a new object: NONE means a new error cropped
3427      up; ANY means an old error to be ignored; otherwise, everything's ok,
3428      update the object (symbol) and continue on. */
3429
3430   if (na == FFESYMBOL_attrsetNONE)
3431     ffesymbol_error (s, t);
3432   else if (!(na & FFESYMBOL_attrsANY))
3433     {
3434       ffesymbol_set_attrs (s, na);
3435       ffesymbol_set_state (s, ns);
3436       ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
3437       ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
3438       if ((ns == FFESYMBOL_stateUNDERSTOOD)
3439           && (kind != FFEINFO_kindSUBROUTINE)
3440           && !ffeimplic_establish_symbol (s))
3441         {
3442           ffesymbol_error (s, t);
3443           return;
3444         }
3445       ffesymbol_set_info (s,
3446                           ffeinfo_new (ffesymbol_basictype (s),
3447                                        ffesymbol_kindtype (s),
3448                                        ffesymbol_rank (s),
3449                                        kind,
3450                                        where,
3451                                        ffesymbol_size (s)));
3452       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
3453                              FFEINTRIN_impNONE);
3454       ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
3455       ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
3456       s = ffecom_sym_learned (s);
3457       ffesymbol_signal_unreported (s);
3458     }
3459 }
3460
3461 /* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
3462
3463    ffestc_promote_sfdummy_(t);
3464
3465    Invoked for each token in dummy arg list of statement function.
3466
3467    22-Oct-91  JCB  1.1
3468       Reject arg if CHARACTER*(*).  */
3469
3470 static void
3471 ffestc_promote_sfdummy_ (ffelexToken t)
3472 {
3473   ffesymbol s;
3474   ffesymbol sp;                 /* Parent symbol. */
3475   ffesymbolAttrs sa;
3476   ffesymbolAttrs na;
3477   ffebld e;
3478
3479   assert (t != NULL);
3480
3481   s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
3482                                            also sets sfa_dummy_parent to
3483                                            parent symbol. */
3484   if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
3485     {
3486       ffesymbol_error (s, t);   /* Dummy already in list. */
3487       return;
3488     }
3489
3490   sp = ffesymbol_sfdummyparent (s);     /* Now flag dummy's parent as used
3491                                            for dummy. */
3492   sa = ffesymbol_attrs (sp);
3493
3494   /* Figure out what kind of object we've got based on previous declarations
3495      of or references to the object. */
3496
3497   if (!ffesymbol_is_specable (sp)
3498       && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
3499           || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
3500               && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
3501               && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
3502               && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
3503     na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
3504   else if (sa & FFESYMBOL_attrsANY)
3505     na = sa;
3506   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
3507                     | FFESYMBOL_attrsCOMMON
3508                     | FFESYMBOL_attrsDUMMY
3509                     | FFESYMBOL_attrsEQUIV
3510                     | FFESYMBOL_attrsINIT
3511                     | FFESYMBOL_attrsNAMELIST
3512                     | FFESYMBOL_attrsRESULT
3513                     | FFESYMBOL_attrsSAVE
3514                     | FFESYMBOL_attrsSFARG
3515                     | FFESYMBOL_attrsTYPE)))
3516     na = sa | FFESYMBOL_attrsSFARG;
3517   else
3518     na = FFESYMBOL_attrsetNONE;
3519
3520   /* Now see what we've got for a new object: NONE means a new error cropped
3521      up; ANY means an old error to be ignored; otherwise, everything's ok,
3522      update the object (symbol) and continue on. */
3523
3524   if (na == FFESYMBOL_attrsetNONE)
3525     {
3526       ffesymbol_error (sp, t);
3527       ffesymbol_set_info (s, ffeinfo_new_any ());
3528     }
3529   else if (!(na & FFESYMBOL_attrsANY))
3530     {
3531       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
3532       ffesymbol_set_attrs (sp, na);
3533       if (!ffeimplic_establish_symbol (sp)
3534           || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
3535               && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
3536         ffesymbol_error (sp, t);
3537       else
3538         ffesymbol_set_info (s,
3539                             ffeinfo_new (ffesymbol_basictype (sp),
3540                                          ffesymbol_kindtype (sp),
3541                                          0,
3542                                          FFEINFO_kindENTITY,
3543                                          FFEINFO_whereDUMMY,
3544                                          ffesymbol_size (sp)));
3545
3546       ffesymbol_signal_unreported (sp);
3547     }
3548
3549   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
3550   ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
3551   ffesymbol_signal_unreported (s);
3552   e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
3553                          FFEINTRIN_impNONE);
3554   ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
3555   ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
3556 }
3557
3558 /* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
3559
3560    ffestc_shriek_begin_program_();
3561
3562    Invoked only when a PROGRAM statement is NOT present at the beginning
3563    of a main program unit.  */
3564
3565 static void
3566 ffestc_shriek_begin_program_ (void)
3567 {
3568   ffestw b;
3569   ffesymbol s;
3570
3571   ffestc_blocknum_ = 0;
3572   b = ffestw_update (ffestw_push (NULL));
3573   ffestw_set_top_do (b, NULL);
3574   ffestw_set_state (b, FFESTV_statePROGRAM0);
3575   ffestw_set_blocknum (b, ffestc_blocknum_++);
3576   ffestw_set_shriek (b, ffestc_shriek_end_program_);
3577   ffestw_set_name (b, NULL);
3578
3579   s = ffesymbol_declare_programunit (NULL,
3580                                  ffelex_token_where_line (ffesta_tokens[0]),
3581                               ffelex_token_where_column (ffesta_tokens[0]));
3582
3583   /* Special case: this is one symbol that won't go through
3584      ffestu_exec_transition_ when the first statement in a main program is
3585      executable, because the transition happens in ffest before ffestc is
3586      reached and triggers the implicit generation of a main program.  So we
3587      do the exec transition for the implicit main program right here, just
3588      for cleanliness' sake (at the very least). */
3589
3590   ffesymbol_set_info (s,
3591                       ffeinfo_new (FFEINFO_basictypeNONE,
3592                                    FFEINFO_kindtypeNONE,
3593                                    0,
3594                                    FFEINFO_kindPROGRAM,
3595                                    FFEINFO_whereLOCAL,
3596                                    FFETARGET_charactersizeNONE));
3597   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
3598
3599   ffesymbol_signal_unreported (s);
3600
3601   ffestd_R1102 (s, NULL);
3602 }
3603
3604 /* ffestc_shriek_blockdata_ -- End a BLOCK DATA
3605
3606    ffestc_shriek_blockdata_(TRUE);  */
3607
3608 static void
3609 ffestc_shriek_blockdata_ (bool ok)
3610 {
3611   if (!ffesta_seen_first_exec)
3612     {
3613       ffesta_seen_first_exec = TRUE;
3614       ffestd_exec_begin ();
3615     }
3616
3617   ffestd_R1112 (ok);
3618
3619   ffestd_exec_end ();
3620
3621   if (ffestw_name (ffestw_stack_top ()) != NULL)
3622     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
3623   ffestw_kill (ffestw_pop ());
3624
3625   ffe_terminate_2 ();
3626   ffe_init_2 ();
3627 }
3628
3629 /* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
3630
3631    ffestc_shriek_do_(TRUE);
3632
3633    Also invoked by _labeldef_branch_end_ (or, in cases
3634    of errors, other _labeldef_ functions) when the label definition is
3635    for a DO-target (LOOPEND) label, once per matching/outstanding DO
3636    block on the stack.  These cases invoke this function with ok==TRUE, so
3637    only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE.  */
3638
3639 static void
3640 ffestc_shriek_do_ (bool ok)
3641 {
3642   ffelab l;
3643
3644   if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
3645       && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
3646     {                           /* DO target is label that is still
3647                                    undefined. */
3648       assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
3649               || (ffelab_type (l) == FFELAB_typeANY));
3650       if (ffelab_type (l) != FFELAB_typeANY)
3651         {
3652           ffelab_set_definition_line (l,
3653                                       ffewhere_line_use (ffelab_doref_line (l)));
3654           ffelab_set_definition_column (l,
3655                                         ffewhere_column_use (ffelab_doref_column (l)));
3656           ffestv_num_label_defines_++;
3657         }
3658       ffestd_labeldef_branch (l);
3659     }
3660
3661   ffestd_do (ok);
3662
3663   if (ffestw_name (ffestw_stack_top ()) != NULL)
3664     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
3665   if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
3666     ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
3667   if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
3668     ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
3669   ffestw_kill (ffestw_pop ());
3670 }
3671
3672 /* ffestc_shriek_end_program_ -- End a PROGRAM
3673
3674    ffestc_shriek_end_program_();  */
3675
3676 static void
3677 ffestc_shriek_end_program_ (bool ok)
3678 {
3679   if (!ffesta_seen_first_exec)
3680     {
3681       ffesta_seen_first_exec = TRUE;
3682       ffestd_exec_begin ();
3683     }
3684
3685   ffestd_R1103 (ok);
3686
3687   ffestd_exec_end ();
3688
3689   if (ffestw_name (ffestw_stack_top ()) != NULL)
3690     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
3691   ffestw_kill (ffestw_pop ());
3692
3693   ffe_terminate_2 ();
3694   ffe_init_2 ();
3695 }
3696
3697 /* ffestc_shriek_function_ -- End a FUNCTION
3698
3699    ffestc_shriek_function_(TRUE);  */
3700
3701 static void
3702 ffestc_shriek_function_ (bool ok)
3703 {
3704   if (!ffesta_seen_first_exec)
3705     {
3706       ffesta_seen_first_exec = TRUE;
3707       ffestd_exec_begin ();
3708     }
3709
3710   ffestd_R1221 (ok);
3711
3712   ffestd_exec_end ();
3713
3714   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
3715   ffestw_kill (ffestw_pop ());
3716   ffesta_is_entry_valid = FALSE;
3717
3718   switch (ffestw_state (ffestw_stack_top ()))
3719     {
3720     case FFESTV_stateNIL:
3721       ffe_terminate_2 ();
3722       ffe_init_2 ();
3723       break;
3724
3725     default:
3726       ffe_terminate_3 ();
3727       ffe_init_3 ();
3728       break;
3729
3730     case FFESTV_stateINTERFACE0:
3731       ffe_terminate_4 ();
3732       ffe_init_4 ();
3733       break;
3734     }
3735 }
3736
3737 /* ffestc_shriek_if_ -- End of statement following logical IF
3738
3739    ffestc_shriek_if_(TRUE);
3740
3741    Applies ONLY to logical IF, not to IF-THEN.  For example, does not
3742    ffelex_token_kill the construct name for an IF-THEN block (the name
3743    field is invalid for logical IF).  ok==TRUE iff statement following
3744    logical IF (substatement) is valid; else, statement is invalid or
3745    stack forcibly popped due to ffestc_eof().  */
3746
3747 static void
3748 ffestc_shriek_if_ (bool ok)
3749 {
3750   ffestd_end_R807 (ok);
3751
3752   ffestw_kill (ffestw_pop ());
3753   ffestc_shriek_after1_ = NULL;
3754
3755   ffestc_try_shriek_do_ ();
3756 }
3757
3758 /* ffestc_shriek_ifthen_ -- End an IF-THEN
3759
3760    ffestc_shriek_ifthen_(TRUE);  */
3761
3762 static void
3763 ffestc_shriek_ifthen_ (bool ok)
3764 {
3765   ffestd_R806 (ok);
3766
3767   if (ffestw_name (ffestw_stack_top ()) != NULL)
3768     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
3769   ffestw_kill (ffestw_pop ());
3770
3771   ffestc_try_shriek_do_ ();
3772 }
3773
3774 /* ffestc_shriek_select_ -- End a SELECT
3775
3776    ffestc_shriek_select_(TRUE);  */
3777
3778 static void
3779 ffestc_shriek_select_ (bool ok)
3780 {
3781   ffestwSelect s;
3782   ffestwCase c;
3783
3784   ffestd_R811 (ok);
3785
3786   if (ffestw_name (ffestw_stack_top ()) != NULL)
3787     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
3788   s = ffestw_select (ffestw_stack_top ());
3789   ffelex_token_kill (s->t);
3790   for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
3791     ffelex_token_kill (c->t);
3792   malloc_pool_kill (s->pool);
3793
3794   ffestw_kill (ffestw_pop ());
3795
3796   ffestc_try_shriek_do_ ();
3797 }
3798
3799 /* ffestc_shriek_subroutine_ -- End a SUBROUTINE
3800
3801    ffestc_shriek_subroutine_(TRUE);  */
3802
3803 static void
3804 ffestc_shriek_subroutine_ (bool ok)
3805 {
3806   if (!ffesta_seen_first_exec)
3807     {
3808       ffesta_seen_first_exec = TRUE;
3809       ffestd_exec_begin ();
3810     }
3811
3812   ffestd_R1225 (ok);
3813
3814   ffestd_exec_end ();
3815
3816   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
3817   ffestw_kill (ffestw_pop ());
3818   ffesta_is_entry_valid = FALSE;
3819
3820   switch (ffestw_state (ffestw_stack_top ()))
3821     {
3822     case FFESTV_stateNIL:
3823       ffe_terminate_2 ();
3824       ffe_init_2 ();
3825       break;
3826
3827     default:
3828       ffe_terminate_3 ();
3829       ffe_init_3 ();
3830       break;
3831
3832     case FFESTV_stateINTERFACE0:
3833       ffe_terminate_4 ();
3834       ffe_init_4 ();
3835       break;
3836     }
3837 }
3838
3839 /* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
3840
3841    i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
3842
3843    search_list contains search_list_size char *'s, spec is checked to see
3844    if it is a char constant and, if so, is binary-searched against the list.
3845    0 is returned if not found, else the "classic" index (beginning with 1)
3846    is returned.  Before returning 0 where the search was performed but
3847    fruitless, if "etc" is a non-NULL char *, an error message is displayed
3848    using "etc" as the pick-one-of-these string.  */
3849
3850 static int
3851 ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
3852                       const char *whine)
3853 {
3854   int lowest_tested;
3855   int highest_tested;
3856   int halfway;
3857   int offset;
3858   int c;
3859   const char *str;
3860   int len;
3861
3862   if (size == 0)
3863     return 0;                   /* Nobody should pass size == 0, but for
3864                                    elegance.... */
3865
3866   lowest_tested = -1;
3867   highest_tested = size;
3868   halfway = size >> 1;
3869
3870   list += halfway;
3871
3872   c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
3873   if (c == 2)
3874     return 0;
3875   c = -c;                       /* Sigh.  */
3876
3877 next:                           /* :::::::::::::::::::: */
3878   switch (c)
3879     {
3880     case -1:
3881       offset = (halfway - lowest_tested) >> 1;
3882       if (offset == 0)
3883         goto nope;              /* :::::::::::::::::::: */
3884       highest_tested = halfway;
3885       list -= offset;
3886       halfway -= offset;
3887       c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
3888       goto next;                /* :::::::::::::::::::: */
3889
3890     case 0:
3891       return halfway + 1;
3892
3893     case 1:
3894       offset = (highest_tested - halfway) >> 1;
3895       if (offset == 0)
3896         goto nope;              /* :::::::::::::::::::: */
3897       lowest_tested = halfway;
3898       list += offset;
3899       halfway += offset;
3900       c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
3901       goto next;                /* :::::::::::::::::::: */
3902
3903     default:
3904       assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
3905       break;
3906     }
3907
3908 nope:                           /* :::::::::::::::::::: */
3909   ffebad_start (FFEBAD_SPEC_VALUE);
3910   ffebad_here (0, ffelex_token_where_line (spec->value),
3911                ffelex_token_where_column (spec->value));
3912   ffebad_string (whine);
3913   ffebad_finish ();
3914   return 0;
3915 }
3916
3917 /* ffestc_subr_format_ -- Return summary of format specifier
3918
3919    ffestc_subr_format_(&specifier);  */
3920
3921 static ffestvFormat
3922 ffestc_subr_format_ (ffestpFile *spec)
3923 {
3924   if (!spec->kw_or_val_present)
3925     return FFESTV_formatNONE;
3926   assert (spec->value_present);
3927   if (spec->value_is_label)
3928     return FFESTV_formatLABEL;  /* Ok if not a label. */
3929
3930   assert (spec->value != NULL);
3931   if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
3932     return FFESTV_formatASTERISK;
3933
3934   if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
3935     return FFESTV_formatNAMELIST;
3936
3937   if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
3938     return FFESTV_formatCHAREXPR;       /* F77 C5. */
3939
3940   switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
3941     {
3942     case FFEINFO_basictypeINTEGER:
3943       return FFESTV_formatINTEXPR;
3944
3945     case FFEINFO_basictypeCHARACTER:
3946       return FFESTV_formatCHAREXPR;
3947
3948     case FFEINFO_basictypeANY:
3949       return FFESTV_formatASTERISK;
3950
3951     default:
3952       assert ("bad basictype" == NULL);
3953       return FFESTV_formatINTEXPR;
3954     }
3955 }
3956
3957 /* ffestc_subr_is_branch_ -- Handle specifier as branch target label
3958
3959    ffestc_subr_is_branch_(&specifier);  */
3960
3961 static bool
3962 ffestc_subr_is_branch_ (ffestpFile *spec)
3963 {
3964   if (!spec->kw_or_val_present)
3965     return TRUE;
3966   assert (spec->value_present);
3967   assert (spec->value_is_label);
3968   spec->value_is_label++;       /* For checking purposes only; 1=>2. */
3969   return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
3970 }
3971
3972 /* ffestc_subr_is_format_ -- Handle specifier as format target label
3973
3974    ffestc_subr_is_format_(&specifier);  */
3975
3976 static bool
3977 ffestc_subr_is_format_ (ffestpFile *spec)
3978 {
3979   if (!spec->kw_or_val_present)
3980     return TRUE;
3981   assert (spec->value_present);
3982   if (!spec->value_is_label)
3983     return TRUE;                /* Ok if not a label. */
3984
3985   spec->value_is_label++;       /* For checking purposes only; 1=>2. */
3986   return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
3987 }
3988
3989 /* ffestc_subr_is_present_ -- Ensure specifier is present, else error
3990
3991    ffestc_subr_is_present_("SPECIFIER",&specifier);  */
3992
3993 static bool
3994 ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
3995 {
3996   if (spec->kw_or_val_present)
3997     {
3998       assert (spec->value_present);
3999       return TRUE;
4000     }
4001
4002   ffebad_start (FFEBAD_MISSING_SPECIFIER);
4003   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
4004                ffelex_token_where_column (ffesta_tokens[0]));
4005   ffebad_string (name);
4006   ffebad_finish ();
4007   return FALSE;
4008 }
4009
4010 /* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
4011
4012    if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
4013        // specifier value is present and is a char constant "CONSTANT"
4014
4015    Like strcmp, except the return values are defined as: -1 returned in place
4016    of strcmp's generic negative value, 1 in place of it's generic positive
4017    value, and 2 when there is no character constant string to compare.  Also,
4018    a case-insensitive comparison is performed, where string is assumed to
4019    already be in InitialCaps form.
4020
4021    If a non-NULL pointer is provided as the char **target, then *target is
4022    written with NULL if 2 is returned, a pointer to the constant string
4023    value of the specifier otherwise.  Similarly, length is written with
4024    0 if 2 is returned, the length of the constant string value otherwise.  */
4025
4026 static int
4027 ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
4028                       int *length)
4029 {
4030   ffebldConstant c;
4031   int i;
4032
4033   if (!spec->kw_or_val_present || !spec->value_present
4034       || (spec->u.expr == NULL)
4035       || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
4036     {
4037       if (target != NULL)
4038         *target = NULL;
4039       if (length != NULL)
4040         *length = 0;
4041       return 2;
4042     }
4043
4044   if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
4045       != FFEBLD_constCHARACTERDEFAULT)
4046     {
4047       if (target != NULL)
4048         *target = NULL;
4049       if (length != NULL)
4050         *length = 0;
4051       return 2;
4052     }
4053
4054   if (target != NULL)
4055     *target = ffebld_constant_characterdefault (c).text;
4056   if (length != NULL)
4057     *length = ffebld_constant_characterdefault (c).length;
4058
4059   i = ffesrc_strcmp_1ns2i (ffe_case_match (),
4060                            ffebld_constant_characterdefault (c).text,
4061                            ffebld_constant_characterdefault (c).length,
4062                            string);
4063   if (i == 0)
4064     return 0;
4065   if (i > 0)
4066     return -1;                  /* Yes indeed, we reverse the strings to
4067                                    _strcmpin_.   */
4068   return 1;
4069 }
4070
4071 /* ffestc_subr_unit_ -- Return summary of unit specifier
4072
4073    ffestc_subr_unit_(&specifier);  */
4074
4075 static ffestvUnit
4076 ffestc_subr_unit_ (ffestpFile *spec)
4077 {
4078   if (!spec->kw_or_val_present)
4079     return FFESTV_unitNONE;
4080   assert (spec->value_present);
4081   assert (spec->value != NULL);
4082
4083   if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
4084     return FFESTV_unitASTERISK;
4085
4086   switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
4087     {
4088     case FFEINFO_basictypeINTEGER:
4089       return FFESTV_unitINTEXPR;
4090
4091     case FFEINFO_basictypeCHARACTER:
4092       return FFESTV_unitCHAREXPR;
4093
4094     case FFEINFO_basictypeANY:
4095       return FFESTV_unitASTERISK;
4096
4097     default:
4098       assert ("bad basictype" == NULL);
4099       return FFESTV_unitINTEXPR;
4100     }
4101 }
4102
4103 /* Call this function whenever it's possible that one or more top
4104    stack items are label-targeting DO blocks that have had their
4105    labels defined, but at a time when they weren't at the top of the
4106    stack.  This prevents uninformative diagnostics for programs
4107    like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END".  */
4108
4109 static void
4110 ffestc_try_shriek_do_ (void)
4111 {
4112   ffelab lab;
4113   ffelabType ty;
4114
4115   while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
4116          && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
4117          && (((ty = (ffelab_type (lab)))
4118               == FFELAB_typeANY)
4119              || (ty == FFELAB_typeUSELESS)
4120              || (ty == FFELAB_typeFORMAT)
4121              || (ty == FFELAB_typeNOTLOOP)
4122              || (ty == FFELAB_typeENDIF)))
4123     ffestc_shriek_do_ (FALSE);
4124 }
4125
4126 /* ffestc_decl_start -- R426 or R501
4127
4128    ffestc_decl_start(...);
4129
4130    Verify that R426 component-def-stmt or R501 type-declaration-stmt are
4131    valid here, figure out which one, and implement.  */
4132
4133 void
4134 ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
4135                    ffelexToken kindt, ffebld len, ffelexToken lent)
4136 {
4137   switch (ffestw_state (ffestw_stack_top ()))
4138     {
4139     case FFESTV_stateNIL:
4140     case FFESTV_statePROGRAM0:
4141     case FFESTV_stateSUBROUTINE0:
4142     case FFESTV_stateFUNCTION0:
4143     case FFESTV_stateMODULE0:
4144     case FFESTV_stateBLOCKDATA0:
4145     case FFESTV_statePROGRAM1:
4146     case FFESTV_stateSUBROUTINE1:
4147     case FFESTV_stateFUNCTION1:
4148     case FFESTV_stateMODULE1:
4149     case FFESTV_stateBLOCKDATA1:
4150     case FFESTV_statePROGRAM2:
4151     case FFESTV_stateSUBROUTINE2:
4152     case FFESTV_stateFUNCTION2:
4153     case FFESTV_stateMODULE2:
4154     case FFESTV_stateBLOCKDATA2:
4155     case FFESTV_statePROGRAM3:
4156     case FFESTV_stateSUBROUTINE3:
4157     case FFESTV_stateFUNCTION3:
4158     case FFESTV_stateMODULE3:
4159     case FFESTV_stateBLOCKDATA3:
4160     case FFESTV_stateUSE:
4161       ffestc_local_.decl.is_R426 = 2;
4162       break;
4163
4164     case FFESTV_stateTYPE:
4165     case FFESTV_stateSTRUCTURE:
4166     case FFESTV_stateMAP:
4167       ffestc_local_.decl.is_R426 = 1;
4168       break;
4169
4170     default:
4171       ffestc_order_bad_ ();
4172       ffestc_labeldef_useless_ ();
4173       ffestc_local_.decl.is_R426 = 0;
4174       return;
4175     }
4176
4177   switch (ffestc_local_.decl.is_R426)
4178     {
4179     case 2:
4180       ffestc_R501_start (type, typet, kind, kindt, len, lent);
4181       break;
4182
4183     default:
4184       ffestc_labeldef_useless_ ();
4185       break;
4186     }
4187 }
4188
4189 /* ffestc_decl_attrib -- R426 or R501 type attribute
4190
4191    ffestc_decl_attrib(...);
4192
4193    Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
4194    is valid here and implement.  */
4195
4196 void
4197 ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
4198                     ffelexToken attribt UNUSED,
4199                     ffestrOther intent_kw UNUSED,
4200                     ffesttDimList dims UNUSED)
4201 {
4202   ffebad_start (FFEBAD_F90);
4203   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
4204                ffelex_token_where_column (ffesta_tokens[0]));
4205   ffebad_finish ();
4206   return;
4207 }
4208
4209 /* ffestc_decl_item -- R426 or R501
4210
4211    ffestc_decl_item(...);
4212
4213    Establish type for a particular object.  */
4214
4215 void
4216 ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
4217               ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
4218                   ffelexToken initt, bool clist)
4219 {
4220   switch (ffestc_local_.decl.is_R426)
4221     {
4222     case 2:
4223       ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
4224                         clist);
4225       break;
4226
4227     default:
4228       break;
4229     }
4230 }
4231
4232 /* ffestc_decl_itemstartvals -- R426 or R501 start list of values
4233
4234    ffestc_decl_itemstartvals();
4235
4236    Gonna specify values for the object now.  */
4237
4238 void
4239 ffestc_decl_itemstartvals (void)
4240 {
4241   switch (ffestc_local_.decl.is_R426)
4242     {
4243     case 2:
4244       ffestc_R501_itemstartvals ();
4245       break;
4246
4247     default:
4248       break;
4249     }
4250 }
4251
4252 /* ffestc_decl_itemvalue -- R426 or R501 source value
4253
4254    ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
4255
4256    Make sure repeat and value are valid for the object being initialized.  */
4257
4258 void
4259 ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
4260                        ffebld value, ffelexToken value_token)
4261 {
4262   switch (ffestc_local_.decl.is_R426)
4263     {
4264     case 2:
4265       ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
4266       break;
4267
4268     default:
4269       break;
4270     }
4271 }
4272
4273 /* ffestc_decl_itemendvals -- R426 or R501 end list of values
4274
4275    ffelexToken t;  // the SLASH token that ends the list.
4276    ffestc_decl_itemendvals(t);
4277
4278    No more values, might specify more objects now.  */
4279
4280 void
4281 ffestc_decl_itemendvals (ffelexToken t)
4282 {
4283   switch (ffestc_local_.decl.is_R426)
4284     {
4285     case 2:
4286       ffestc_R501_itemendvals (t);
4287       break;
4288
4289     default:
4290       break;
4291     }
4292 }
4293
4294 /* ffestc_decl_finish -- R426 or R501
4295
4296    ffestc_decl_finish();
4297
4298    Just wrap up any local activities.  */
4299
4300 void
4301 ffestc_decl_finish (void)
4302 {
4303   switch (ffestc_local_.decl.is_R426)
4304     {
4305     case 2:
4306       ffestc_R501_finish ();
4307       break;
4308
4309     default:
4310       break;
4311     }
4312 }
4313
4314 /* ffestc_elsewhere -- Generic ELSE WHERE statement
4315
4316    ffestc_end();
4317
4318    Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant.  */
4319
4320 void
4321 ffestc_elsewhere (ffelexToken where)
4322 {
4323   switch (ffestw_state (ffestw_stack_top ()))
4324     {
4325     case FFESTV_stateIFTHEN:
4326       ffestc_R805 (where);
4327       break;
4328
4329     default:
4330       break;
4331     }
4332 }
4333
4334 /* ffestc_end -- Generic END statement
4335
4336    ffestc_end();
4337
4338    Make sure a generic END is valid in the current context, and implement
4339    it.  */
4340
4341 void
4342 ffestc_end (void)
4343 {
4344   ffestw b;
4345
4346   b = ffestw_stack_top ();
4347
4348 recurse:
4349
4350   switch (ffestw_state (b))
4351     {
4352     case FFESTV_stateBLOCKDATA0:
4353     case FFESTV_stateBLOCKDATA1:
4354     case FFESTV_stateBLOCKDATA2:
4355     case FFESTV_stateBLOCKDATA3:
4356     case FFESTV_stateBLOCKDATA4:
4357     case FFESTV_stateBLOCKDATA5:
4358       ffestc_R1112 (NULL);
4359       break;
4360
4361     case FFESTV_stateFUNCTION0:
4362     case FFESTV_stateFUNCTION1:
4363     case FFESTV_stateFUNCTION2:
4364     case FFESTV_stateFUNCTION3:
4365     case FFESTV_stateFUNCTION4:
4366     case FFESTV_stateFUNCTION5:
4367       if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
4368           && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
4369         {
4370           ffebad_start (FFEBAD_END_WO);
4371           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
4372                        ffelex_token_where_column (ffesta_tokens[0]));
4373           ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
4374           ffebad_string ("FUNCTION");
4375           ffebad_finish ();
4376         }
4377       ffestc_R1221 (NULL);
4378       break;
4379
4380     case FFESTV_stateMODULE0:
4381     case FFESTV_stateMODULE1:
4382     case FFESTV_stateMODULE2:
4383     case FFESTV_stateMODULE3:
4384     case FFESTV_stateMODULE4:
4385     case FFESTV_stateMODULE5:
4386       break;
4387
4388     case FFESTV_stateSUBROUTINE0:
4389     case FFESTV_stateSUBROUTINE1:
4390     case FFESTV_stateSUBROUTINE2:
4391     case FFESTV_stateSUBROUTINE3:
4392     case FFESTV_stateSUBROUTINE4:
4393     case FFESTV_stateSUBROUTINE5:
4394       if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
4395           && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
4396         {
4397           ffebad_start (FFEBAD_END_WO);
4398           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
4399                        ffelex_token_where_column (ffesta_tokens[0]));
4400           ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
4401           ffebad_string ("SUBROUTINE");
4402           ffebad_finish ();
4403         }
4404       ffestc_R1225 (NULL);
4405       break;
4406
4407     case FFESTV_stateUSE:
4408       b = ffestw_previous (ffestw_stack_top ());
4409       goto recurse;             /* :::::::::::::::::::: */
4410
4411     default:
4412       ffestc_R1103 (NULL);
4413       break;
4414     }
4415 }
4416
4417 /* ffestc_eof -- Generic EOF
4418
4419    ffestc_eof();
4420
4421    Make sure we're at state NIL, or issue an error message and use each
4422    block's shriek function to clean up to state NIL.  */
4423
4424 void
4425 ffestc_eof (void)
4426 {
4427   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
4428     {
4429       ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
4430       ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
4431       ffebad_finish ();
4432       do
4433         (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
4434       while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
4435     }
4436 }
4437
4438 /* ffestc_exec_transition -- Check if ok and move stmt state to executable
4439
4440    if (ffestc_exec_transition())
4441        // Transition successful (kind of like a CONTINUE stmt was seen).
4442
4443    If the current statement state is a non-nested specification state in
4444    which, say, a CONTINUE statement would be valid, then enter the state
4445    we'd be in after seeing CONTINUE (without, of course, generating any
4446    CONTINUE code), call ffestd_exec_begin, and return TRUE.  Otherwise
4447    return FALSE.
4448
4449    This function cannot be invoked once the first executable statement
4450    is seen.  This function may choose to always return TRUE by shrieking
4451    away any interceding state stack entries to reach the base level of
4452    specification state, but right now it doesn't, and it is (or should
4453    be) purely an issue of how one wishes errors to be handled (for example,
4454    an unrecognized statement in the middle of a STRUCTURE construct: after
4455    the error message, should subsequent statements still be interpreted as
4456    being within the construct, or should the construct be terminated upon
4457    seeing the unrecognized statement?  we do the former at the moment).  */
4458
4459 bool
4460 ffestc_exec_transition (void)
4461 {
4462   bool update;
4463
4464 recurse:
4465
4466   switch (ffestw_state (ffestw_stack_top ()))
4467     {
4468     case FFESTV_stateNIL:
4469       ffestc_shriek_begin_program_ ();
4470       goto recurse;             /* :::::::::::::::::::: */
4471
4472     case FFESTV_statePROGRAM0:
4473     case FFESTV_stateSUBROUTINE0:
4474     case FFESTV_stateFUNCTION0:
4475     case FFESTV_stateBLOCKDATA0:
4476       ffestw_state (ffestw_stack_top ()) += 4;  /* To state UNIT4. */
4477       update = TRUE;
4478       break;
4479
4480     case FFESTV_statePROGRAM1:
4481     case FFESTV_stateSUBROUTINE1:
4482     case FFESTV_stateFUNCTION1:
4483     case FFESTV_stateBLOCKDATA1:
4484       ffestw_state (ffestw_stack_top ()) += 3;  /* To state UNIT4. */
4485       update = TRUE;
4486       break;
4487
4488     case FFESTV_statePROGRAM2:
4489     case FFESTV_stateSUBROUTINE2:
4490     case FFESTV_stateFUNCTION2:
4491     case FFESTV_stateBLOCKDATA2:
4492       ffestw_state (ffestw_stack_top ()) += 2;  /* To state UNIT4. */
4493       update = TRUE;
4494       break;
4495
4496     case FFESTV_statePROGRAM3:
4497     case FFESTV_stateSUBROUTINE3:
4498     case FFESTV_stateFUNCTION3:
4499     case FFESTV_stateBLOCKDATA3:
4500       ffestw_state (ffestw_stack_top ()) += 1;  /* To state UNIT4. */
4501       update = TRUE;
4502       break;
4503
4504     case FFESTV_stateUSE:
4505       goto recurse;             /* :::::::::::::::::::: */
4506
4507     default:
4508       return FALSE;
4509     }
4510
4511   if (update)
4512     ffestw_update (NULL);       /* Update state line/col info. */
4513
4514   ffesta_seen_first_exec = TRUE;
4515   ffestd_exec_begin ();
4516
4517   return TRUE;
4518 }
4519
4520 /* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
4521
4522    ffesymbol s;
4523    // call ffebad_start first, of course.
4524    ffestc_ffebad_here_doiter(0,s);
4525    // call ffebad_finish afterwards, naturally.
4526
4527    Searches the stack of blocks backwards for a DO loop that has s
4528    as its iteration variable, then calls ffebad_here with pointers to
4529    that particular reference to the variable.  Crashes if the DO loop
4530    can't be found.  */
4531
4532 void
4533 ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
4534 {
4535   ffestw block;
4536
4537   for (block = ffestw_top_do (ffestw_stack_top ());
4538        (block != NULL) && (ffestw_blocknum (block) != 0);
4539        block = ffestw_top_do (ffestw_previous (block)))
4540     {
4541       if (ffestw_do_iter_var (block) == s)
4542         {
4543           ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
4544                   ffelex_token_where_column (ffestw_do_iter_var_t (block)));
4545           return;
4546         }
4547     }
4548   assert ("no do block found" == NULL);
4549 }
4550
4551 /* ffestc_is_decl_not_R1219 -- Context information for FFESTB
4552
4553    if (ffestc_is_decl_not_R1219()) ...
4554
4555    When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
4556    is seen, call this function.  It returns TRUE if the statement's context
4557    is such that it is a declaration of an object named
4558    "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
4559    if the statement's context is such that it begins the definition of a
4560    function named "name" havin the dummy argument list "name-list" (this
4561    is the R1219 function-stmt case).  */
4562
4563 bool
4564 ffestc_is_decl_not_R1219 (void)
4565 {
4566   switch (ffestw_state (ffestw_stack_top ()))
4567     {
4568     case FFESTV_stateNIL:
4569     case FFESTV_statePROGRAM5:
4570     case FFESTV_stateSUBROUTINE5:
4571     case FFESTV_stateFUNCTION5:
4572     case FFESTV_stateMODULE5:
4573     case FFESTV_stateINTERFACE0:
4574       return FALSE;
4575
4576     default:
4577       return TRUE;
4578     }
4579 }
4580
4581 /* ffestc_is_entry_in_subr -- Context information for FFESTB
4582
4583    if (ffestc_is_entry_in_subr()) ...
4584
4585    When a statement with the form "ENTRY name(name-list)"
4586    is seen, call this function.  It returns TRUE if the statement's context
4587    is such that it may have "*", meaning alternate return, in place of
4588    names in the name list (i.e. if the ENTRY is in a subroutine context).
4589    It also returns TRUE if the ENTRY is not in a function context (invalid
4590    but prevents extra complaints about "*", if present).  It returns FALSE
4591    if the ENTRY is in a function context.  */
4592
4593 bool
4594 ffestc_is_entry_in_subr (void)
4595 {
4596   ffestvState s;
4597
4598   s = ffestw_state (ffestw_stack_top ());
4599
4600 recurse:
4601
4602   switch (s)
4603     {
4604     case FFESTV_stateFUNCTION0:
4605     case FFESTV_stateFUNCTION1:
4606     case FFESTV_stateFUNCTION2:
4607     case FFESTV_stateFUNCTION3:
4608     case FFESTV_stateFUNCTION4:
4609       return FALSE;
4610
4611     case FFESTV_stateUSE:
4612       s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
4613       goto recurse;             /* :::::::::::::::::::: */
4614
4615     default:
4616       return TRUE;
4617     }
4618 }
4619
4620 /* ffestc_is_let_not_V027 -- Context information for FFESTB
4621
4622    if (ffestc_is_let_not_V027()) ...
4623
4624    When a statement with the form "PARAMETERname=expr"
4625    is seen, call this function.  It returns TRUE if the statement's context
4626    is such that it is an assignment to an object named "PARAMETERname", FALSE
4627    if the statement's context is such that it is a V-extension PARAMETER
4628    statement that is like a PARAMETER(name=expr) statement except that the
4629    type of name is determined by the type of expr, not the implicit or
4630    explicit typing of name.  */
4631
4632 bool
4633 ffestc_is_let_not_V027 (void)
4634 {
4635   switch (ffestw_state (ffestw_stack_top ()))
4636     {
4637     case FFESTV_statePROGRAM4:
4638     case FFESTV_stateSUBROUTINE4:
4639     case FFESTV_stateFUNCTION4:
4640     case FFESTV_stateWHERETHEN:
4641     case FFESTV_stateIFTHEN:
4642     case FFESTV_stateDO:
4643     case FFESTV_stateSELECT0:
4644     case FFESTV_stateSELECT1:
4645     case FFESTV_stateWHERE:
4646     case FFESTV_stateIF:
4647       return TRUE;
4648
4649     default:
4650       return FALSE;
4651     }
4652 }
4653
4654 /* ffestc_terminate_4 -- Terminate ffestc after scoping unit
4655
4656    ffestc_terminate_4();
4657
4658    For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
4659    defs, and statement function defs.  */
4660
4661 void
4662 ffestc_terminate_4 (void)
4663 {
4664   ffestc_entry_num_ = ffestc_saved_entry_num_;
4665 }
4666
4667 /* ffestc_R501_start -- type-declaration-stmt
4668
4669    ffestc_R501_start(...);
4670
4671    Verify that R501 type-declaration-stmt is
4672    valid here and implement.  */
4673
4674 void
4675 ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
4676                    ffelexToken kindt, ffebld len, ffelexToken lent)
4677 {
4678   ffestc_check_start_ ();
4679   if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
4680     {
4681       ffestc_local_.decl.is_R426 = 0;
4682       return;
4683     }
4684   ffestc_labeldef_useless_ ();
4685
4686   ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
4687 }
4688
4689 /* ffestc_R501_attrib -- type attribute
4690
4691    ffestc_R501_attrib(...);
4692
4693    Verify that R501 type-declaration-stmt attribute
4694    is valid here and implement.  */
4695
4696 void
4697 ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
4698                     ffestrOther intent_kw UNUSED,
4699                     ffesttDimList dims UNUSED)
4700 {
4701   ffestc_check_attrib_ ();
4702
4703   switch (attrib)
4704     {
4705     case FFESTP_attribDIMENSION:
4706       ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4707       break;
4708
4709     case FFESTP_attribEXTERNAL:
4710       break;
4711
4712     case FFESTP_attribINTRINSIC:
4713       break;
4714
4715     case FFESTP_attribPARAMETER:
4716       break;
4717
4718     case FFESTP_attribSAVE:
4719       switch (ffestv_save_state_)
4720         {
4721         case FFESTV_savestateNONE:
4722           ffestv_save_state_ = FFESTV_savestateSPECIFIC;
4723           ffestv_save_line_
4724             = ffewhere_line_use (ffelex_token_where_line (attribt));
4725           ffestv_save_col_
4726             = ffewhere_column_use (ffelex_token_where_column (attribt));
4727           break;
4728
4729         case FFESTV_savestateSPECIFIC:
4730         case FFESTV_savestateANY:
4731           break;
4732
4733         case FFESTV_savestateALL:
4734           if (ffe_is_pedantic ())
4735             {
4736               ffebad_start (FFEBAD_CONFLICTING_SAVES);
4737               ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
4738               ffebad_here (1, ffelex_token_where_line (attribt),
4739                            ffelex_token_where_column (attribt));
4740               ffebad_finish ();
4741             }
4742           ffestv_save_state_ = FFESTV_savestateANY;
4743           break;
4744
4745         default:
4746           assert ("unexpected save state" == NULL);
4747           break;
4748         }
4749       break;
4750
4751     default:
4752       assert ("unexpected attribute" == NULL);
4753       break;
4754     }
4755 }
4756
4757 /* ffestc_R501_item -- declared object
4758
4759    ffestc_R501_item(...);
4760
4761    Establish type for a particular object.  */
4762
4763 void
4764 ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
4765                   ffesttDimList dims, ffebld len, ffelexToken lent,
4766                   ffebld init, ffelexToken initt, bool clist)
4767 {
4768   ffesymbol s;
4769   ffesymbol sfn;                /* FUNCTION symbol. */
4770   ffebld array_size;
4771   ffebld extents;
4772   ffesymbolAttrs sa;
4773   ffesymbolAttrs na;
4774   ffestpDimtype nd;
4775   bool is_init = (init != NULL) || clist;
4776   bool is_assumed;
4777   bool is_ugly_assumed;
4778   ffeinfoRank rank;
4779
4780   ffestc_check_item_ ();
4781   assert (name != NULL);
4782   assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
4783   assert (kind == NULL);        /* No way an expression should get here. */
4784
4785   ffestc_establish_declinfo_ (kind, kindt, len, lent);
4786
4787   is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
4788     && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
4789
4790   if ((dims != NULL) || is_init)
4791     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4792
4793   s = ffesymbol_declare_local (name, TRUE);
4794   sa = ffesymbol_attrs (s);
4795
4796   /* First figure out what kind of object this is based solely on the current
4797      object situation (type params, dimension list, and initialization). */
4798
4799   na = FFESYMBOL_attrsTYPE;
4800
4801   if (is_assumed)
4802     na |= FFESYMBOL_attrsANYLEN;
4803
4804   is_ugly_assumed = (ffe_is_ugly_assumed ()
4805                      && ((sa & FFESYMBOL_attrsDUMMY)
4806                          || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
4807
4808   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
4809   switch (nd)
4810     {
4811     case FFESTP_dimtypeNONE:
4812       break;
4813
4814     case FFESTP_dimtypeKNOWN:
4815       na |= FFESYMBOL_attrsARRAY;
4816       break;
4817
4818     case FFESTP_dimtypeADJUSTABLE:
4819       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
4820       break;
4821
4822     case FFESTP_dimtypeASSUMED:
4823       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
4824       break;
4825
4826     case FFESTP_dimtypeADJUSTABLEASSUMED:
4827       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
4828         | FFESYMBOL_attrsANYSIZE;
4829       break;
4830
4831     default:
4832       assert ("unexpected dimtype" == NULL);
4833       na = FFESYMBOL_attrsetNONE;
4834       break;
4835     }
4836
4837   if (!ffesta_is_entry_valid
4838       && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
4839            == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
4840     na = FFESYMBOL_attrsetNONE;
4841
4842   if (is_init)
4843     {
4844       if (na == FFESYMBOL_attrsetNONE)
4845         ;
4846       else if (na & (FFESYMBOL_attrsANYLEN
4847                      | FFESYMBOL_attrsADJUSTABLE
4848                      | FFESYMBOL_attrsANYSIZE))
4849         na = FFESYMBOL_attrsetNONE;
4850       else
4851         na |= FFESYMBOL_attrsINIT;
4852     }
4853
4854   /* Now figure out what kind of object we've got based on previous
4855      declarations of or references to the object. */
4856
4857   if (na == FFESYMBOL_attrsetNONE)
4858     ;
4859   else if (!ffesymbol_is_specable (s)
4860            && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
4861                 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
4862                || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
4863     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
4864                                    dimension/init UNDERSTOODs. */
4865   else if (sa & FFESYMBOL_attrsANY)
4866     na = sa;
4867   else if ((sa & na)
4868            || ((sa & (FFESYMBOL_attrsSFARG
4869                       | FFESYMBOL_attrsADJUSTS))
4870                && (na & (FFESYMBOL_attrsARRAY
4871                          | FFESYMBOL_attrsANYLEN)))
4872            || ((sa & FFESYMBOL_attrsRESULT)
4873                && (na & (FFESYMBOL_attrsARRAY
4874                          | FFESYMBOL_attrsINIT)))
4875            || ((sa & (FFESYMBOL_attrsSFUNC
4876                       | FFESYMBOL_attrsEXTERNAL
4877                       | FFESYMBOL_attrsINTRINSIC
4878                       | FFESYMBOL_attrsINIT))
4879                && (na & (FFESYMBOL_attrsARRAY
4880                          | FFESYMBOL_attrsANYLEN
4881                          | FFESYMBOL_attrsINIT)))
4882            || ((sa & FFESYMBOL_attrsARRAY)
4883                && !ffesta_is_entry_valid
4884                && (na & FFESYMBOL_attrsANYLEN))
4885            || ((sa & (FFESYMBOL_attrsADJUSTABLE
4886                       | FFESYMBOL_attrsANYLEN
4887                       | FFESYMBOL_attrsANYSIZE
4888                       | FFESYMBOL_attrsDUMMY))
4889                && (na & FFESYMBOL_attrsINIT))
4890            || ((sa & (FFESYMBOL_attrsSAVE
4891                       | FFESYMBOL_attrsNAMELIST
4892                       | FFESYMBOL_attrsCOMMON
4893                       | FFESYMBOL_attrsEQUIV))
4894                && (na & (FFESYMBOL_attrsADJUSTABLE
4895                          | FFESYMBOL_attrsANYLEN
4896                          | FFESYMBOL_attrsANYSIZE))))
4897     na = FFESYMBOL_attrsetNONE;
4898   else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
4899            && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
4900            && (na & FFESYMBOL_attrsANYLEN))
4901     {                           /* If CHARACTER*(*) FOO after PARAMETER FOO. */
4902       na |= FFESYMBOL_attrsTYPE;
4903       ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
4904     }
4905   else
4906     na |= sa;
4907
4908   /* Now see what we've got for a new object: NONE means a new error cropped
4909      up; ANY means an old error to be ignored; otherwise, everything's ok,
4910      update the object (symbol) and continue on. */
4911
4912   if (na == FFESYMBOL_attrsetNONE)
4913     {
4914       ffesymbol_error (s, name);
4915       ffestc_parent_ok_ = FALSE;
4916     }
4917   else if (na & FFESYMBOL_attrsANY)
4918     ffestc_parent_ok_ = FALSE;
4919   else
4920     {
4921       ffesymbol_set_attrs (s, na);
4922       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
4923         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
4924       rank = ffesymbol_rank (s);
4925       if (dims != NULL)
4926         {
4927           ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
4928                                                          &array_size,
4929                                                          &extents,
4930                                                          is_ugly_assumed));
4931           ffesymbol_set_arraysize (s, array_size);
4932           ffesymbol_set_extents (s, extents);
4933           if (!(0 && ffe_is_90 ())
4934               && (ffebld_op (array_size) == FFEBLD_opCONTER)
4935               && (ffebld_constant_integerdefault (ffebld_conter (array_size))
4936                   == 0))
4937             {
4938               ffebad_start (FFEBAD_ZERO_ARRAY);
4939               ffebad_here (0, ffelex_token_where_line (name),
4940                            ffelex_token_where_column (name));
4941               ffebad_finish ();
4942             }
4943         }
4944       if (init != NULL)
4945         {
4946           ffesymbol_set_init (s,
4947                               ffeexpr_convert (init, initt, name,
4948                                                ffestc_local_.decl.basic_type,
4949                                                ffestc_local_.decl.kind_type,
4950                                                rank,
4951                                                ffestc_local_.decl.size,
4952                                                FFEEXPR_contextDATA));
4953           ffecom_notify_init_symbol (s);
4954           ffesymbol_update_init (s);
4955 #if FFEGLOBAL_ENABLED
4956           if (ffesymbol_common (s) != NULL)
4957             ffeglobal_init_common (ffesymbol_common (s), initt);
4958 #endif
4959         }
4960       else if (clist)
4961         {
4962           ffebld symter;
4963
4964           symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
4965                                       FFEINTRIN_specNONE,
4966                                       FFEINTRIN_impNONE);
4967
4968           ffebld_set_info (symter,
4969                            ffeinfo_new (ffestc_local_.decl.basic_type,
4970                                         ffestc_local_.decl.kind_type,
4971                                         rank,
4972                                         FFEINFO_kindNONE,
4973                                         FFEINFO_whereNONE,
4974                                         ffestc_local_.decl.size));
4975           ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
4976         }
4977       if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
4978         {
4979           ffesymbol_set_info (s,
4980                               ffeinfo_new (ffestc_local_.decl.basic_type,
4981                                            ffestc_local_.decl.kind_type,
4982                                            rank,
4983                                            ffesymbol_kind (s),
4984                                            ffesymbol_where (s),
4985                                            ffestc_local_.decl.size));
4986           if ((na & FFESYMBOL_attrsRESULT)
4987               && ((sfn = ffesymbol_funcresult (s)) != NULL))
4988             {
4989               ffesymbol_set_info (sfn,
4990                                   ffeinfo_new (ffestc_local_.decl.basic_type,
4991                                                ffestc_local_.decl.kind_type,
4992                                                rank,
4993                                                ffesymbol_kind (sfn),
4994                                                ffesymbol_where (sfn),
4995                                                ffestc_local_.decl.size));
4996               ffesymbol_signal_unreported (sfn);
4997             }
4998         }
4999       else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
5000                || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
5001                || ((ffestc_local_.decl.basic_type
5002                     == FFEINFO_basictypeCHARACTER)
5003                    && (ffestc_local_.decl.size != ffesymbol_size (s))))
5004         {                       /* Explicit type disagrees with established
5005                                    implicit type. */
5006           ffesymbol_error (s, name);
5007         }
5008
5009       if ((na & FFESYMBOL_attrsADJUSTS)
5010           && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
5011               || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
5012         ffesymbol_error (s, name);
5013
5014       ffesymbol_signal_unreported (s);
5015       ffestc_parent_ok_ = TRUE;
5016     }
5017 }
5018
5019 /* ffestc_R501_itemstartvals -- Start list of values
5020
5021    ffestc_R501_itemstartvals();
5022
5023    Gonna specify values for the object now.  */
5024
5025 void
5026 ffestc_R501_itemstartvals (void)
5027 {
5028   ffestc_check_item_startvals_ ();
5029
5030   if (ffestc_parent_ok_)
5031     ffedata_begin (ffestc_local_.decl.initlist);
5032 }
5033
5034 /* ffestc_R501_itemvalue -- Source value
5035
5036    ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
5037
5038    Make sure repeat and value are valid for the object being initialized.  */
5039
5040 void
5041 ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
5042                        ffebld value, ffelexToken value_token)
5043 {
5044   ffetargetIntegerDefault rpt;
5045
5046   ffestc_check_item_value_ ();
5047
5048   if (!ffestc_parent_ok_)
5049     return;
5050
5051   if (repeat == NULL)
5052     rpt = 1;
5053   else if (ffebld_op (repeat) == FFEBLD_opCONTER)
5054     rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
5055   else
5056     {
5057       ffestc_parent_ok_ = FALSE;
5058       ffedata_end (TRUE, NULL);
5059       return;
5060     }
5061
5062   if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
5063                       (repeat_token == NULL) ? value_token : repeat_token)))
5064     ffedata_end (TRUE, NULL);
5065 }
5066
5067 /* ffestc_R501_itemendvals -- End list of values
5068
5069    ffelexToken t;  // the SLASH token that ends the list.
5070    ffestc_R501_itemendvals(t);
5071
5072    No more values, might specify more objects now.  */
5073
5074 void
5075 ffestc_R501_itemendvals (ffelexToken t)
5076 {
5077   ffestc_check_item_endvals_ ();
5078
5079   if (ffestc_parent_ok_)
5080     ffestc_parent_ok_ = ffedata_end (FALSE, t);
5081
5082   if (ffestc_parent_ok_)
5083     ffesymbol_signal_unreported (ffebld_symter (ffebld_head
5084                                              (ffestc_local_.decl.initlist)));
5085 }
5086
5087 /* ffestc_R501_finish -- Done
5088
5089    ffestc_R501_finish();
5090
5091    Just wrap up any local activities.  */
5092
5093 void
5094 ffestc_R501_finish (void)
5095 {
5096   ffestc_check_finish_ ();
5097 }
5098
5099 /* ffestc_R522 -- SAVE statement with no list
5100
5101    ffestc_R522();
5102
5103    Verify that SAVE is valid here, and flag everything as SAVEd.  */
5104
5105 void
5106 ffestc_R522 (void)
5107 {
5108   ffestc_check_simple_ ();
5109   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
5110     return;
5111   ffestc_labeldef_useless_ ();
5112
5113   switch (ffestv_save_state_)
5114     {
5115     case FFESTV_savestateNONE:
5116       ffestv_save_state_ = FFESTV_savestateALL;
5117       ffestv_save_line_
5118         = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
5119       ffestv_save_col_
5120         = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
5121       break;
5122
5123     case FFESTV_savestateANY:
5124       break;
5125
5126     case FFESTV_savestateSPECIFIC:
5127     case FFESTV_savestateALL:
5128       if (ffe_is_pedantic ())
5129         {
5130           ffebad_start (FFEBAD_CONFLICTING_SAVES);
5131           ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
5132           ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
5133                        ffelex_token_where_column (ffesta_tokens[0]));
5134           ffebad_finish ();
5135         }
5136       ffestv_save_state_ = FFESTV_savestateALL;
5137       break;
5138
5139     default:
5140       assert ("unexpected save state" == NULL);
5141       break;
5142     }
5143
5144   ffe_set_is_saveall (TRUE);
5145
5146   ffestd_R522 ();
5147 }
5148
5149 /* ffestc_R522start -- SAVE statement list begin
5150
5151    ffestc_R522start();
5152
5153    Verify that SAVE is valid here, and begin accepting items in the list.  */
5154
5155 void
5156 ffestc_R522start (void)
5157 {
5158   ffestc_check_start_ ();
5159   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
5160     {
5161       ffestc_ok_ = FALSE;
5162       return;
5163     }
5164   ffestc_labeldef_useless_ ();
5165
5166   switch (ffestv_save_state_)
5167     {
5168     case FFESTV_savestateNONE:
5169       ffestv_save_state_ = FFESTV_savestateSPECIFIC;
5170       ffestv_save_line_
5171         = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
5172       ffestv_save_col_
5173         = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
5174       break;
5175
5176     case FFESTV_savestateSPECIFIC:
5177     case FFESTV_savestateANY:
5178       break;
5179
5180     case FFESTV_savestateALL:
5181       if (ffe_is_pedantic ())
5182         {
5183           ffebad_start (FFEBAD_CONFLICTING_SAVES);
5184           ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
5185           ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
5186                        ffelex_token_where_column (ffesta_tokens[0]));
5187           ffebad_finish ();
5188         }
5189       ffestv_save_state_ = FFESTV_savestateANY;
5190       break;
5191
5192     default:
5193       assert ("unexpected save state" == NULL);
5194       break;
5195     }
5196
5197   ffestd_R522start ();
5198
5199   ffestc_ok_ = TRUE;
5200 }
5201
5202 /* ffestc_R522item_object -- SAVE statement for object-name
5203
5204    ffestc_R522item_object(name_token);
5205
5206    Make sure name_token identifies a valid object to be SAVEd.  */
5207
5208 void
5209 ffestc_R522item_object (ffelexToken name)
5210 {
5211   ffesymbol s;
5212   ffesymbolAttrs sa;
5213   ffesymbolAttrs na;
5214
5215   ffestc_check_item_ ();
5216   assert (name != NULL);
5217   if (!ffestc_ok_)
5218     return;
5219
5220   s = ffesymbol_declare_local (name, FALSE);
5221   sa = ffesymbol_attrs (s);
5222
5223   /* Figure out what kind of object we've got based on previous declarations
5224      of or references to the object. */
5225
5226   if (!ffesymbol_is_specable (s)
5227       && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
5228           || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
5229     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
5230   else if (sa & FFESYMBOL_attrsANY)
5231     na = sa;
5232   else if (!(sa & ~(FFESYMBOL_attrsARRAY
5233                     | FFESYMBOL_attrsEQUIV
5234                     | FFESYMBOL_attrsINIT
5235                     | FFESYMBOL_attrsNAMELIST
5236                     | FFESYMBOL_attrsSFARG
5237                     | FFESYMBOL_attrsTYPE)))
5238     na = sa | FFESYMBOL_attrsSAVE;
5239   else
5240     na = FFESYMBOL_attrsetNONE;
5241
5242   /* Now see what we've got for a new object: NONE means a new error cropped
5243      up; ANY means an old error to be ignored; otherwise, everything's ok,
5244      update the object (symbol) and continue on. */
5245
5246   if (na == FFESYMBOL_attrsetNONE)
5247     ffesymbol_error (s, name);
5248   else if (!(na & FFESYMBOL_attrsANY))
5249     {
5250       ffesymbol_set_attrs (s, na);
5251       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
5252         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
5253       ffesymbol_update_save (s);
5254       ffesymbol_signal_unreported (s);
5255     }
5256
5257   ffestd_R522item_object (name);
5258 }
5259
5260 /* ffestc_R522item_cblock -- SAVE statement for common-block-name
5261
5262    ffestc_R522item_cblock(name_token);
5263
5264    Make sure name_token identifies a valid common block to be SAVEd.  */
5265
5266 void
5267 ffestc_R522item_cblock (ffelexToken name)
5268 {
5269   ffesymbol s;
5270   ffesymbolAttrs sa;
5271   ffesymbolAttrs na;
5272
5273   ffestc_check_item_ ();
5274   assert (name != NULL);
5275   if (!ffestc_ok_)
5276     return;
5277
5278   s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
5279                               ffelex_token_where_column (ffesta_tokens[0]));
5280   sa = ffesymbol_attrs (s);
5281
5282   /* Figure out what kind of object we've got based on previous declarations
5283      of or references to the object. */
5284
5285   if (!ffesymbol_is_specable (s))
5286     na = FFESYMBOL_attrsetNONE;
5287   else if (sa & FFESYMBOL_attrsANY)
5288     na = sa;                    /* Already have an error here, say nothing. */
5289   else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
5290     na = sa | FFESYMBOL_attrsSAVECBLOCK;
5291   else
5292     na = FFESYMBOL_attrsetNONE;
5293
5294   /* Now see what we've got for a new object: NONE means a new error cropped
5295      up; ANY means an old error to be ignored; otherwise, everything's ok,
5296      update the object (symbol) and continue on. */
5297
5298   if (na == FFESYMBOL_attrsetNONE)
5299     ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
5300   else if (!(na & FFESYMBOL_attrsANY))
5301     {
5302       ffesymbol_set_attrs (s, na);
5303       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
5304       ffesymbol_update_save (s);
5305       ffesymbol_signal_unreported (s);
5306     }
5307
5308   ffestd_R522item_cblock (name);
5309 }
5310
5311 /* ffestc_R522finish -- SAVE statement list complete
5312
5313    ffestc_R522finish();
5314
5315    Just wrap up any local activities.  */
5316
5317 void
5318 ffestc_R522finish (void)
5319 {
5320   ffestc_check_finish_ ();
5321   if (!ffestc_ok_)
5322     return;
5323
5324   ffestd_R522finish ();
5325 }
5326
5327 /* ffestc_R524_start -- DIMENSION statement list begin
5328
5329    ffestc_R524_start(bool virtual);
5330
5331    Verify that DIMENSION is valid here, and begin accepting items in the
5332    list.  */
5333
5334 void
5335 ffestc_R524_start (bool virtual)
5336 {
5337   ffestc_check_start_ ();
5338   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
5339     {
5340       ffestc_ok_ = FALSE;
5341       return;
5342     }
5343   ffestc_labeldef_useless_ ();
5344
5345   ffestd_R524_start (virtual);
5346
5347   ffestc_ok_ = TRUE;
5348 }
5349
5350 /* ffestc_R524_item -- DIMENSION statement for object-name
5351
5352    ffestc_R524_item(name_token,dim_list);
5353
5354    Make sure name_token identifies a valid object to be DIMENSIONd.  */
5355
5356 void
5357 ffestc_R524_item (ffelexToken name, ffesttDimList dims)
5358 {
5359   ffesymbol s;
5360   ffebld array_size;
5361   ffebld extents;
5362   ffesymbolAttrs sa;
5363   ffesymbolAttrs na;
5364   ffestpDimtype nd;
5365   ffeinfoRank rank;
5366   bool is_ugly_assumed;
5367
5368   ffestc_check_item_ ();
5369   assert (name != NULL);
5370   assert (dims != NULL);
5371   if (!ffestc_ok_)
5372     return;
5373
5374   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5375
5376   s = ffesymbol_declare_local (name, FALSE);
5377   sa = ffesymbol_attrs (s);
5378
5379   /* First figure out what kind of object this is based solely on the current
5380      object situation (dimension list). */
5381
5382   is_ugly_assumed = (ffe_is_ugly_assumed ()
5383                      && ((sa & FFESYMBOL_attrsDUMMY)
5384                          || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
5385
5386   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
5387   switch (nd)
5388     {
5389     case FFESTP_dimtypeKNOWN:
5390       na = FFESYMBOL_attrsARRAY;
5391       break;
5392
5393     case FFESTP_dimtypeADJUSTABLE:
5394       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
5395       break;
5396
5397     case FFESTP_dimtypeASSUMED:
5398       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
5399       break;
5400
5401     case FFESTP_dimtypeADJUSTABLEASSUMED:
5402       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
5403         | FFESYMBOL_attrsANYSIZE;
5404       break;
5405
5406     default:
5407       assert ("Unexpected dims type" == NULL);
5408       na = FFESYMBOL_attrsetNONE;
5409       break;
5410     }
5411
5412   /* Now figure out what kind of object we've got based on previous
5413      declarations of or references to the object. */
5414
5415   if (!ffesymbol_is_specable (s))
5416     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
5417   else if (sa & FFESYMBOL_attrsANY)
5418     na = FFESYMBOL_attrsANY;
5419   else if (!ffesta_is_entry_valid
5420            && (sa & FFESYMBOL_attrsANYLEN))
5421     na = FFESYMBOL_attrsetNONE;
5422   else if ((sa & FFESYMBOL_attrsARRAY)
5423            || ((sa & (FFESYMBOL_attrsCOMMON
5424                       | FFESYMBOL_attrsEQUIV
5425                       | FFESYMBOL_attrsNAMELIST
5426                       | FFESYMBOL_attrsSAVE))
5427                && (na & (FFESYMBOL_attrsADJUSTABLE
5428                          | FFESYMBOL_attrsANYSIZE))))
5429     na = FFESYMBOL_attrsetNONE;
5430   else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
5431                     | FFESYMBOL_attrsANYLEN
5432                     | FFESYMBOL_attrsANYSIZE
5433                     | FFESYMBOL_attrsCOMMON
5434                     | FFESYMBOL_attrsDUMMY
5435                     | FFESYMBOL_attrsEQUIV
5436                     | FFESYMBOL_attrsNAMELIST
5437                     | FFESYMBOL_attrsSAVE
5438                     | FFESYMBOL_attrsTYPE)))
5439     na |= sa;
5440   else
5441     na = FFESYMBOL_attrsetNONE;
5442
5443   /* Now see what we've got for a new object: NONE means a new error cropped
5444      up; ANY means an old error to be ignored; otherwise, everything's ok,
5445      update the object (symbol) and continue on. */
5446
5447   if (na == FFESYMBOL_attrsetNONE)
5448     ffesymbol_error (s, name);
5449   else if (!(na & FFESYMBOL_attrsANY))
5450     {
5451       ffesymbol_set_attrs (s, na);
5452       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
5453       ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
5454                                                      &array_size,
5455                                                      &extents,
5456                                                      is_ugly_assumed));
5457       ffesymbol_set_arraysize (s, array_size);
5458       ffesymbol_set_extents (s, extents);
5459       if (!(0 && ffe_is_90 ())
5460           && (ffebld_op (array_size) == FFEBLD_opCONTER)
5461           && (ffebld_constant_integerdefault (ffebld_conter (array_size))
5462               == 0))
5463         {
5464           ffebad_start (FFEBAD_ZERO_ARRAY);
5465           ffebad_here (0, ffelex_token_where_line (name),
5466                        ffelex_token_where_column (name));
5467           ffebad_finish ();
5468         }
5469       ffesymbol_set_info (s,
5470                           ffeinfo_new (ffesymbol_basictype (s),
5471                                        ffesymbol_kindtype (s),
5472                                        rank,
5473                                        ffesymbol_kind (s),
5474                                        ffesymbol_where (s),
5475                                        ffesymbol_size (s)));
5476     }
5477
5478   ffesymbol_signal_unreported (s);
5479
5480   ffestd_R524_item (name, dims);
5481 }
5482
5483 /* ffestc_R524_finish -- DIMENSION statement list complete
5484
5485    ffestc_R524_finish();
5486
5487    Just wrap up any local activities.  */
5488
5489 void
5490 ffestc_R524_finish (void)
5491 {
5492   ffestc_check_finish_ ();
5493   if (!ffestc_ok_)
5494     return;
5495
5496   ffestd_R524_finish ();
5497 }
5498
5499 /* ffestc_R528_start -- DATA statement list begin
5500
5501    ffestc_R528_start();
5502
5503    Verify that DATA is valid here, and begin accepting items in the list.  */
5504
5505 void
5506 ffestc_R528_start (void)
5507 {
5508   ffestcOrder_ order;
5509
5510   ffestc_check_start_ ();
5511   if (ffe_is_pedantic_not_90 ())
5512     order = ffestc_order_data77_ ();
5513   else
5514     order = ffestc_order_data_ ();
5515   if (order != FFESTC_orderOK_)
5516     {
5517       ffestc_ok_ = FALSE;
5518       return;
5519     }
5520   ffestc_labeldef_useless_ ();
5521
5522   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5523
5524 #if 1
5525   ffestc_local_.data.objlist = NULL;
5526 #else
5527   ffestd_R528_start_ ();
5528 #endif
5529
5530   ffestc_ok_ = TRUE;
5531 }
5532
5533 /* ffestc_R528_item_object -- DATA statement target object
5534
5535    ffestc_R528_item_object(object,object_token);
5536
5537    Make sure object is valid to be DATAd.  */
5538
5539 void
5540 ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
5541 {
5542   ffestc_check_item_ ();
5543   if (!ffestc_ok_)
5544     return;
5545
5546 #if 1
5547   if (ffestc_local_.data.objlist == NULL)
5548     ffebld_init_list (&ffestc_local_.data.objlist,
5549                       &ffestc_local_.data.list_bottom);
5550
5551   ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
5552 #else
5553   ffestd_R528_item_object_ (expr, expr_token);
5554 #endif
5555 }
5556
5557 /* ffestc_R528_item_startvals -- DATA statement start list of values
5558
5559    ffestc_R528_item_startvals();
5560
5561    No more objects, gonna specify values for the list of objects now.  */
5562
5563 void
5564 ffestc_R528_item_startvals (void)
5565 {
5566   ffestc_check_item_startvals_ ();
5567   if (!ffestc_ok_)
5568     return;
5569
5570 #if 1
5571   assert (ffestc_local_.data.objlist != NULL);
5572   ffebld_end_list (&ffestc_local_.data.list_bottom);
5573   ffedata_begin (ffestc_local_.data.objlist);
5574 #else
5575   ffestd_R528_item_startvals_ ();
5576 #endif
5577 }
5578
5579 /* ffestc_R528_item_value -- DATA statement source value
5580
5581    ffestc_R528_item_value(repeat,repeat_token,value,value_token);
5582
5583    Make sure repeat and value are valid for the objects being initialized.  */
5584
5585 void
5586 ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
5587                         ffebld value, ffelexToken value_token)
5588 {
5589   ffetargetIntegerDefault rpt;
5590
5591   ffestc_check_item_value_ ();
5592   if (!ffestc_ok_)
5593     return;
5594
5595 #if 1
5596   if (repeat == NULL)
5597     rpt = 1;
5598   else if (ffebld_op (repeat) == FFEBLD_opCONTER)
5599     rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
5600   else
5601     {
5602       ffestc_ok_ = FALSE;
5603       ffedata_end (TRUE, NULL);
5604       return;
5605     }
5606
5607   if (!(ffestc_ok_ = ffedata_value (rpt, value,
5608                                     (repeat_token == NULL)
5609                                     ? value_token
5610                                     : repeat_token)))
5611     ffedata_end (TRUE, NULL);
5612
5613 #else
5614   ffestd_R528_item_value_ (repeat, value);
5615 #endif
5616 }
5617
5618 /* ffestc_R528_item_endvals -- DATA statement start list of values
5619
5620    ffelexToken t;  // the SLASH token that ends the list.
5621    ffestc_R528_item_endvals(t);
5622
5623    No more values, might specify more objects now.  */
5624
5625 void
5626 ffestc_R528_item_endvals (ffelexToken t)
5627 {
5628   ffestc_check_item_endvals_ ();
5629   if (!ffestc_ok_)
5630     return;
5631
5632 #if 1
5633   ffedata_end (!ffestc_ok_, t);
5634   ffestc_local_.data.objlist = NULL;
5635 #else
5636   ffestd_R528_item_endvals_ (t);
5637 #endif
5638 }
5639
5640 /* ffestc_R528_finish -- DATA statement list complete
5641
5642    ffestc_R528_finish();
5643
5644    Just wrap up any local activities.  */
5645
5646 void
5647 ffestc_R528_finish (void)
5648 {
5649   ffestc_check_finish_ ();
5650
5651 #if 1
5652 #else
5653   ffestd_R528_finish_ ();
5654 #endif
5655 }
5656
5657 /* ffestc_R537_start -- PARAMETER statement list begin
5658
5659    ffestc_R537_start();
5660
5661    Verify that PARAMETER is valid here, and begin accepting items in the
5662    list.  */
5663
5664 void
5665 ffestc_R537_start (void)
5666 {
5667   ffestc_check_start_ ();
5668   if (ffestc_order_parameter_ () != FFESTC_orderOK_)
5669     {
5670       ffestc_ok_ = FALSE;
5671       return;
5672     }
5673   ffestc_labeldef_useless_ ();
5674
5675   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5676
5677   ffestd_R537_start ();
5678
5679   ffestc_ok_ = TRUE;
5680 }
5681
5682 /* ffestc_R537_item -- PARAMETER statement assignment
5683
5684    ffestc_R537_item(dest,dest_token,source,source_token);
5685
5686    Make sure the source is a valid source for the destination; make the
5687    assignment.  */
5688
5689 void
5690 ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
5691                   ffelexToken source_token)
5692 {
5693   ffesymbol s;
5694
5695   ffestc_check_item_ ();
5696   if (!ffestc_ok_)
5697     return;
5698
5699   if ((ffebld_op (dest) == FFEBLD_opANY)
5700       || (ffebld_op (source) == FFEBLD_opANY))
5701     {
5702       if (ffebld_op (dest) == FFEBLD_opSYMTER)
5703         {
5704           s = ffebld_symter (dest);
5705           ffesymbol_set_init (s, ffebld_new_any ());
5706           ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
5707           ffesymbol_signal_unreported (s);
5708         }
5709       ffestd_R537_item (dest, source);
5710       return;
5711     }
5712
5713   assert (ffebld_op (dest) == FFEBLD_opSYMTER);
5714   assert (ffebld_op (source) == FFEBLD_opCONTER);
5715
5716   s = ffebld_symter (dest);
5717   if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
5718       && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
5719     {                           /* Destination has explicit/implicit
5720                                    CHARACTER*(*) type; set length. */
5721       ffesymbol_set_info (s,
5722                           ffeinfo_new (ffesymbol_basictype (s),
5723                                        ffesymbol_kindtype (s),
5724                                        0,
5725                                        ffesymbol_kind (s),
5726                                        ffesymbol_where (s),
5727                                        ffebld_size (source)));
5728       ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
5729     }
5730
5731   source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
5732                                  FFEEXPR_contextDATA);
5733
5734   ffesymbol_set_init (s, source);
5735
5736   ffesymbol_signal_unreported (s);
5737
5738   ffestd_R537_item (dest, source);
5739 }
5740
5741 /* ffestc_R537_finish -- PARAMETER statement list complete
5742
5743    ffestc_R537_finish();
5744
5745    Just wrap up any local activities.  */
5746
5747 void
5748 ffestc_R537_finish (void)
5749 {
5750   ffestc_check_finish_ ();
5751   if (!ffestc_ok_)
5752     return;
5753
5754   ffestd_R537_finish ();
5755 }
5756
5757 /* ffestc_R539 -- IMPLICIT NONE statement
5758
5759    ffestc_R539();
5760
5761    Verify that the IMPLICIT NONE statement is ok here and implement.  */
5762
5763 void
5764 ffestc_R539 (void)
5765 {
5766   ffestc_check_simple_ ();
5767   if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
5768     return;
5769   ffestc_labeldef_useless_ ();
5770
5771   ffeimplic_none ();
5772
5773   ffestd_R539 ();
5774 }
5775
5776 /* ffestc_R539start -- IMPLICIT statement
5777
5778    ffestc_R539start();
5779
5780    Verify that the IMPLICIT statement is ok here and implement.  */
5781
5782 void
5783 ffestc_R539start (void)
5784 {
5785   ffestc_check_start_ ();
5786   if (ffestc_order_implicit_ () != FFESTC_orderOK_)
5787     {
5788       ffestc_ok_ = FALSE;
5789       return;
5790     }
5791   ffestc_labeldef_useless_ ();
5792
5793   ffestd_R539start ();
5794
5795   ffestc_ok_ = TRUE;
5796 }
5797
5798 /* ffestc_R539item -- IMPLICIT statement specification (R540)
5799
5800    ffestc_R539item(...);
5801
5802    Verify that the type and letter list are all ok and implement.  */
5803
5804 void
5805 ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
5806                  ffebld len, ffelexToken lent, ffesttImpList letters)
5807 {
5808   ffestc_check_item_ ();
5809   if (!ffestc_ok_)
5810     return;
5811
5812   if ((type == FFESTP_typeCHARACTER) && (len != NULL)
5813       && (ffebld_op (len) == FFEBLD_opSTAR))
5814     {                           /* Complain and pretend they're CHARACTER
5815                                    [*1]. */
5816       ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
5817       ffebad_here (0, ffelex_token_where_line (lent),
5818                    ffelex_token_where_column (lent));
5819       ffebad_finish ();
5820       len = NULL;
5821       lent = NULL;
5822     }
5823   ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
5824   ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
5825
5826   ffestt_implist_drive (letters, ffestc_establish_impletter_);
5827
5828   ffestd_R539item (type, kind, kindt, len, lent, letters);
5829 }
5830
5831 /* ffestc_R539finish -- IMPLICIT statement
5832
5833    ffestc_R539finish();
5834
5835    Finish up any local activities.  */
5836
5837 void
5838 ffestc_R539finish (void)
5839 {
5840   ffestc_check_finish_ ();
5841   if (!ffestc_ok_)
5842     return;
5843
5844   ffestd_R539finish ();
5845 }
5846
5847 /* ffestc_R542_start -- NAMELIST statement list begin
5848
5849    ffestc_R542_start();
5850
5851    Verify that NAMELIST is valid here, and begin accepting items in the
5852    list.  */
5853
5854 void
5855 ffestc_R542_start (void)
5856 {
5857   ffestc_check_start_ ();
5858   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
5859     {
5860       ffestc_ok_ = FALSE;
5861       return;
5862     }
5863   ffestc_labeldef_useless_ ();
5864
5865   if (ffe_is_f2c_library ()
5866       && (ffe_case_source () == FFE_caseNONE))
5867     {
5868       ffebad_start (FFEBAD_NAMELIST_CASE);
5869       ffesta_ffebad_here_current_stmt (0);
5870       ffebad_finish ();
5871     }
5872
5873   ffestd_R542_start ();
5874
5875   ffestc_local_.namelist.symbol = NULL;
5876
5877   ffestc_ok_ = TRUE;
5878 }
5879
5880 /* ffestc_R542_item_nlist -- NAMELIST statement for group-name
5881
5882    ffestc_R542_item_nlist(groupname_token);
5883
5884    Make sure name_token identifies a valid object to be NAMELISTd.  */
5885
5886 void
5887 ffestc_R542_item_nlist (ffelexToken name)
5888 {
5889   ffesymbol s;
5890
5891   ffestc_check_item_ ();
5892   assert (name != NULL);
5893   if (!ffestc_ok_)
5894     return;
5895
5896   if (ffestc_local_.namelist.symbol != NULL)
5897     ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
5898
5899   s = ffesymbol_declare_local (name, FALSE);
5900
5901   if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
5902       || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
5903           && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
5904     {
5905       ffestc_parent_ok_ = TRUE;
5906       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
5907         {
5908           ffebld_init_list (ffesymbol_ptr_to_namelist (s),
5909                             ffesymbol_ptr_to_listbottom (s));
5910           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
5911           ffesymbol_set_info (s,
5912                               ffeinfo_new (FFEINFO_basictypeNONE,
5913                                            FFEINFO_kindtypeNONE,
5914                                            0,
5915                                            FFEINFO_kindNAMELIST,
5916                                            FFEINFO_whereLOCAL,
5917                                            FFETARGET_charactersizeNONE));
5918         }
5919     }
5920   else
5921     {
5922       if (ffesymbol_kind (s) != FFEINFO_kindANY)
5923         ffesymbol_error (s, name);
5924       ffestc_parent_ok_ = FALSE;
5925     }
5926
5927   ffestc_local_.namelist.symbol = s;
5928
5929   ffestd_R542_item_nlist (name);
5930 }
5931
5932 /* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
5933
5934    ffestc_R542_item_nitem(name_token);
5935
5936    Make sure name_token identifies a valid object to be NAMELISTd.  */
5937
5938 void
5939 ffestc_R542_item_nitem (ffelexToken name)
5940 {
5941   ffesymbol s;
5942   ffesymbolAttrs sa;
5943   ffesymbolAttrs na;
5944   ffebld e;
5945
5946   ffestc_check_item_ ();
5947   assert (name != NULL);
5948   if (!ffestc_ok_)
5949     return;
5950
5951   s = ffesymbol_declare_local (name, FALSE);
5952   sa = ffesymbol_attrs (s);
5953
5954   /* Figure out what kind of object we've got based on previous declarations
5955      of or references to the object. */
5956
5957   if (!ffesymbol_is_specable (s)
5958       && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
5959           || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
5960               && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
5961     na = FFESYMBOL_attrsetNONE;
5962   else if (sa & FFESYMBOL_attrsANY)
5963     na = FFESYMBOL_attrsANY;
5964   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
5965                     | FFESYMBOL_attrsARRAY
5966                     | FFESYMBOL_attrsCOMMON
5967                     | FFESYMBOL_attrsEQUIV
5968                     | FFESYMBOL_attrsINIT
5969                     | FFESYMBOL_attrsNAMELIST
5970                     | FFESYMBOL_attrsSAVE
5971                     | FFESYMBOL_attrsSFARG
5972                     | FFESYMBOL_attrsTYPE)))
5973     na = sa | FFESYMBOL_attrsNAMELIST;
5974   else
5975     na = FFESYMBOL_attrsetNONE;
5976
5977   /* Now see what we've got for a new object: NONE means a new error cropped
5978      up; ANY means an old error to be ignored; otherwise, everything's ok,
5979      update the object (symbol) and continue on. */
5980
5981   if (na == FFESYMBOL_attrsetNONE)
5982     ffesymbol_error (s, name);
5983   else if (!(na & FFESYMBOL_attrsANY))
5984     {
5985       ffesymbol_set_attrs (s, na);
5986       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
5987         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
5988       ffesymbol_set_namelisted (s, TRUE);
5989       ffesymbol_signal_unreported (s);
5990 #if 0                           /* No need to establish type yet! */
5991       if (!ffeimplic_establish_symbol (s))
5992         ffesymbol_error (s, name);
5993 #endif
5994     }
5995
5996   if (ffestc_parent_ok_)
5997     {
5998       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
5999                              FFEINTRIN_impNONE);
6000       ffebld_set_info (e,
6001                        ffeinfo_new (FFEINFO_basictypeNONE,
6002                                     FFEINFO_kindtypeNONE, 0,
6003                                     FFEINFO_kindNONE,
6004                                     FFEINFO_whereNONE,
6005                                     FFETARGET_charactersizeNONE));
6006       ffebld_append_item
6007         (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
6008     }
6009
6010   ffestd_R542_item_nitem (name);
6011 }
6012
6013 /* ffestc_R542_finish -- NAMELIST statement list complete
6014
6015    ffestc_R542_finish();
6016
6017    Just wrap up any local activities.  */
6018
6019 void
6020 ffestc_R542_finish (void)
6021 {
6022   ffestc_check_finish_ ();
6023   if (!ffestc_ok_)
6024     return;
6025
6026   ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
6027
6028   ffestd_R542_finish ();
6029 }
6030
6031 /* ffestc_R544_start -- EQUIVALENCE statement list begin
6032
6033    ffestc_R544_start();
6034
6035    Verify that EQUIVALENCE is valid here, and begin accepting items in the
6036    list.  */
6037
6038 void
6039 ffestc_R544_start (void)
6040 {
6041   ffestc_check_start_ ();
6042   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
6043     {
6044       ffestc_ok_ = FALSE;
6045       return;
6046     }
6047   ffestc_labeldef_useless_ ();
6048
6049   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6050
6051   ffestc_ok_ = TRUE;
6052 }
6053
6054 /* ffestc_R544_item -- EQUIVALENCE statement assignment
6055
6056    ffestc_R544_item(exprlist);
6057
6058    Make sure the equivalence is valid, then implement it.  */
6059
6060 void
6061 ffestc_R544_item (ffesttExprList exprlist)
6062 {
6063   ffestc_check_item_ ();
6064   if (!ffestc_ok_)
6065     return;
6066
6067   /* First we go through the list and come up with one ffeequiv object that
6068      will describe all items in the list.  When an ffeequiv object is first
6069      found, it is used (else we create one as a "local equiv" for the time
6070      being).  If subsequent ffeequiv objects are found, they are merged with
6071      the first so we end up with one.  However, if more than one COMMON
6072      variable is involved, then an error condition occurs. */
6073
6074   ffestc_local_.equiv.ok = TRUE;
6075   ffestc_local_.equiv.t = NULL; /* No token yet. */
6076   ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
6077   ffestc_local_.equiv.save = FALSE;     /* No SAVEd variables yet. */
6078
6079   ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
6080   ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
6081   ffebld_end_list (&ffestc_local_.equiv.bottom);
6082
6083   if (!ffestc_local_.equiv.ok)
6084     return;                     /* Something went wrong, stop bothering with
6085                                    this stuff. */
6086
6087   if (ffestc_local_.equiv.eq == NULL)
6088     ffestc_local_.equiv.eq = ffeequiv_new ();   /* Make local equivalence. */
6089
6090   /* Append this list of equivalences to list of such lists for this
6091      equivalence. */
6092
6093   ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
6094                 ffestc_local_.equiv.t);
6095   if (ffestc_local_.equiv.save)
6096     ffeequiv_update_save (ffestc_local_.equiv.eq);
6097 }
6098
6099 /* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
6100
6101    ffebld expr;
6102    ffelexToken t;
6103    ffestc_R544_equiv_(expr,t);
6104
6105    Record information, if any, on symbol in expr; if symbol has equivalence
6106    object already, merge with outstanding object if present or make it
6107    the outstanding object.  */
6108
6109 static void
6110 ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
6111 {
6112   ffesymbol s;
6113
6114   if (!ffestc_local_.equiv.ok)
6115     return;
6116
6117   if (ffestc_local_.equiv.t == NULL)
6118     ffestc_local_.equiv.t = t;
6119
6120   switch (ffebld_op (expr))
6121     {
6122     case FFEBLD_opANY:
6123       return;                   /* Don't put this on the list. */
6124
6125     case FFEBLD_opSYMTER:
6126     case FFEBLD_opARRAYREF:
6127     case FFEBLD_opSUBSTR:
6128       break;                    /* All of these are ok. */
6129
6130     default:
6131       assert ("ffestc_R544_equiv_ bad op" == NULL);
6132       return;
6133     }
6134
6135   ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
6136
6137   s = ffeequiv_symbol (expr);
6138
6139   /* See if symbol has an equivalence object already. */
6140
6141   if (ffesymbol_equiv (s) != NULL)
6142     {
6143       if (ffestc_local_.equiv.eq == NULL)
6144         ffestc_local_.equiv.eq = ffesymbol_equiv (s);   /* New equiv obj. */
6145       else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
6146         {
6147           ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
6148                                                    ffestc_local_.equiv.eq,
6149                                                    t);
6150           if (ffestc_local_.equiv.eq == NULL)
6151             ffestc_local_.equiv.ok = FALSE;     /* Couldn't merge. */
6152         }
6153     }
6154
6155   if (ffesymbol_is_save (s))
6156     ffestc_local_.equiv.save = TRUE;
6157 }
6158
6159 /* ffestc_R544_finish -- EQUIVALENCE statement list complete
6160
6161    ffestc_R544_finish();
6162
6163    Just wrap up any local activities.  */
6164
6165 void
6166 ffestc_R544_finish (void)
6167 {
6168   ffestc_check_finish_ ();
6169 }
6170
6171 /* ffestc_R547_start -- COMMON statement list begin
6172
6173    ffestc_R547_start();
6174
6175    Verify that COMMON is valid here, and begin accepting items in the list.  */
6176
6177 void
6178 ffestc_R547_start (void)
6179 {
6180   ffestc_check_start_ ();
6181   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
6182     {
6183       ffestc_ok_ = FALSE;
6184       return;
6185     }
6186   ffestc_labeldef_useless_ ();
6187
6188   ffestc_local_.common.symbol = NULL;   /* Blank common is the default. */
6189   ffestc_parent_ok_ = TRUE;
6190
6191   ffestd_R547_start ();
6192
6193   ffestc_ok_ = TRUE;
6194 }
6195
6196 /* ffestc_R547_item_object -- COMMON statement for object-name
6197
6198    ffestc_R547_item_object(name_token,dim_list);
6199
6200    Make sure name_token identifies a valid object to be COMMONd.  */
6201
6202 void
6203 ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
6204 {
6205   ffesymbol s;
6206   ffebld array_size;
6207   ffebld extents;
6208   ffesymbolAttrs sa;
6209   ffesymbolAttrs na;
6210   ffestpDimtype nd;
6211   ffebld e;
6212   ffeinfoRank rank;
6213   bool is_ugly_assumed;
6214
6215   if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
6216     ffestc_R547_item_cblock (NULL);     /* As if "COMMON [//] ...". */
6217
6218   ffestc_check_item_ ();
6219   assert (name != NULL);
6220   if (!ffestc_ok_)
6221     return;
6222
6223   if (dims != NULL)
6224     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6225
6226   s = ffesymbol_declare_local (name, FALSE);
6227   sa = ffesymbol_attrs (s);
6228
6229   /* First figure out what kind of object this is based solely on the current
6230      object situation (dimension list). */
6231
6232   is_ugly_assumed = (ffe_is_ugly_assumed ()
6233                      && ((sa & FFESYMBOL_attrsDUMMY)
6234                          || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
6235
6236   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
6237   switch (nd)
6238     {
6239     case FFESTP_dimtypeNONE:
6240       na = FFESYMBOL_attrsCOMMON;
6241       break;
6242
6243     case FFESTP_dimtypeKNOWN:
6244       na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
6245       break;
6246
6247     default:
6248       na = FFESYMBOL_attrsetNONE;
6249       break;
6250     }
6251
6252   /* Figure out what kind of object we've got based on previous declarations
6253      of or references to the object. */
6254
6255   if (na == FFESYMBOL_attrsetNONE)
6256     ;
6257   else if (!ffesymbol_is_specable (s))
6258     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
6259   else if (sa & FFESYMBOL_attrsANY)
6260     na = FFESYMBOL_attrsANY;
6261   else if ((sa & (FFESYMBOL_attrsADJUSTS
6262                   | FFESYMBOL_attrsARRAY
6263                   | FFESYMBOL_attrsINIT
6264                   | FFESYMBOL_attrsSFARG))
6265            && (na & FFESYMBOL_attrsARRAY))
6266     na = FFESYMBOL_attrsetNONE;
6267   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
6268                     | FFESYMBOL_attrsARRAY
6269                     | FFESYMBOL_attrsEQUIV
6270                     | FFESYMBOL_attrsINIT
6271                     | FFESYMBOL_attrsNAMELIST
6272                     | FFESYMBOL_attrsSFARG
6273                     | FFESYMBOL_attrsTYPE)))
6274     na |= sa;
6275   else
6276     na = FFESYMBOL_attrsetNONE;
6277
6278   /* Now see what we've got for a new object: NONE means a new error cropped
6279      up; ANY means an old error to be ignored; otherwise, everything's ok,
6280      update the object (symbol) and continue on. */
6281
6282   if (na == FFESYMBOL_attrsetNONE)
6283     ffesymbol_error (s, name);
6284   else if ((ffesymbol_equiv (s) != NULL)
6285            && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
6286            && (ffeequiv_common (ffesymbol_equiv (s))
6287                != ffestc_local_.common.symbol))
6288     {
6289       /* Oops, just COMMONed a symbol to a different area (via equiv).  */
6290       ffebad_start (FFEBAD_EQUIV_COMMON);
6291       ffebad_here (0, ffelex_token_where_line (name),
6292                    ffelex_token_where_column (name));
6293       ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
6294       ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
6295       ffebad_finish ();
6296       ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
6297       ffesymbol_set_info (s, ffeinfo_new_any ());
6298       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
6299       ffesymbol_signal_unreported (s);
6300     }
6301   else if (!(na & FFESYMBOL_attrsANY))
6302     {
6303       ffesymbol_set_attrs (s, na);
6304       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
6305       ffesymbol_set_common (s, ffestc_local_.common.symbol);
6306 #if FFEGLOBAL_ENABLED
6307       if (ffesymbol_is_init (s))
6308         ffeglobal_init_common (ffestc_local_.common.symbol, name);
6309 #endif
6310       if (ffesymbol_is_save (ffestc_local_.common.symbol))
6311         ffesymbol_update_save (s);
6312       if (ffesymbol_equiv (s) != NULL)
6313         {                       /* Is this newly COMMONed symbol involved in
6314                                    an equivalence? */
6315           if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
6316             ffeequiv_set_common (ffesymbol_equiv (s),   /* Yes, tell equiv obj. */
6317                                  ffestc_local_.common.symbol);
6318 #if FFEGLOBAL_ENABLED
6319           if (ffeequiv_is_init (ffesymbol_equiv (s)))
6320             ffeglobal_init_common (ffestc_local_.common.symbol, name);
6321 #endif
6322           if (ffesymbol_is_save (ffestc_local_.common.symbol))
6323             ffeequiv_update_save (ffesymbol_equiv (s));
6324         }
6325       if (dims != NULL)
6326         {
6327           ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
6328                                                          &array_size,
6329                                                          &extents,
6330                                                          is_ugly_assumed));
6331           ffesymbol_set_arraysize (s, array_size);
6332           ffesymbol_set_extents (s, extents);
6333           if (!(0 && ffe_is_90 ())
6334               && (ffebld_op (array_size) == FFEBLD_opCONTER)
6335               && (ffebld_constant_integerdefault (ffebld_conter (array_size))
6336                   == 0))
6337             {
6338               ffebad_start (FFEBAD_ZERO_ARRAY);
6339               ffebad_here (0, ffelex_token_where_line (name),
6340                            ffelex_token_where_column (name));
6341               ffebad_finish ();
6342             }
6343           ffesymbol_set_info (s,
6344                               ffeinfo_new (ffesymbol_basictype (s),
6345                                            ffesymbol_kindtype (s),
6346                                            rank,
6347                                            ffesymbol_kind (s),
6348                                            ffesymbol_where (s),
6349                                            ffesymbol_size (s)));
6350         }
6351       ffesymbol_signal_unreported (s);
6352     }
6353
6354   if (ffestc_parent_ok_)
6355     {
6356       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
6357                              FFEINTRIN_impNONE);
6358       ffebld_set_info (e,
6359                        ffeinfo_new (FFEINFO_basictypeNONE,
6360                                     FFEINFO_kindtypeNONE,
6361                                     0,
6362                                     FFEINFO_kindNONE,
6363                                     FFEINFO_whereNONE,
6364                                     FFETARGET_charactersizeNONE));
6365       ffebld_append_item
6366         (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
6367     }
6368
6369   ffestd_R547_item_object (name, dims);
6370 }
6371
6372 /* ffestc_R547_item_cblock -- COMMON statement for common-block-name
6373
6374    ffestc_R547_item_cblock(name_token);
6375
6376    Make sure name_token identifies a valid common block to be COMMONd.  */
6377
6378 void
6379 ffestc_R547_item_cblock (ffelexToken name)
6380 {
6381   ffesymbol s;
6382   ffesymbolAttrs sa;
6383   ffesymbolAttrs na;
6384
6385   ffestc_check_item_ ();
6386   if (!ffestc_ok_)
6387     return;
6388
6389   if (ffestc_local_.common.symbol != NULL)
6390     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
6391
6392   s = ffesymbol_declare_cblock (name,
6393                                 ffelex_token_where_line (ffesta_tokens[0]),
6394                               ffelex_token_where_column (ffesta_tokens[0]));
6395   sa = ffesymbol_attrs (s);
6396
6397   /* Figure out what kind of object we've got based on previous declarations
6398      of or references to the object. */
6399
6400   if (!ffesymbol_is_specable (s))
6401     na = FFESYMBOL_attrsetNONE;
6402   else if (sa & FFESYMBOL_attrsANY)
6403     na = FFESYMBOL_attrsANY;    /* Already have an error here, say nothing. */
6404   else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
6405                     | FFESYMBOL_attrsSAVECBLOCK)))
6406     {
6407       if (!(sa & FFESYMBOL_attrsCBLOCK))
6408         ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
6409                           ffesymbol_ptr_to_listbottom (s));
6410       na = sa | FFESYMBOL_attrsCBLOCK;
6411     }
6412   else
6413     na = FFESYMBOL_attrsetNONE;
6414
6415   /* Now see what we've got for a new object: NONE means a new error cropped
6416      up; ANY means an old error to be ignored; otherwise, everything's ok,
6417      update the object (symbol) and continue on. */
6418
6419   if (na == FFESYMBOL_attrsetNONE)
6420     {
6421       ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
6422       ffestc_parent_ok_ = FALSE;
6423     }
6424   else if (na & FFESYMBOL_attrsANY)
6425     ffestc_parent_ok_ = FALSE;
6426   else
6427     {
6428       ffesymbol_set_attrs (s, na);
6429       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
6430       if (name == NULL)
6431         ffesymbol_update_save (s);
6432       ffestc_parent_ok_ = TRUE;
6433     }
6434
6435   ffestc_local_.common.symbol = s;
6436
6437   ffestd_R547_item_cblock (name);
6438 }
6439
6440 /* ffestc_R547_finish -- COMMON statement list complete
6441
6442    ffestc_R547_finish();
6443
6444    Just wrap up any local activities.  */
6445
6446 void
6447 ffestc_R547_finish (void)
6448 {
6449   ffestc_check_finish_ ();
6450   if (!ffestc_ok_)
6451     return;
6452
6453   if (ffestc_local_.common.symbol != NULL)
6454     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
6455
6456   ffestd_R547_finish ();
6457 }
6458
6459 /* ffestc_R737 -- Assignment statement
6460
6461    ffestc_R737(dest_expr,source_expr,source_token);
6462
6463    Make sure the assignment is valid.  */
6464
6465 void
6466 ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
6467 {
6468   ffestc_check_simple_ ();
6469
6470   if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
6471     return;
6472   ffestc_labeldef_branch_begin_ ();
6473
6474   source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
6475                                  FFEEXPR_contextLET);
6476
6477   ffestd_R737A (dest, source);
6478
6479   if (ffestc_shriek_after1_ != NULL)
6480     (*ffestc_shriek_after1_) (TRUE);
6481   ffestc_labeldef_branch_end_ ();
6482 }
6483
6484 /* ffestc_R803 -- Block IF (IF-THEN) statement
6485
6486    ffestc_R803(construct_name,expr,expr_token);
6487
6488    Make sure statement is valid here; implement.  */
6489
6490 void
6491 ffestc_R803 (ffelexToken construct_name, ffebld expr,
6492              ffelexToken expr_token UNUSED)
6493 {
6494   ffestw b;
6495   ffesymbol s;
6496
6497   ffestc_check_simple_ ();
6498   if (ffestc_order_exec_ () != FFESTC_orderOK_)
6499     return;
6500   ffestc_labeldef_notloop_ ();
6501
6502   b = ffestw_update (ffestw_push (NULL));
6503   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
6504   ffestw_set_state (b, FFESTV_stateIFTHEN);
6505   ffestw_set_blocknum (b, ffestc_blocknum_++);
6506   ffestw_set_shriek (b, ffestc_shriek_ifthen_);
6507   ffestw_set_substate (b, 0);   /* Haven't seen ELSE yet. */
6508
6509   if (construct_name == NULL)
6510     ffestw_set_name (b, NULL);
6511   else
6512     {
6513       ffestw_set_name (b, ffelex_token_use (construct_name));
6514
6515       s = ffesymbol_declare_local (construct_name, FALSE);
6516
6517       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
6518         {
6519           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
6520           ffesymbol_set_info (s,
6521                               ffeinfo_new (FFEINFO_basictypeNONE,
6522                                            FFEINFO_kindtypeNONE,
6523                                            0,
6524                                            FFEINFO_kindCONSTRUCT,
6525                                            FFEINFO_whereLOCAL,
6526                                            FFETARGET_charactersizeNONE));
6527           s = ffecom_sym_learned (s);
6528           ffesymbol_signal_unreported (s);
6529         }
6530       else
6531         ffesymbol_error (s, construct_name);
6532     }
6533
6534   ffestd_R803 (construct_name, expr);
6535 }
6536
6537 /* ffestc_R804 -- ELSE IF statement
6538
6539    ffestc_R804(expr,expr_token,name_token);
6540
6541    Make sure ffestc_kind_ identifies an IF block.  If not
6542    NULL, make sure name_token gives the correct name.  Implement the else
6543    of the IF block.  */
6544
6545 void
6546 ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
6547              ffelexToken name)
6548 {
6549   ffestc_check_simple_ ();
6550   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
6551     return;
6552   ffestc_labeldef_useless_ ();
6553
6554   if (name != NULL)
6555     {
6556       if (ffestw_name (ffestw_stack_top ()) == NULL)
6557         {
6558           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
6559           ffebad_here (0, ffelex_token_where_line (name),
6560                        ffelex_token_where_column (name));
6561           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6562           ffebad_finish ();
6563         }
6564       else if (ffelex_token_strcmp (name,
6565                                     ffestw_name (ffestw_stack_top ()))
6566                != 0)
6567         {
6568           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
6569           ffebad_here (0, ffelex_token_where_line (name),
6570                        ffelex_token_where_column (name));
6571           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
6572              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
6573           ffebad_finish ();
6574         }
6575     }
6576
6577   if (ffestw_substate (ffestw_stack_top ()) != 0)
6578     {
6579       ffebad_start (FFEBAD_AFTER_ELSE);
6580       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6581                    ffelex_token_where_column (ffesta_tokens[0]));
6582       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6583       ffebad_finish ();
6584       return;                   /* Don't upset back end with ELSEIF
6585                                    after ELSE. */
6586     }
6587
6588   ffestd_R804 (expr, name);
6589 }
6590
6591 /* ffestc_R805 -- ELSE statement
6592
6593    ffestc_R805(name_token);
6594
6595    Make sure ffestc_kind_ identifies an IF block.  If not
6596    NULL, make sure name_token gives the correct name.  Implement the ELSE
6597    of the IF block.  */
6598
6599 void
6600 ffestc_R805 (ffelexToken name)
6601 {
6602   ffestc_check_simple_ ();
6603   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
6604     return;
6605   ffestc_labeldef_useless_ ();
6606
6607   if (name != NULL)
6608     {
6609       if (ffestw_name (ffestw_stack_top ()) == NULL)
6610         {
6611           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
6612           ffebad_here (0, ffelex_token_where_line (name),
6613                        ffelex_token_where_column (name));
6614           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6615           ffebad_finish ();
6616         }
6617       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
6618         {
6619           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
6620           ffebad_here (0, ffelex_token_where_line (name),
6621                        ffelex_token_where_column (name));
6622           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
6623              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
6624           ffebad_finish ();
6625         }
6626     }
6627
6628   if (ffestw_substate (ffestw_stack_top ()) != 0)
6629     {
6630       ffebad_start (FFEBAD_AFTER_ELSE);
6631       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6632                    ffelex_token_where_column (ffesta_tokens[0]));
6633       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6634       ffebad_finish ();
6635       return;                   /* Tell back end about only one ELSE. */
6636     }
6637
6638   ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
6639
6640   ffestd_R805 (name);
6641 }
6642
6643 /* ffestc_R806 -- END IF statement
6644
6645    ffestc_R806(name_token);
6646
6647    Make sure ffestc_kind_ identifies an IF block.  If not
6648    NULL, make sure name_token gives the correct name.  Implement the end
6649    of the IF block.  */
6650
6651 void
6652 ffestc_R806 (ffelexToken name)
6653 {
6654   ffestc_check_simple_ ();
6655   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
6656     return;
6657   ffestc_labeldef_endif_ ();
6658
6659   if (name == NULL)
6660     {
6661       if (ffestw_name (ffestw_stack_top ()) != NULL)
6662         {
6663           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
6664           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6665                        ffelex_token_where_column (ffesta_tokens[0]));
6666           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6667           ffebad_finish ();
6668         }
6669     }
6670   else
6671     {
6672       if (ffestw_name (ffestw_stack_top ()) == NULL)
6673         {
6674           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
6675           ffebad_here (0, ffelex_token_where_line (name),
6676                        ffelex_token_where_column (name));
6677           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6678           ffebad_finish ();
6679         }
6680       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
6681         {
6682           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
6683           ffebad_here (0, ffelex_token_where_line (name),
6684                        ffelex_token_where_column (name));
6685           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
6686              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
6687           ffebad_finish ();
6688         }
6689     }
6690
6691   ffestc_shriek_ifthen_ (TRUE);
6692 }
6693
6694 /* ffestc_R807 -- Logical IF statement
6695
6696    ffestc_R807(expr,expr_token);
6697
6698    Make sure statement is valid here; implement.  */
6699
6700 void
6701 ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
6702 {
6703   ffestw b;
6704
6705   ffestc_check_simple_ ();
6706   if (ffestc_order_action_ () != FFESTC_orderOK_)
6707     return;
6708   ffestc_labeldef_branch_begin_ ();
6709
6710   b = ffestw_update (ffestw_push (NULL));
6711   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
6712   ffestw_set_state (b, FFESTV_stateIF);
6713   ffestw_set_blocknum (b, ffestc_blocknum_++);
6714   ffestw_set_shriek (b, ffestc_shriek_if_lost_);
6715
6716   ffestd_R807 (expr);
6717
6718   /* Do the label finishing in the next statement. */
6719
6720 }
6721
6722 /* ffestc_R809 -- SELECT CASE statement
6723
6724    ffestc_R809(construct_name,expr,expr_token);
6725
6726    Make sure statement is valid here; implement.  */
6727
6728 void
6729 ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
6730 {
6731   ffestw b;
6732   mallocPool pool;
6733   ffestwSelect s;
6734   ffesymbol sym;
6735
6736   ffestc_check_simple_ ();
6737   if (ffestc_order_exec_ () != FFESTC_orderOK_)
6738     return;
6739   ffestc_labeldef_notloop_ ();
6740
6741   b = ffestw_update (ffestw_push (NULL));
6742   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
6743   ffestw_set_state (b, FFESTV_stateSELECT0);
6744   ffestw_set_blocknum (b, ffestc_blocknum_++);
6745   ffestw_set_shriek (b, ffestc_shriek_select_);
6746   ffestw_set_substate (b, 0);   /* Haven't seen CASE DEFAULT yet. */
6747
6748   /* Init block to manage CASE list. */
6749
6750   pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
6751   s = malloc_new_kp (pool, "Select", sizeof (*s));
6752   s->first_rel = (ffestwCase) &s->first_rel;
6753   s->last_rel = (ffestwCase) &s->first_rel;
6754   s->first_stmt = (ffestwCase) &s->first_rel;
6755   s->last_stmt = (ffestwCase) &s->first_rel;
6756   s->pool = pool;
6757   s->cases = 1;
6758   s->t = ffelex_token_use (expr_token);
6759   s->type = ffeinfo_basictype (ffebld_info (expr));
6760   s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
6761   ffestw_set_select (b, s);
6762
6763   if (construct_name == NULL)
6764     ffestw_set_name (b, NULL);
6765   else
6766     {
6767       ffestw_set_name (b, ffelex_token_use (construct_name));
6768
6769       sym = ffesymbol_declare_local (construct_name, FALSE);
6770
6771       if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
6772         {
6773           ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
6774           ffesymbol_set_info (sym,
6775                               ffeinfo_new (FFEINFO_basictypeNONE,
6776                                            FFEINFO_kindtypeNONE, 0,
6777                                            FFEINFO_kindCONSTRUCT,
6778                                            FFEINFO_whereLOCAL,
6779                                            FFETARGET_charactersizeNONE));
6780           sym = ffecom_sym_learned (sym);
6781           ffesymbol_signal_unreported (sym);
6782         }
6783       else
6784         ffesymbol_error (sym, construct_name);
6785     }
6786
6787   ffestd_R809 (construct_name, expr);
6788 }
6789
6790 /* ffestc_R810 -- CASE statement
6791
6792    ffestc_R810(case_value_range_list,name);
6793
6794    If case_value_range_list is NULL, it's CASE DEFAULT.  name is the case-
6795    construct-name.  Make sure no more than one CASE DEFAULT is present for
6796    a given case-construct and that there aren't any overlapping ranges or
6797    duplicate case values.  */
6798
6799 void
6800 ffestc_R810 (ffesttCaseList cases, ffelexToken name)
6801 {
6802   ffesttCaseList caseobj;
6803   ffestwSelect s;
6804   ffestwCase c, nc;
6805   ffebldConstant expr1c, expr2c;
6806
6807   ffestc_check_simple_ ();
6808   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
6809     return;
6810   ffestc_labeldef_useless_ ();
6811
6812   s = ffestw_select (ffestw_stack_top ());
6813
6814   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
6815     {
6816 #if 0                           /* Not sure we want to have msgs point here
6817                                    instead of SELECT CASE. */
6818       ffestw_update (NULL);     /* Update state line/col info. */
6819 #endif
6820       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
6821     }
6822
6823   if (name != NULL)
6824     {
6825       if (ffestw_name (ffestw_stack_top ()) == NULL)
6826         {
6827           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
6828           ffebad_here (0, ffelex_token_where_line (name),
6829                        ffelex_token_where_column (name));
6830           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6831           ffebad_finish ();
6832         }
6833       else if (ffelex_token_strcmp (name,
6834                                     ffestw_name (ffestw_stack_top ()))
6835                != 0)
6836         {
6837           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
6838           ffebad_here (0, ffelex_token_where_line (name),
6839                        ffelex_token_where_column (name));
6840           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
6841              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
6842           ffebad_finish ();
6843         }
6844     }
6845
6846   if (cases == NULL)
6847     {
6848       if (ffestw_substate (ffestw_stack_top ()) != 0)
6849         {
6850           ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
6851           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6852                        ffelex_token_where_column (ffesta_tokens[0]));
6853           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6854           ffebad_finish ();
6855         }
6856
6857       ffestw_set_substate (ffestw_stack_top (), 1);     /* Saw ELSE. */
6858     }
6859   else
6860     {                           /* For each case, try to fit into sorted list
6861                                    of ranges. */
6862       for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
6863         {
6864           if ((caseobj->expr1 == NULL)
6865               && (!caseobj->range
6866                   || (caseobj->expr2 == NULL)))
6867             {                   /* "CASE (:)". */
6868               ffebad_start (FFEBAD_CASE_BAD_RANGE);
6869               ffebad_here (0, ffelex_token_where_line (caseobj->t),
6870                            ffelex_token_where_column (caseobj->t));
6871               ffebad_finish ();
6872               continue;
6873             }
6874           if (((caseobj->expr1 != NULL)
6875                && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
6876                     != s->type)
6877                    || ((ffeinfo_kindtype (ffebld_info (caseobj->expr1))
6878                        != s->kindtype)
6879                        && (ffeinfo_kindtype (ffebld_info (caseobj->expr1)) != FFEINFO_kindtypeINTEGER1 ))
6880               || ((caseobj->range)
6881                   && (caseobj->expr2 != NULL)
6882                   && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
6883                        != s->type)
6884                       || ((ffeinfo_kindtype (ffebld_info (caseobj->expr2))
6885                           != s->kindtype)
6886                       && (ffeinfo_kindtype (ffebld_info (caseobj->expr2)) != FFEINFO_kindtypeINTEGER1)))))))
6887             {
6888               ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
6889               ffebad_here (0, ffelex_token_where_line (caseobj->t),
6890                            ffelex_token_where_column (caseobj->t));
6891               ffebad_here (1, ffelex_token_where_line (s->t),
6892                            ffelex_token_where_column (s->t));
6893               ffebad_finish ();
6894               continue;
6895             }
6896
6897
6898
6899           if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
6900             {
6901               ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
6902               ffebad_here (0, ffelex_token_where_line (caseobj->t),
6903                            ffelex_token_where_column (caseobj->t));
6904               ffebad_finish ();
6905               continue;
6906             }
6907
6908           if (caseobj->expr1 == NULL)
6909             expr1c = NULL;
6910           else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
6911             continue;           /* opANY. */
6912           else
6913             expr1c = ffebld_conter (caseobj->expr1);
6914
6915           if (!caseobj->range)
6916             expr2c = expr1c;    /* expr1c and expr2c are NOT NULL in this
6917                                    case. */
6918           else if (caseobj->expr2 == NULL)
6919             expr2c = NULL;
6920           else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
6921             continue;           /* opANY. */
6922           else
6923             expr2c = ffebld_conter (caseobj->expr2);
6924
6925           if (expr1c == NULL)
6926             {                   /* "CASE (:high)", must be first in list. */
6927               c = s->first_rel;
6928               if ((c != (ffestwCase) &s->first_rel)
6929                   && ((c->low == NULL)
6930                       || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
6931                 {               /* Other "CASE (:high)" or lowest "CASE
6932                                    (low[:high])" low. */
6933                   ffebad_start (FFEBAD_CASE_DUPLICATE);
6934                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
6935                                ffelex_token_where_column (caseobj->t));
6936                   ffebad_here (1, ffelex_token_where_line (c->t),
6937                                ffelex_token_where_column (c->t));
6938                   ffebad_finish ();
6939                   continue;
6940                 }
6941             }
6942           else if (expr2c == NULL)
6943             {                   /* "CASE (low:)", must be last in list. */
6944               c = s->last_rel;
6945               if ((c != (ffestwCase) &s->first_rel)
6946                   && ((c->high == NULL)
6947                       || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
6948                 {               /* Other "CASE (low:)" or lowest "CASE
6949                                    ([low:]high)" high. */
6950                   ffebad_start (FFEBAD_CASE_DUPLICATE);
6951                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
6952                                ffelex_token_where_column (caseobj->t));
6953                   ffebad_here (1, ffelex_token_where_line (c->t),
6954                                ffelex_token_where_column (c->t));
6955                   ffebad_finish ();
6956                   continue;
6957                 }
6958               c = c->next_rel;  /* Same as c = (ffestwCase) &s->first;. */
6959             }
6960           else
6961             {                   /* (expr1c != NULL) && (expr2c != NULL). */
6962               if (ffebld_constant_cmp (expr1c, expr2c) > 0)
6963                 {               /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
6964                   ffebad_start (FFEBAD_CASE_RANGE_USELESS);     /* Warn/inform only. */
6965                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
6966                                ffelex_token_where_column (caseobj->t));
6967                   ffebad_finish ();
6968                   continue;
6969                 }
6970               for (c = s->first_rel;
6971                    (c != (ffestwCase) &s->first_rel)
6972                    && ((c->low == NULL)
6973                        || (ffebld_constant_cmp (expr1c, c->low) > 0));
6974                    c = c->next_rel)
6975                 ;
6976               nc = c;           /* Which one to report? */
6977               if (((c != (ffestwCase) &s->first_rel)
6978                    && (ffebld_constant_cmp (expr2c, c->low) >= 0))
6979                   || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
6980                       && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
6981                 {               /* Interference with range in case nc. */
6982                   ffebad_start (FFEBAD_CASE_DUPLICATE);
6983                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
6984                                ffelex_token_where_column (caseobj->t));
6985                   ffebad_here (1, ffelex_token_where_line (nc->t),
6986                                ffelex_token_where_column (nc->t));
6987                   ffebad_finish ();
6988                   continue;
6989                 }
6990             }
6991
6992           /* If we reach here for this case range/value, it's ok (sorts into
6993              the list of ranges/values) so we give it its own case object
6994              sorted into the list of case statements. */
6995
6996           nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
6997           nc->next_rel = c;
6998           nc->previous_rel = c->previous_rel;
6999           nc->next_stmt = (ffestwCase) &s->first_rel;
7000           nc->previous_stmt = s->last_stmt;
7001           nc->low = expr1c;
7002           nc->high = expr2c;
7003           nc->casenum = s->cases;
7004           nc->t = ffelex_token_use (caseobj->t);
7005           nc->next_rel->previous_rel = nc;
7006           nc->previous_rel->next_rel = nc;
7007           nc->next_stmt->previous_stmt = nc;
7008           nc->previous_stmt->next_stmt = nc;
7009         }
7010     }
7011
7012   ffestd_R810 ((cases == NULL) ? 0 : s->cases);
7013
7014   s->cases++;                   /* Increment # of cases. */
7015 }
7016
7017 /* ffestc_R811 -- END SELECT statement
7018
7019    ffestc_R811(name_token);
7020
7021    Make sure ffestc_kind_ identifies a SELECT block.  If not
7022    NULL, make sure name_token gives the correct name.  Implement the end
7023    of the SELECT block.  */
7024
7025 void
7026 ffestc_R811 (ffelexToken name)
7027 {
7028   ffestc_check_simple_ ();
7029   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
7030     return;
7031   ffestc_labeldef_notloop_ ();
7032
7033   if (name == NULL)
7034     {
7035       if (ffestw_name (ffestw_stack_top ()) != NULL)
7036         {
7037           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
7038           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
7039                        ffelex_token_where_column (ffesta_tokens[0]));
7040           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
7041           ffebad_finish ();
7042         }
7043     }
7044   else
7045     {
7046       if (ffestw_name (ffestw_stack_top ()) == NULL)
7047         {
7048           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
7049           ffebad_here (0, ffelex_token_where_line (name),
7050                        ffelex_token_where_column (name));
7051           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
7052           ffebad_finish ();
7053         }
7054       else if (ffelex_token_strcmp (name,
7055                                     ffestw_name (ffestw_stack_top ()))
7056                != 0)
7057         {
7058           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
7059           ffebad_here (0, ffelex_token_where_line (name),
7060                        ffelex_token_where_column (name));
7061           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
7062              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
7063           ffebad_finish ();
7064         }
7065     }
7066
7067   ffestc_shriek_select_ (TRUE);
7068 }
7069
7070 /* ffestc_R819A -- Iterative labeled DO statement
7071
7072    ffestc_R819A(construct_name,label_token,expr,expr_token);
7073
7074    Make sure statement is valid here; implement.  */
7075
7076 void
7077 ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
7078    ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
7079               ffelexToken end_token, ffebld incr, ffelexToken incr_token)
7080 {
7081   ffestw b;
7082   ffelab label;
7083   ffesymbol s;
7084   ffesymbol varsym;
7085
7086   ffestc_check_simple_ ();
7087   if (ffestc_order_exec_ () != FFESTC_orderOK_)
7088     return;
7089   ffestc_labeldef_notloop_ ();
7090
7091   if (!ffestc_labelref_is_loopend_ (label_token, &label))
7092     return;
7093
7094   b = ffestw_update (ffestw_push (NULL));
7095   ffestw_set_top_do (b, b);
7096   ffestw_set_state (b, FFESTV_stateDO);
7097   ffestw_set_blocknum (b, ffestc_blocknum_++);
7098   ffestw_set_shriek (b, ffestc_shriek_do_);
7099   ffestw_set_label (b, label);
7100   switch (ffebld_op (var))
7101     {
7102     case FFEBLD_opSYMTER:
7103       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
7104           && ffe_is_warn_surprising ())
7105         {
7106           ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
7107           ffebad_here (0, ffelex_token_where_line (var_token),
7108                        ffelex_token_where_column (var_token));
7109           ffebad_string (ffesymbol_text (ffebld_symter (var)));
7110           ffebad_finish ();
7111         }
7112       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
7113         {                       /* Presumably already complained about by
7114                                    ffeexpr_lhs_. */
7115           ffesymbol_set_is_doiter (varsym, TRUE);
7116           ffestw_set_do_iter_var (b, varsym);
7117           ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
7118           break;
7119         }
7120       /* Fall through. */
7121     case FFEBLD_opANY:
7122       ffestw_set_do_iter_var (b, NULL);
7123       ffestw_set_do_iter_var_t (b, NULL);
7124       break;
7125
7126     default:
7127       assert ("bad iter var" == NULL);
7128       break;
7129     }
7130
7131   if (construct_name == NULL)
7132     ffestw_set_name (b, NULL);
7133   else
7134     {
7135       ffestw_set_name (b, ffelex_token_use (construct_name));
7136
7137       s = ffesymbol_declare_local (construct_name, FALSE);
7138
7139       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
7140         {
7141           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
7142           ffesymbol_set_info (s,
7143                               ffeinfo_new (FFEINFO_basictypeNONE,
7144                                            FFEINFO_kindtypeNONE,
7145                                            0,
7146                                            FFEINFO_kindCONSTRUCT,
7147                                            FFEINFO_whereLOCAL,
7148                                            FFETARGET_charactersizeNONE));
7149           s = ffecom_sym_learned (s);
7150           ffesymbol_signal_unreported (s);
7151         }
7152       else
7153         ffesymbol_error (s, construct_name);
7154     }
7155
7156   if (incr == NULL)
7157     {
7158       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
7159       ffebld_set_info (incr, ffeinfo_new
7160                        (FFEINFO_basictypeINTEGER,
7161                         FFEINFO_kindtypeINTEGERDEFAULT,
7162                         0,
7163                         FFEINFO_kindENTITY,
7164                         FFEINFO_whereCONSTANT,
7165                         FFETARGET_charactersizeNONE));
7166     }
7167
7168   start = ffeexpr_convert_expr (start, start_token, var, var_token,
7169                                 FFEEXPR_contextLET);
7170   end = ffeexpr_convert_expr (end, end_token, var, var_token,
7171                               FFEEXPR_contextLET);
7172   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
7173                                FFEEXPR_contextLET);
7174
7175   ffestd_R819A (construct_name, label, var,
7176                 start, start_token,
7177                 end, end_token,
7178                 incr, incr_token);
7179 }
7180
7181 /* ffestc_R819B -- Labeled DO WHILE statement
7182
7183    ffestc_R819B(construct_name,label_token,expr,expr_token);
7184
7185    Make sure statement is valid here; implement.  */
7186
7187 void
7188 ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
7189               ffebld expr, ffelexToken expr_token UNUSED)
7190 {
7191   ffestw b;
7192   ffelab label;
7193   ffesymbol s;
7194
7195   ffestc_check_simple_ ();
7196   if (ffestc_order_exec_ () != FFESTC_orderOK_)
7197     return;
7198   ffestc_labeldef_notloop_ ();
7199
7200   if (!ffestc_labelref_is_loopend_ (label_token, &label))
7201     return;
7202
7203   b = ffestw_update (ffestw_push (NULL));
7204   ffestw_set_top_do (b, b);
7205   ffestw_set_state (b, FFESTV_stateDO);
7206   ffestw_set_blocknum (b, ffestc_blocknum_++);
7207   ffestw_set_shriek (b, ffestc_shriek_do_);
7208   ffestw_set_label (b, label);
7209   ffestw_set_do_iter_var (b, NULL);
7210   ffestw_set_do_iter_var_t (b, NULL);
7211
7212   if (construct_name == NULL)
7213     ffestw_set_name (b, NULL);
7214   else
7215     {
7216       ffestw_set_name (b, ffelex_token_use (construct_name));
7217
7218       s = ffesymbol_declare_local (construct_name, FALSE);
7219
7220       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
7221         {
7222           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
7223           ffesymbol_set_info (s,
7224                               ffeinfo_new (FFEINFO_basictypeNONE,
7225                                            FFEINFO_kindtypeNONE,
7226                                            0,
7227                                            FFEINFO_kindCONSTRUCT,
7228                                            FFEINFO_whereLOCAL,
7229                                            FFETARGET_charactersizeNONE));
7230           s = ffecom_sym_learned (s);
7231           ffesymbol_signal_unreported (s);
7232         }
7233       else
7234         ffesymbol_error (s, construct_name);
7235     }
7236
7237   ffestd_R819B (construct_name, label, expr);
7238 }
7239
7240 /* ffestc_R820A -- Iterative nonlabeled DO statement
7241
7242    ffestc_R820A(construct_name,expr,expr_token);
7243
7244    Make sure statement is valid here; implement.  */
7245
7246 void
7247 ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
7248    ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
7249               ffebld incr, ffelexToken incr_token)
7250 {
7251   ffestw b;
7252   ffesymbol s;
7253   ffesymbol varsym;
7254
7255   ffestc_check_simple_ ();
7256   if (ffestc_order_exec_ () != FFESTC_orderOK_)
7257     return;
7258   ffestc_labeldef_notloop_ ();
7259
7260   b = ffestw_update (ffestw_push (NULL));
7261   ffestw_set_top_do (b, b);
7262   ffestw_set_state (b, FFESTV_stateDO);
7263   ffestw_set_blocknum (b, ffestc_blocknum_++);
7264   ffestw_set_shriek (b, ffestc_shriek_do_);
7265   ffestw_set_label (b, NULL);
7266   switch (ffebld_op (var))
7267     {
7268     case FFEBLD_opSYMTER:
7269       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
7270           && ffe_is_warn_surprising ())
7271         {
7272           ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
7273           ffebad_here (0, ffelex_token_where_line (var_token),
7274                        ffelex_token_where_column (var_token));
7275           ffebad_string (ffesymbol_text (ffebld_symter (var)));
7276           ffebad_finish ();
7277         }
7278       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
7279         {                       /* Presumably already complained about by
7280                                    ffeexpr_lhs_. */
7281           ffesymbol_set_is_doiter (varsym, TRUE);
7282           ffestw_set_do_iter_var (b, varsym);
7283           ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
7284           break;
7285         }
7286       /* Fall through. */
7287     case FFEBLD_opANY:
7288       ffestw_set_do_iter_var (b, NULL);
7289       ffestw_set_do_iter_var_t (b, NULL);
7290       break;
7291
7292     default:
7293       assert ("bad iter var" == NULL);
7294       break;
7295     }
7296
7297   if (construct_name == NULL)
7298     ffestw_set_name (b, NULL);
7299   else
7300     {
7301       ffestw_set_name (b, ffelex_token_use (construct_name));
7302
7303       s = ffesymbol_declare_local (construct_name, FALSE);
7304
7305       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
7306         {
7307           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
7308           ffesymbol_set_info (s,
7309                               ffeinfo_new (FFEINFO_basictypeNONE,
7310                                            FFEINFO_kindtypeNONE,
7311                                            0,
7312                                            FFEINFO_kindCONSTRUCT,
7313                                            FFEINFO_whereLOCAL,
7314                                            FFETARGET_charactersizeNONE));
7315           s = ffecom_sym_learned (s);
7316           ffesymbol_signal_unreported (s);
7317         }
7318       else
7319         ffesymbol_error (s, construct_name);
7320     }
7321
7322   if (incr == NULL)
7323     {
7324       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
7325       ffebld_set_info (incr, ffeinfo_new
7326                        (FFEINFO_basictypeINTEGER,
7327                         FFEINFO_kindtypeINTEGERDEFAULT,
7328                         0,
7329                         FFEINFO_kindENTITY,
7330                         FFEINFO_whereCONSTANT,
7331                         FFETARGET_charactersizeNONE));
7332     }
7333
7334   start = ffeexpr_convert_expr (start, start_token, var, var_token,
7335                                 FFEEXPR_contextLET);
7336   end = ffeexpr_convert_expr (end, end_token, var, var_token,
7337                               FFEEXPR_contextLET);
7338   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
7339                                FFEEXPR_contextLET);
7340
7341 #if 0
7342   if ((ffebld_op (incr) == FFEBLD_opCONTER)
7343       && (ffebld_constant_is_zero (ffebld_conter (incr))))
7344     {
7345       ffebad_start (FFEBAD_DO_STEP_ZERO);
7346       ffebad_here (0, ffelex_token_where_line (incr_token),
7347                    ffelex_token_where_column (incr_token));
7348       ffebad_string ("Iterative DO loop");
7349       ffebad_finish ();
7350     }
7351 #endif
7352
7353   ffestd_R819A (construct_name, NULL, var,
7354                 start, start_token,
7355                 end, end_token,
7356                 incr, incr_token);
7357 }
7358
7359 /* ffestc_R820B -- Nonlabeled DO WHILE statement
7360
7361    ffestc_R820B(construct_name,expr,expr_token);
7362
7363    Make sure statement is valid here; implement.  */
7364
7365 void
7366 ffestc_R820B (ffelexToken construct_name, ffebld expr,
7367               ffelexToken expr_token UNUSED)
7368 {
7369   ffestw b;
7370   ffesymbol s;
7371
7372   ffestc_check_simple_ ();
7373   if (ffestc_order_exec_ () != FFESTC_orderOK_)
7374     return;
7375   ffestc_labeldef_notloop_ ();
7376
7377   b = ffestw_update (ffestw_push (NULL));
7378   ffestw_set_top_do (b, b);
7379   ffestw_set_state (b, FFESTV_stateDO);
7380   ffestw_set_blocknum (b, ffestc_blocknum_++);
7381   ffestw_set_shriek (b, ffestc_shriek_do_);
7382   ffestw_set_label (b, NULL);
7383   ffestw_set_do_iter_var (b, NULL);
7384   ffestw_set_do_iter_var_t (b, NULL);
7385
7386   if (construct_name == NULL)
7387     ffestw_set_name (b, NULL);
7388   else
7389     {
7390       ffestw_set_name (b, ffelex_token_use (construct_name));
7391
7392       s = ffesymbol_declare_local (construct_name, FALSE);
7393
7394       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
7395         {
7396           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
7397           ffesymbol_set_info (s,
7398                               ffeinfo_new (FFEINFO_basictypeNONE,
7399                                            FFEINFO_kindtypeNONE,
7400                                            0,
7401                                            FFEINFO_kindCONSTRUCT,
7402                                            FFEINFO_whereLOCAL,
7403                                            FFETARGET_charactersizeNONE));
7404           s = ffecom_sym_learned (s);
7405           ffesymbol_signal_unreported (s);
7406         }
7407       else
7408         ffesymbol_error (s, construct_name);
7409     }
7410
7411   ffestd_R819B (construct_name, NULL, expr);
7412 }
7413
7414 /* ffestc_R825 -- END DO statement
7415
7416    ffestc_R825(name_token);
7417
7418    Make sure ffestc_kind_ identifies a DO block.  If not
7419    NULL, make sure name_token gives the correct name.  Implement the end
7420    of the DO block.  */
7421
7422 void
7423 ffestc_R825 (ffelexToken name)
7424 {
7425   ffestc_check_simple_ ();
7426   if (ffestc_order_do_ () != FFESTC_orderOK_)
7427     return;
7428   ffestc_labeldef_branch_begin_ ();
7429
7430   if (name == NULL)
7431     {
7432       if (ffestw_name (ffestw_stack_top ()) != NULL)
7433         {
7434           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
7435           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
7436                        ffelex_token_where_column (ffesta_tokens[0]));
7437           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
7438           ffebad_finish ();
7439         }
7440     }
7441   else
7442     {
7443       if (ffestw_name (ffestw_stack_top ()) == NULL)
7444         {
7445           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
7446           ffebad_here (0, ffelex_token_where_line (name),
7447                        ffelex_token_where_column (name));
7448           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
7449           ffebad_finish ();
7450         }
7451       else if (ffelex_token_strcmp (name,
7452                                     ffestw_name (ffestw_stack_top ()))
7453                != 0)
7454         {
7455           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
7456           ffebad_here (0, ffelex_token_where_line (name),
7457                        ffelex_token_where_column (name));
7458           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
7459              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
7460           ffebad_finish ();
7461         }
7462     }
7463
7464   if (ffesta_label_token == NULL)
7465     {                           /* If top of stack has label, its an error! */
7466       if (ffestw_label (ffestw_stack_top ()) != NULL)
7467         {
7468           ffebad_start (FFEBAD_DO_HAD_LABEL);
7469           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
7470                        ffelex_token_where_column (ffesta_tokens[0]));
7471           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
7472           ffebad_finish ();
7473         }
7474
7475       ffestc_shriek_do_ (TRUE);
7476
7477       ffestc_try_shriek_do_ ();
7478
7479       return;
7480     }
7481
7482   ffestd_R825 (name);
7483
7484   ffestc_labeldef_branch_end_ ();
7485 }
7486
7487 /* ffestc_R834 -- CYCLE statement
7488
7489    ffestc_R834(name_token);
7490
7491    Handle a CYCLE within a loop.  */
7492
7493 void
7494 ffestc_R834 (ffelexToken name)
7495 {
7496   ffestw block;
7497
7498   ffestc_check_simple_ ();
7499   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
7500     return;
7501   ffestc_labeldef_notloop_begin_ ();
7502
7503   if (name == NULL)
7504     block = ffestw_top_do (ffestw_stack_top ());
7505   else
7506     {                           /* Search for name. */
7507       for (block = ffestw_top_do (ffestw_stack_top ());
7508            (block != NULL) && (ffestw_blocknum (block) != 0);
7509            block = ffestw_top_do (ffestw_previous (block)))
7510         {
7511           if ((ffestw_name (block) != NULL)
7512               && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
7513             break;
7514         }
7515       if ((block == NULL) || (ffestw_blocknum (block) == 0))
7516         {
7517           block = ffestw_top_do (ffestw_stack_top ());
7518           ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
7519           ffebad_here (0, ffelex_token_where_line (name),
7520                        ffelex_token_where_column (name));
7521           ffebad_finish ();
7522         }
7523     }
7524
7525   ffestd_R834 (block);
7526
7527   if (ffestc_shriek_after1_ != NULL)
7528     (*ffestc_shriek_after1_) (TRUE);
7529
7530   /* notloop's that are actionif's can be the target of a loop-end
7531      statement if they're in the "then" part of a logical IF, as
7532      in "DO 10", "10 IF (...) CYCLE".  */
7533
7534   ffestc_labeldef_branch_end_ ();
7535 }
7536
7537 /* ffestc_R835 -- EXIT statement
7538
7539    ffestc_R835(name_token);
7540
7541    Handle a EXIT within a loop.  */
7542
7543 void
7544 ffestc_R835 (ffelexToken name)
7545 {
7546   ffestw block;
7547
7548   ffestc_check_simple_ ();
7549   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
7550     return;
7551   ffestc_labeldef_notloop_begin_ ();
7552
7553   if (name == NULL)
7554     block = ffestw_top_do (ffestw_stack_top ());
7555   else
7556     {                           /* Search for name. */
7557       for (block = ffestw_top_do (ffestw_stack_top ());
7558            (block != NULL) && (ffestw_blocknum (block) != 0);
7559            block = ffestw_top_do (ffestw_previous (block)))
7560         {
7561           if ((ffestw_name (block) != NULL)
7562               && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
7563             break;
7564         }
7565       if ((block == NULL) || (ffestw_blocknum (block) == 0))
7566         {
7567           block = ffestw_top_do (ffestw_stack_top ());
7568           ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
7569           ffebad_here (0, ffelex_token_where_line (name),
7570                        ffelex_token_where_column (name));
7571           ffebad_finish ();
7572         }
7573     }
7574
7575   ffestd_R835 (block);
7576
7577   if (ffestc_shriek_after1_ != NULL)
7578     (*ffestc_shriek_after1_) (TRUE);
7579
7580   /* notloop's that are actionif's can be the target of a loop-end
7581      statement if they're in the "then" part of a logical IF, as
7582      in "DO 10", "10 IF (...) EXIT".  */
7583
7584   ffestc_labeldef_branch_end_ ();
7585 }
7586
7587 /* ffestc_R836 -- GOTO statement
7588
7589    ffestc_R836(label_token);
7590
7591    Make sure label_token identifies a valid label for a GOTO.  Update
7592    that label's info to indicate it is the target of a GOTO.  */
7593
7594 void
7595 ffestc_R836 (ffelexToken label_token)
7596 {
7597   ffelab label;
7598
7599   ffestc_check_simple_ ();
7600   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7601     return;
7602   ffestc_labeldef_notloop_begin_ ();
7603
7604   if (ffestc_labelref_is_branch_ (label_token, &label))
7605     ffestd_R836 (label);
7606
7607   if (ffestc_shriek_after1_ != NULL)
7608     (*ffestc_shriek_after1_) (TRUE);
7609
7610   /* notloop's that are actionif's can be the target of a loop-end
7611      statement if they're in the "then" part of a logical IF, as
7612      in "DO 10", "10 IF (...) GOTO 100".  */
7613
7614   ffestc_labeldef_branch_end_ ();
7615 }
7616
7617 /* ffestc_R837 -- Computed GOTO statement
7618
7619    ffestc_R837(label_list,expr,expr_token);
7620
7621    Make sure label_list identifies valid labels for a GOTO.  Update
7622    each label's info to indicate it is the target of a GOTO.  */
7623
7624 void
7625 ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
7626              ffelexToken expr_token UNUSED)
7627 {
7628   ffesttTokenItem ti;
7629   bool ok = TRUE;
7630   int i;
7631   ffelab *labels;
7632
7633   assert (label_toks != NULL);
7634
7635   ffestc_check_simple_ ();
7636   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7637     return;
7638   ffestc_labeldef_branch_begin_ ();
7639
7640   labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
7641                           sizeof (*labels)
7642                           * ffestt_tokenlist_count (label_toks));
7643
7644   for (ti = label_toks->first, i = 0;
7645        ti != (ffesttTokenItem) &label_toks->first;
7646        ti = ti->next, ++i)
7647     {
7648       if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
7649         {
7650           ok = FALSE;
7651           break;
7652         }
7653     }
7654
7655   if (ok)
7656     ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
7657
7658   if (ffestc_shriek_after1_ != NULL)
7659     (*ffestc_shriek_after1_) (TRUE);
7660   ffestc_labeldef_branch_end_ ();
7661 }
7662
7663 /* ffestc_R838 -- ASSIGN statement
7664
7665    ffestc_R838(label_token,target_variable,target_token);
7666
7667    Make sure label_token identifies a valid label for an assignment.  Update
7668    that label's info to indicate it is the source of an assignment.  Update
7669    target_variable's info to indicate it is the target the assignment of that
7670    label.  */
7671
7672 void
7673 ffestc_R838 (ffelexToken label_token, ffebld target,
7674              ffelexToken target_token UNUSED)
7675 {
7676   ffelab label;
7677
7678   ffestc_check_simple_ ();
7679   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7680     return;
7681   ffestc_labeldef_branch_begin_ ();
7682
7683   /* Mark target symbol as target of an ASSIGN.  */
7684   if (ffebld_op (target) == FFEBLD_opSYMTER)
7685     ffesymbol_set_assigned (ffebld_symter (target), TRUE);
7686
7687   if (ffestc_labelref_is_assignable_ (label_token, &label))
7688     ffestd_R838 (label, target);
7689
7690   if (ffestc_shriek_after1_ != NULL)
7691     (*ffestc_shriek_after1_) (TRUE);
7692   ffestc_labeldef_branch_end_ ();
7693 }
7694
7695 /* ffestc_R839 -- Assigned GOTO statement
7696
7697    ffestc_R839(target,target_token,label_list);
7698
7699    Make sure label_list identifies valid labels for a GOTO.  Update
7700    each label's info to indicate it is the target of a GOTO.  */
7701
7702 void
7703 ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
7704              ffesttTokenList label_toks)
7705 {
7706   ffesttTokenItem ti;
7707   bool ok = TRUE;
7708   int i;
7709   ffelab *labels;
7710
7711   ffestc_check_simple_ ();
7712   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7713     return;
7714   ffestc_labeldef_notloop_begin_ ();
7715
7716   if (label_toks == NULL)
7717     {
7718       labels = NULL;
7719       i = 0;
7720     }
7721   else
7722     {
7723       labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
7724                     sizeof (*labels) * ffestt_tokenlist_count (label_toks));
7725
7726       for (ti = label_toks->first, i = 0;
7727            ti != (ffesttTokenItem) &label_toks->first;
7728            ti = ti->next, ++i)
7729         {
7730           if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
7731             {
7732               ok = FALSE;
7733               break;
7734             }
7735         }
7736     }
7737
7738   if (ok)
7739     ffestd_R839 (target, labels, i);
7740
7741   if (ffestc_shriek_after1_ != NULL)
7742     (*ffestc_shriek_after1_) (TRUE);
7743
7744   /* notloop's that are actionif's can be the target of a loop-end
7745      statement if they're in the "then" part of a logical IF, as
7746      in "DO 10", "10 IF (...) GOTO I".  */
7747
7748   ffestc_labeldef_branch_end_ ();
7749 }
7750
7751 /* ffestc_R840 -- Arithmetic IF statement
7752
7753    ffestc_R840(expr,expr_token,neg,zero,pos);
7754
7755    Make sure the labels are valid; implement.  */
7756
7757 void
7758 ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
7759              ffelexToken neg_token, ffelexToken zero_token,
7760              ffelexToken pos_token)
7761 {
7762   ffelab neg;
7763   ffelab zero;
7764   ffelab pos;
7765
7766   ffestc_check_simple_ ();
7767   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7768     return;
7769   ffestc_labeldef_notloop_begin_ ();
7770
7771   if (ffestc_labelref_is_branch_ (neg_token, &neg)
7772       && ffestc_labelref_is_branch_ (zero_token, &zero)
7773       && ffestc_labelref_is_branch_ (pos_token, &pos))
7774     ffestd_R840 (expr, neg, zero, pos);
7775
7776   if (ffestc_shriek_after1_ != NULL)
7777     (*ffestc_shriek_after1_) (TRUE);
7778
7779   /* notloop's that are actionif's can be the target of a loop-end
7780      statement if they're in the "then" part of a logical IF, as
7781      in "DO 10", "10 IF (...) GOTO (100,200,300), I".  */
7782
7783   ffestc_labeldef_branch_end_ ();
7784 }
7785
7786 /* ffestc_R841 -- CONTINUE statement
7787
7788    ffestc_R841();  */
7789
7790 void
7791 ffestc_R841 (void)
7792 {
7793   ffestc_check_simple_ ();
7794
7795   if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
7796     return;
7797
7798   ffestc_labeldef_branch_begin_ ();
7799
7800   ffestd_R841 (FALSE);
7801
7802   if (ffestc_shriek_after1_ != NULL)
7803     (*ffestc_shriek_after1_) (TRUE);
7804   ffestc_labeldef_branch_end_ ();
7805 }
7806
7807 /* ffestc_R842 -- STOP statement
7808
7809    ffestc_R842(expr,expr_token);
7810
7811    Make sure statement is valid here; implement.  expr and expr_token are
7812    both NULL if there was no expression.  */
7813
7814 void
7815 ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
7816 {
7817   ffestc_check_simple_ ();
7818   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7819     return;
7820   ffestc_labeldef_notloop_begin_ ();
7821
7822   ffestd_R842 (expr);
7823
7824   if (ffestc_shriek_after1_ != NULL)
7825     (*ffestc_shriek_after1_) (TRUE);
7826
7827   /* notloop's that are actionif's can be the target of a loop-end
7828      statement if they're in the "then" part of a logical IF, as
7829      in "DO 10", "10 IF (...) STOP".  */
7830
7831   ffestc_labeldef_branch_end_ ();
7832 }
7833
7834 /* ffestc_R843 -- PAUSE statement
7835
7836    ffestc_R843(expr,expr_token);
7837
7838    Make sure statement is valid here; implement.  expr and expr_token are
7839    both NULL if there was no expression.  */
7840
7841 void
7842 ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
7843 {
7844   ffestc_check_simple_ ();
7845   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7846     return;
7847   ffestc_labeldef_branch_begin_ ();
7848
7849   ffestd_R843 (expr);
7850
7851   if (ffestc_shriek_after1_ != NULL)
7852     (*ffestc_shriek_after1_) (TRUE);
7853   ffestc_labeldef_branch_end_ ();
7854 }
7855
7856 /* ffestc_R904 -- OPEN statement
7857
7858    ffestc_R904();
7859
7860    Make sure an OPEN is valid in the current context, and implement it.  */
7861
7862 void
7863 ffestc_R904 (void)
7864 {
7865   int i;
7866   int expect_file;
7867   static const char *const status_strs[] =
7868   {
7869     "New",
7870     "Old",
7871     "Replace",
7872     "Scratch",
7873     "Unknown"
7874   };
7875   static const char *const access_strs[] =
7876   {
7877     "Append",
7878     "Direct",
7879     "Keyed",
7880     "Sequential"
7881   };
7882   static const char *const blank_strs[] =
7883   {
7884     "Null",
7885     "Zero"
7886   };
7887   static const char *const carriagecontrol_strs[] =
7888   {
7889     "Fortran",
7890     "List",
7891     "None"
7892   };
7893   static const char *const dispose_strs[] =
7894   {
7895     "Delete",
7896     "Keep",
7897     "Print",
7898     "Print/Delete",
7899     "Save",
7900     "Submit",
7901     "Submit/Delete"
7902   };
7903   static const char *const form_strs[] =
7904   {
7905     "Formatted",
7906     "Unformatted"
7907   };
7908   static const char *const organization_strs[] =
7909   {
7910     "Indexed",
7911     "Relative",
7912     "Sequential"
7913   };
7914   static const char *const position_strs[] =
7915   {
7916     "Append",
7917     "AsIs",
7918     "Rewind"
7919   };
7920   static const char *const action_strs[] =
7921   {
7922     "Read",
7923     "ReadWrite",
7924     "Write"
7925   };
7926   static const char *const delim_strs[] =
7927   {
7928     "Apostrophe",
7929     "None",
7930     "Quote"
7931   };
7932   static const char *const recordtype_strs[] =
7933   {
7934     "Fixed",
7935     "Segmented",
7936     "Stream",
7937     "Stream_CR",
7938     "Stream_LF",
7939     "Variable"
7940   };
7941   static const char *const pad_strs[] =
7942   {
7943     "No",
7944     "Yes"
7945   };
7946
7947   ffestc_check_simple_ ();
7948   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
7949     return;
7950   ffestc_labeldef_branch_begin_ ();
7951
7952   if (ffestc_subr_is_branch_
7953       (&ffestp_file.open.open_spec[FFESTP_openixERR])
7954       && ffestc_subr_is_present_ ("UNIT",
7955                             &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
7956     {
7957       i = ffestc_subr_binsrch_ (status_strs,
7958                                 ARRAY_SIZE (status_strs),
7959                            &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
7960                                 "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
7961       switch (i)
7962         {
7963         case 0:         /* Unknown. */
7964         case 5:         /* UNKNOWN. */
7965           expect_file = 2;      /* Unknown, don't care about FILE=. */
7966           break;
7967
7968         case 1:         /* NEW. */
7969         case 2:         /* OLD. */
7970           if (ffe_is_pedantic ())
7971             expect_file = 1;    /* Yes, need FILE=. */
7972           else
7973             expect_file = 2;    /* f2clib doesn't care about FILE=. */
7974           break;
7975
7976         case 3:         /* REPLACE. */
7977           expect_file = 1;      /* Yes, need FILE=. */
7978           break;
7979
7980         case 4:         /* SCRATCH. */
7981           expect_file = 0;      /* No, disallow FILE=. */
7982           break;
7983
7984         default:
7985           assert ("invalid _binsrch_ result" == NULL);
7986           expect_file = 0;
7987           break;
7988         }
7989       if ((expect_file == 0)
7990           && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
7991         {
7992           ffebad_start (FFEBAD_CONFLICTING_SPECS);
7993           assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
7994           if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
7995             {
7996               ffebad_here (0, ffelex_token_where_line
7997                          (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
7998                            ffelex_token_where_column
7999                         (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
8000             }
8001           else
8002             {
8003               ffebad_here (0, ffelex_token_where_line
8004                       (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
8005                            ffelex_token_where_column
8006                      (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
8007             }
8008           assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
8009           if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
8010             {
8011               ffebad_here (1, ffelex_token_where_line
8012                        (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
8013                            ffelex_token_where_column
8014                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
8015             }
8016           else
8017             {
8018               ffebad_here (1, ffelex_token_where_line
8019                     (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
8020                            ffelex_token_where_column
8021                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
8022             }
8023           ffebad_finish ();
8024         }
8025       else if ((expect_file == 1)
8026         && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
8027         {
8028           ffebad_start (FFEBAD_MISSING_SPECIFIER);
8029           assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
8030           if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
8031             {
8032               ffebad_here (0, ffelex_token_where_line
8033                        (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
8034                            ffelex_token_where_column
8035                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
8036             }
8037           else
8038             {
8039               ffebad_here (0, ffelex_token_where_line
8040                     (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
8041                            ffelex_token_where_column
8042                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
8043             }
8044           ffebad_string ("FILE=");
8045           ffebad_finish ();
8046         }
8047
8048       ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
8049                             &ffestp_file.open.open_spec[FFESTP_openixACCESS],
8050                             "APPEND, DIRECT, KEYED, or SEQUENTIAL");
8051
8052       ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
8053                             &ffestp_file.open.open_spec[FFESTP_openixBLANK],
8054                             "NULL or ZERO");
8055
8056       ffestc_subr_binsrch_ (carriagecontrol_strs,
8057                             ARRAY_SIZE (carriagecontrol_strs),
8058                   &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
8059                             "FORTRAN, LIST, or NONE");
8060
8061       ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
8062                           &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
8063        "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
8064
8065       ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
8066                             &ffestp_file.open.open_spec[FFESTP_openixFORM],
8067                             "FORMATTED or UNFORMATTED");
8068
8069       ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
8070                      &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
8071                             "INDEXED, RELATIVE, or SEQUENTIAL");
8072
8073       ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
8074                          &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
8075                             "APPEND, ASIS, or REWIND");
8076
8077       ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
8078                             &ffestp_file.open.open_spec[FFESTP_openixACTION],
8079                             "READ, READWRITE, or WRITE");
8080
8081       ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
8082                             &ffestp_file.open.open_spec[FFESTP_openixDELIM],
8083                             "APOSTROPHE, NONE, or QUOTE");
8084
8085       ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
8086                        &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
8087              "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
8088
8089       ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
8090                             &ffestp_file.open.open_spec[FFESTP_openixPAD],
8091                             "NO or YES");
8092
8093       ffestd_R904 ();
8094     }
8095
8096   if (ffestc_shriek_after1_ != NULL)
8097     (*ffestc_shriek_after1_) (TRUE);
8098   ffestc_labeldef_branch_end_ ();
8099 }
8100
8101 /* ffestc_R907 -- CLOSE statement
8102
8103    ffestc_R907();
8104
8105    Make sure a CLOSE is valid in the current context, and implement it.  */
8106
8107 void
8108 ffestc_R907 (void)
8109 {
8110   static const char *const status_strs[] =
8111   {
8112     "Delete",
8113     "Keep",
8114     "Print",
8115     "Print/Delete",
8116     "Save",
8117     "Submit",
8118     "Submit/Delete"
8119   };
8120
8121   ffestc_check_simple_ ();
8122   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8123     return;
8124   ffestc_labeldef_branch_begin_ ();
8125
8126   if (ffestc_subr_is_branch_
8127       (&ffestp_file.close.close_spec[FFESTP_closeixERR])
8128       && ffestc_subr_is_present_ ("UNIT",
8129                          &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
8130     {
8131       ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
8132                         &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
8133        "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
8134
8135       ffestd_R907 ();
8136     }
8137
8138   if (ffestc_shriek_after1_ != NULL)
8139     (*ffestc_shriek_after1_) (TRUE);
8140   ffestc_labeldef_branch_end_ ();
8141 }
8142
8143 /* ffestc_R909_start -- READ(...) statement list begin
8144
8145    ffestc_R909_start(FALSE);
8146
8147    Verify that READ is valid here, and begin accepting items in the
8148    list.  */
8149
8150 void
8151 ffestc_R909_start (bool only_format)
8152 {
8153   ffestvUnit unit;
8154   ffestvFormat format;
8155   bool rec;
8156   bool key;
8157   ffestpReadIx keyn;
8158   ffestpReadIx spec1;
8159   ffestpReadIx spec2;
8160
8161   ffestc_check_start_ ();
8162   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8163     {
8164       ffestc_ok_ = FALSE;
8165       return;
8166     }
8167   ffestc_labeldef_branch_begin_ ();
8168
8169   if (!ffestc_subr_is_format_
8170       (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
8171     {
8172       ffestc_ok_ = FALSE;
8173       return;
8174     }
8175
8176   format = ffestc_subr_format_
8177     (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
8178   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
8179
8180   if (only_format)
8181     {
8182       ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
8183
8184       ffestc_ok_ = TRUE;
8185       return;
8186     }
8187
8188   if (!ffestc_subr_is_branch_
8189       (&ffestp_file.read.read_spec[FFESTP_readixEOR])
8190       || !ffestc_subr_is_branch_
8191       (&ffestp_file.read.read_spec[FFESTP_readixERR])
8192       || !ffestc_subr_is_branch_
8193       (&ffestp_file.read.read_spec[FFESTP_readixEND]))
8194     {
8195       ffestc_ok_ = FALSE;
8196       return;
8197     }
8198
8199   unit = ffestc_subr_unit_
8200     (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
8201   if (unit == FFESTV_unitNONE)
8202     {
8203       ffebad_start (FFEBAD_NO_UNIT_SPEC);
8204       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8205                    ffelex_token_where_column (ffesta_tokens[0]));
8206       ffebad_finish ();
8207       ffestc_ok_ = FALSE;
8208       return;
8209     }
8210
8211   rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
8212
8213   if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
8214     {
8215       key = TRUE;
8216       keyn = spec1 = FFESTP_readixKEYEQ;
8217     }
8218   else
8219     {
8220       key = FALSE;
8221       keyn = spec1 = FFESTP_readix;
8222     }
8223
8224   if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
8225     {
8226       if (key)
8227         {
8228           spec2 = FFESTP_readixKEYGT;
8229         whine:                  /* :::::::::::::::::::: */
8230           ffebad_start (FFEBAD_CONFLICTING_SPECS);
8231           assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
8232           if (ffestp_file.read.read_spec[spec1].kw_present)
8233             {
8234               ffebad_here (0, ffelex_token_where_line
8235                            (ffestp_file.read.read_spec[spec1].kw),
8236                            ffelex_token_where_column
8237                            (ffestp_file.read.read_spec[spec1].kw));
8238             }
8239           else
8240             {
8241               ffebad_here (0, ffelex_token_where_line
8242                            (ffestp_file.read.read_spec[spec1].value),
8243                            ffelex_token_where_column
8244                            (ffestp_file.read.read_spec[spec1].value));
8245             }
8246           assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
8247           if (ffestp_file.read.read_spec[spec2].kw_present)
8248             {
8249               ffebad_here (1, ffelex_token_where_line
8250                            (ffestp_file.read.read_spec[spec2].kw),
8251                            ffelex_token_where_column
8252                            (ffestp_file.read.read_spec[spec2].kw));
8253             }
8254           else
8255             {
8256               ffebad_here (1, ffelex_token_where_line
8257                            (ffestp_file.read.read_spec[spec2].value),
8258                            ffelex_token_where_column
8259                            (ffestp_file.read.read_spec[spec2].value));
8260             }
8261           ffebad_finish ();
8262           ffestc_ok_ = FALSE;
8263           return;
8264         }
8265       key = TRUE;
8266       keyn = spec1 = FFESTP_readixKEYGT;
8267     }
8268
8269   if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
8270     {
8271       if (key)
8272         {
8273           spec2 = FFESTP_readixKEYGT;
8274           goto whine;           /* :::::::::::::::::::: */
8275         }
8276       key = TRUE;
8277       keyn = FFESTP_readixKEYGT;
8278     }
8279
8280   if (rec)
8281     {
8282       spec1 = FFESTP_readixREC;
8283       if (key)
8284         {
8285           spec2 = keyn;
8286           goto whine;           /* :::::::::::::::::::: */
8287         }
8288       if (unit == FFESTV_unitCHAREXPR)
8289         {
8290           spec2 = FFESTP_readixUNIT;
8291           goto whine;           /* :::::::::::::::::::: */
8292         }
8293       if ((format == FFESTV_formatASTERISK)
8294           || (format == FFESTV_formatNAMELIST))
8295         {
8296           spec2 = FFESTP_readixFORMAT;
8297           goto whine;           /* :::::::::::::::::::: */
8298         }
8299       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
8300         {
8301           spec2 = FFESTP_readixADVANCE;
8302           goto whine;           /* :::::::::::::::::::: */
8303         }
8304       if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
8305         {
8306           spec2 = FFESTP_readixEND;
8307           goto whine;           /* :::::::::::::::::::: */
8308         }
8309       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
8310         {
8311           spec2 = FFESTP_readixNULLS;
8312           goto whine;           /* :::::::::::::::::::: */
8313         }
8314     }
8315   else if (key)
8316     {
8317       spec1 = keyn;
8318       if (unit == FFESTV_unitCHAREXPR)
8319         {
8320           spec2 = FFESTP_readixUNIT;
8321           goto whine;           /* :::::::::::::::::::: */
8322         }
8323       if ((format == FFESTV_formatASTERISK)
8324           || (format == FFESTV_formatNAMELIST))
8325         {
8326           spec2 = FFESTP_readixFORMAT;
8327           goto whine;           /* :::::::::::::::::::: */
8328         }
8329       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
8330         {
8331           spec2 = FFESTP_readixADVANCE;
8332           goto whine;           /* :::::::::::::::::::: */
8333         }
8334       if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
8335         {
8336           spec2 = FFESTP_readixEND;
8337           goto whine;           /* :::::::::::::::::::: */
8338         }
8339       if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
8340         {
8341           spec2 = FFESTP_readixEOR;
8342           goto whine;           /* :::::::::::::::::::: */
8343         }
8344       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
8345         {
8346           spec2 = FFESTP_readixNULLS;
8347           goto whine;           /* :::::::::::::::::::: */
8348         }
8349       if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
8350         {
8351           spec2 = FFESTP_readixREC;
8352           goto whine;           /* :::::::::::::::::::: */
8353         }
8354       if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
8355         {
8356           spec2 = FFESTP_readixSIZE;
8357           goto whine;           /* :::::::::::::::::::: */
8358         }
8359     }
8360   else
8361     {                           /* Sequential/Internal. */
8362       if (unit == FFESTV_unitCHAREXPR)
8363         {                       /* Internal file. */
8364           spec1 = FFESTP_readixUNIT;
8365           if (format == FFESTV_formatNAMELIST)
8366             {
8367               spec2 = FFESTP_readixFORMAT;
8368               goto whine;       /* :::::::::::::::::::: */
8369             }
8370           if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
8371             {
8372               spec2 = FFESTP_readixADVANCE;
8373               goto whine;       /* :::::::::::::::::::: */
8374             }
8375         }
8376       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
8377         {                       /* ADVANCE= specified. */
8378           spec1 = FFESTP_readixADVANCE;
8379           if (format == FFESTV_formatNONE)
8380             {
8381               ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
8382               ffebad_here (0, ffelex_token_where_line
8383                            (ffestp_file.read.read_spec[spec1].kw),
8384                            ffelex_token_where_column
8385                            (ffestp_file.read.read_spec[spec1].kw));
8386               ffebad_finish ();
8387
8388               ffestc_ok_ = FALSE;
8389               return;
8390             }
8391           if (format == FFESTV_formatNAMELIST)
8392             {
8393               spec2 = FFESTP_readixFORMAT;
8394               goto whine;       /* :::::::::::::::::::: */
8395             }
8396         }
8397       if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
8398         {                       /* EOR= specified. */
8399           spec1 = FFESTP_readixEOR;
8400           if (ffestc_subr_speccmp_ ("No",
8401                           &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
8402                                     NULL, NULL) != 0)
8403             {
8404               goto whine_advance;       /* :::::::::::::::::::: */
8405             }
8406         }
8407       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
8408         {                       /* NULLS= specified. */
8409           spec1 = FFESTP_readixNULLS;
8410           if (format != FFESTV_formatASTERISK)
8411             {
8412               spec2 = FFESTP_readixFORMAT;
8413               goto whine;       /* :::::::::::::::::::: */
8414             }
8415         }
8416       if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
8417         {                       /* SIZE= specified. */
8418           spec1 = FFESTP_readixSIZE;
8419           if (ffestc_subr_speccmp_ ("No",
8420                           &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
8421                                     NULL, NULL) != 0)
8422             {
8423             whine_advance:      /* :::::::::::::::::::: */
8424               if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
8425                   .kw_or_val_present)
8426                 {
8427                   ffebad_start (FFEBAD_CONFLICTING_SPECS);
8428                   ffebad_here (0, ffelex_token_where_line
8429                                (ffestp_file.read.read_spec[spec1].kw),
8430                                ffelex_token_where_column
8431                                (ffestp_file.read.read_spec[spec1].kw));
8432                   ffebad_here (1, ffelex_token_where_line
8433                       (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
8434                                ffelex_token_where_column
8435                      (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
8436                   ffebad_finish ();
8437                 }
8438               else
8439                 {
8440                   ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
8441                   ffebad_here (0, ffelex_token_where_line
8442                                (ffestp_file.read.read_spec[spec1].kw),
8443                                ffelex_token_where_column
8444                                (ffestp_file.read.read_spec[spec1].kw));
8445                   ffebad_finish ();
8446                 }
8447
8448               ffestc_ok_ = FALSE;
8449               return;
8450             }
8451         }
8452     }
8453
8454   if (unit == FFESTV_unitCHAREXPR)
8455     ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
8456   else
8457     ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
8458
8459   ffestd_R909_start (FALSE, unit, format, rec, key);
8460
8461   ffestc_ok_ = TRUE;
8462 }
8463
8464 /* ffestc_R909_item -- READ statement i/o item
8465
8466    ffestc_R909_item(expr,expr_token);
8467
8468    Implement output-list expression.  */
8469
8470 void
8471 ffestc_R909_item (ffebld expr, ffelexToken expr_token)
8472 {
8473   ffestc_check_item_ ();
8474   if (!ffestc_ok_)
8475     return;
8476
8477   if (ffestc_namelist_ != 0)
8478     {
8479       if (ffestc_namelist_ == 1)
8480         {
8481           ffestc_namelist_ = 2;
8482           ffebad_start (FFEBAD_NAMELIST_ITEMS);
8483           ffebad_here (0, ffelex_token_where_line (expr_token),
8484                        ffelex_token_where_column (expr_token));
8485           ffebad_finish ();
8486         }
8487       return;
8488     }
8489
8490   ffestd_R909_item (expr, expr_token);
8491 }
8492
8493 /* ffestc_R909_finish -- READ statement list complete
8494
8495    ffestc_R909_finish();
8496
8497    Just wrap up any local activities.  */
8498
8499 void
8500 ffestc_R909_finish (void)
8501 {
8502   ffestc_check_finish_ ();
8503   if (!ffestc_ok_)
8504     return;
8505
8506   ffestd_R909_finish ();
8507
8508   if (ffestc_shriek_after1_ != NULL)
8509     (*ffestc_shriek_after1_) (TRUE);
8510   ffestc_labeldef_branch_end_ ();
8511 }
8512
8513 /* ffestc_R910_start -- WRITE(...) statement list begin
8514
8515    ffestc_R910_start();
8516
8517    Verify that WRITE is valid here, and begin accepting items in the
8518    list.  */
8519
8520 void
8521 ffestc_R910_start (void)
8522 {
8523   ffestvUnit unit;
8524   ffestvFormat format;
8525   bool rec;
8526   ffestpWriteIx spec1;
8527   ffestpWriteIx spec2;
8528
8529   ffestc_check_start_ ();
8530   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8531     {
8532       ffestc_ok_ = FALSE;
8533       return;
8534     }
8535   ffestc_labeldef_branch_begin_ ();
8536
8537   if (!ffestc_subr_is_branch_
8538       (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
8539       || !ffestc_subr_is_branch_
8540       (&ffestp_file.write.write_spec[FFESTP_writeixERR])
8541       || !ffestc_subr_is_format_
8542       (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
8543     {
8544       ffestc_ok_ = FALSE;
8545       return;
8546     }
8547
8548   format = ffestc_subr_format_
8549     (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
8550   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
8551
8552   unit = ffestc_subr_unit_
8553     (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
8554   if (unit == FFESTV_unitNONE)
8555     {
8556       ffebad_start (FFEBAD_NO_UNIT_SPEC);
8557       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8558                    ffelex_token_where_column (ffesta_tokens[0]));
8559       ffebad_finish ();
8560       ffestc_ok_ = FALSE;
8561       return;
8562     }
8563
8564   rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
8565
8566   if (rec)
8567     {
8568       spec1 = FFESTP_writeixREC;
8569       if (unit == FFESTV_unitCHAREXPR)
8570         {
8571           spec2 = FFESTP_writeixUNIT;
8572         whine:                  /* :::::::::::::::::::: */
8573           ffebad_start (FFEBAD_CONFLICTING_SPECS);
8574           assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
8575           if (ffestp_file.write.write_spec[spec1].kw_present)
8576             {
8577               ffebad_here (0, ffelex_token_where_line
8578                            (ffestp_file.write.write_spec[spec1].kw),
8579                            ffelex_token_where_column
8580                            (ffestp_file.write.write_spec[spec1].kw));
8581             }
8582           else
8583             {
8584               ffebad_here (0, ffelex_token_where_line
8585                            (ffestp_file.write.write_spec[spec1].value),
8586                            ffelex_token_where_column
8587                            (ffestp_file.write.write_spec[spec1].value));
8588             }
8589           assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
8590           if (ffestp_file.write.write_spec[spec2].kw_present)
8591             {
8592               ffebad_here (1, ffelex_token_where_line
8593                            (ffestp_file.write.write_spec[spec2].kw),
8594                            ffelex_token_where_column
8595                            (ffestp_file.write.write_spec[spec2].kw));
8596             }
8597           else
8598             {
8599               ffebad_here (1, ffelex_token_where_line
8600                            (ffestp_file.write.write_spec[spec2].value),
8601                            ffelex_token_where_column
8602                            (ffestp_file.write.write_spec[spec2].value));
8603             }
8604           ffebad_finish ();
8605           ffestc_ok_ = FALSE;
8606           return;
8607         }
8608       if ((format == FFESTV_formatASTERISK)
8609           || (format == FFESTV_formatNAMELIST))
8610         {
8611           spec2 = FFESTP_writeixFORMAT;
8612           goto whine;           /* :::::::::::::::::::: */
8613         }
8614       if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
8615         {
8616           spec2 = FFESTP_writeixADVANCE;
8617           goto whine;           /* :::::::::::::::::::: */
8618         }
8619     }
8620   else
8621     {                           /* Sequential/Indexed/Internal. */
8622       if (unit == FFESTV_unitCHAREXPR)
8623         {                       /* Internal file. */
8624           spec1 = FFESTP_writeixUNIT;
8625           if (format == FFESTV_formatNAMELIST)
8626             {
8627               spec2 = FFESTP_writeixFORMAT;
8628               goto whine;       /* :::::::::::::::::::: */
8629             }
8630           if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
8631             {
8632               spec2 = FFESTP_writeixADVANCE;
8633               goto whine;       /* :::::::::::::::::::: */
8634             }
8635         }
8636       if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
8637         {                       /* ADVANCE= specified. */
8638           spec1 = FFESTP_writeixADVANCE;
8639           if (format == FFESTV_formatNONE)
8640             {
8641               ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
8642               ffebad_here (0, ffelex_token_where_line
8643                            (ffestp_file.write.write_spec[spec1].kw),
8644                            ffelex_token_where_column
8645                            (ffestp_file.write.write_spec[spec1].kw));
8646               ffebad_finish ();
8647
8648               ffestc_ok_ = FALSE;
8649               return;
8650             }
8651           if (format == FFESTV_formatNAMELIST)
8652             {
8653               spec2 = FFESTP_writeixFORMAT;
8654               goto whine;       /* :::::::::::::::::::: */
8655             }
8656         }
8657       if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
8658         {                       /* EOR= specified. */
8659           spec1 = FFESTP_writeixEOR;
8660           if (ffestc_subr_speccmp_ ("No",
8661                        &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
8662                                     NULL, NULL) != 0)
8663             {
8664               if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
8665                   .kw_or_val_present)
8666                 {
8667                   ffebad_start (FFEBAD_CONFLICTING_SPECS);
8668                   ffebad_here (0, ffelex_token_where_line
8669                                (ffestp_file.write.write_spec[spec1].kw),
8670                                ffelex_token_where_column
8671                                (ffestp_file.write.write_spec[spec1].kw));
8672                   ffebad_here (1, ffelex_token_where_line
8673                    (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
8674                                ffelex_token_where_column
8675                   (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
8676                   ffebad_finish ();
8677                 }
8678               else
8679                 {
8680                   ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
8681                   ffebad_here (0, ffelex_token_where_line
8682                                (ffestp_file.write.write_spec[spec1].kw),
8683                                ffelex_token_where_column
8684                                (ffestp_file.write.write_spec[spec1].kw));
8685                   ffebad_finish ();
8686                 }
8687
8688               ffestc_ok_ = FALSE;
8689               return;
8690             }
8691         }
8692     }
8693
8694   if (unit == FFESTV_unitCHAREXPR)
8695     ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
8696   else
8697     ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
8698
8699   ffestd_R910_start (unit, format, rec);
8700
8701   ffestc_ok_ = TRUE;
8702 }
8703
8704 /* ffestc_R910_item -- WRITE statement i/o item
8705
8706    ffestc_R910_item(expr,expr_token);
8707
8708    Implement output-list expression.  */
8709
8710 void
8711 ffestc_R910_item (ffebld expr, ffelexToken expr_token)
8712 {
8713   ffestc_check_item_ ();
8714   if (!ffestc_ok_)
8715     return;
8716
8717   if (ffestc_namelist_ != 0)
8718     {
8719       if (ffestc_namelist_ == 1)
8720         {
8721           ffestc_namelist_ = 2;
8722           ffebad_start (FFEBAD_NAMELIST_ITEMS);
8723           ffebad_here (0, ffelex_token_where_line (expr_token),
8724                        ffelex_token_where_column (expr_token));
8725           ffebad_finish ();
8726         }
8727       return;
8728     }
8729
8730   ffestd_R910_item (expr, expr_token);
8731 }
8732
8733 /* ffestc_R910_finish -- WRITE statement list complete
8734
8735    ffestc_R910_finish();
8736
8737    Just wrap up any local activities.  */
8738
8739 void
8740 ffestc_R910_finish (void)
8741 {
8742   ffestc_check_finish_ ();
8743   if (!ffestc_ok_)
8744     return;
8745
8746   ffestd_R910_finish ();
8747
8748   if (ffestc_shriek_after1_ != NULL)
8749     (*ffestc_shriek_after1_) (TRUE);
8750   ffestc_labeldef_branch_end_ ();
8751 }
8752
8753 /* ffestc_R911_start -- PRINT(...) statement list begin
8754
8755    ffestc_R911_start();
8756
8757    Verify that PRINT is valid here, and begin accepting items in the
8758    list.  */
8759
8760 void
8761 ffestc_R911_start (void)
8762 {
8763   ffestvFormat format;
8764
8765   ffestc_check_start_ ();
8766   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8767     {
8768       ffestc_ok_ = FALSE;
8769       return;
8770     }
8771   ffestc_labeldef_branch_begin_ ();
8772
8773   if (!ffestc_subr_is_format_
8774       (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
8775     {
8776       ffestc_ok_ = FALSE;
8777       return;
8778     }
8779
8780   format = ffestc_subr_format_
8781     (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
8782   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
8783
8784   ffestd_R911_start (format);
8785
8786   ffestc_ok_ = TRUE;
8787 }
8788
8789 /* ffestc_R911_item -- PRINT statement i/o item
8790
8791    ffestc_R911_item(expr,expr_token);
8792
8793    Implement output-list expression.  */
8794
8795 void
8796 ffestc_R911_item (ffebld expr, ffelexToken expr_token)
8797 {
8798   ffestc_check_item_ ();
8799   if (!ffestc_ok_)
8800     return;
8801
8802   if (ffestc_namelist_ != 0)
8803     {
8804       if (ffestc_namelist_ == 1)
8805         {
8806           ffestc_namelist_ = 2;
8807           ffebad_start (FFEBAD_NAMELIST_ITEMS);
8808           ffebad_here (0, ffelex_token_where_line (expr_token),
8809                        ffelex_token_where_column (expr_token));
8810           ffebad_finish ();
8811         }
8812       return;
8813     }
8814
8815   ffestd_R911_item (expr, expr_token);
8816 }
8817
8818 /* ffestc_R911_finish -- PRINT statement list complete
8819
8820    ffestc_R911_finish();
8821
8822    Just wrap up any local activities.  */
8823
8824 void
8825 ffestc_R911_finish (void)
8826 {
8827   ffestc_check_finish_ ();
8828   if (!ffestc_ok_)
8829     return;
8830
8831   ffestd_R911_finish ();
8832
8833   if (ffestc_shriek_after1_ != NULL)
8834     (*ffestc_shriek_after1_) (TRUE);
8835   ffestc_labeldef_branch_end_ ();
8836 }
8837
8838 /* ffestc_R919 -- BACKSPACE statement
8839
8840    ffestc_R919();
8841
8842    Make sure a BACKSPACE is valid in the current context, and implement it.  */
8843
8844 void
8845 ffestc_R919 (void)
8846 {
8847   ffestc_check_simple_ ();
8848   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8849     return;
8850   ffestc_labeldef_branch_begin_ ();
8851
8852   if (ffestc_subr_is_branch_
8853       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
8854       && ffestc_subr_is_present_ ("UNIT",
8855                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
8856     ffestd_R919 ();
8857
8858   if (ffestc_shriek_after1_ != NULL)
8859     (*ffestc_shriek_after1_) (TRUE);
8860   ffestc_labeldef_branch_end_ ();
8861 }
8862
8863 /* ffestc_R920 -- ENDFILE statement
8864
8865    ffestc_R920();
8866
8867    Make sure a ENDFILE is valid in the current context, and implement it.  */
8868
8869 void
8870 ffestc_R920 (void)
8871 {
8872   ffestc_check_simple_ ();
8873   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8874     return;
8875   ffestc_labeldef_branch_begin_ ();
8876
8877   if (ffestc_subr_is_branch_
8878       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
8879       && ffestc_subr_is_present_ ("UNIT",
8880                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
8881     ffestd_R920 ();
8882
8883   if (ffestc_shriek_after1_ != NULL)
8884     (*ffestc_shriek_after1_) (TRUE);
8885   ffestc_labeldef_branch_end_ ();
8886 }
8887
8888 /* ffestc_R921 -- REWIND statement
8889
8890    ffestc_R921();
8891
8892    Make sure a REWIND is valid in the current context, and implement it.  */
8893
8894 void
8895 ffestc_R921 (void)
8896 {
8897   ffestc_check_simple_ ();
8898   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8899     return;
8900   ffestc_labeldef_branch_begin_ ();
8901
8902   if (ffestc_subr_is_branch_
8903       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
8904       && ffestc_subr_is_present_ ("UNIT",
8905                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
8906     ffestd_R921 ();
8907
8908   if (ffestc_shriek_after1_ != NULL)
8909     (*ffestc_shriek_after1_) (TRUE);
8910   ffestc_labeldef_branch_end_ ();
8911 }
8912
8913 /* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
8914
8915    ffestc_R923A();
8916
8917    Make sure an INQUIRE is valid in the current context, and implement it.  */
8918
8919 void
8920 ffestc_R923A (void)
8921 {
8922   bool by_file;
8923   bool by_unit;
8924
8925   ffestc_check_simple_ ();
8926   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8927     return;
8928   ffestc_labeldef_branch_begin_ ();
8929
8930   if (ffestc_subr_is_branch_
8931       (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
8932     {
8933       by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
8934         .kw_or_val_present;
8935       by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
8936         .kw_or_val_present;
8937       if (by_file && by_unit)
8938         {
8939           ffebad_start (FFEBAD_CONFLICTING_SPECS);
8940           assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
8941           if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
8942             {
8943               ffebad_here (0, ffelex_token_where_line
8944                 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
8945                            ffelex_token_where_column
8946                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
8947             }
8948           else
8949             {
8950               ffebad_here (0, ffelex_token_where_line
8951               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
8952                            ffelex_token_where_column
8953                            (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
8954             }
8955           assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
8956           if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
8957             {
8958               ffebad_here (1, ffelex_token_where_line
8959                 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
8960                            ffelex_token_where_column
8961                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
8962             }
8963           else
8964             {
8965               ffebad_here (1, ffelex_token_where_line
8966               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
8967                            ffelex_token_where_column
8968                            (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
8969             }
8970           ffebad_finish ();
8971         }
8972       else if (!by_file && !by_unit)
8973         {
8974           ffebad_start (FFEBAD_MISSING_SPECIFIER);
8975           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8976                        ffelex_token_where_column (ffesta_tokens[0]));
8977           ffebad_string ("UNIT= or FILE=");
8978           ffebad_finish ();
8979         }
8980       else
8981         ffestd_R923A (by_file);
8982     }
8983
8984   if (ffestc_shriek_after1_ != NULL)
8985     (*ffestc_shriek_after1_) (TRUE);
8986   ffestc_labeldef_branch_end_ ();
8987 }
8988
8989 /* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
8990
8991    ffestc_R923B_start();
8992
8993    Verify that INQUIRE is valid here, and begin accepting items in the
8994    list.  */
8995
8996 void
8997 ffestc_R923B_start (void)
8998 {
8999   ffestc_check_start_ ();
9000   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9001     {
9002       ffestc_ok_ = FALSE;
9003       return;
9004     }
9005   ffestc_labeldef_branch_begin_ ();
9006
9007   ffestd_R923B_start ();
9008
9009   ffestc_ok_ = TRUE;
9010 }
9011
9012 /* ffestc_R923B_item -- INQUIRE statement i/o item
9013
9014    ffestc_R923B_item(expr,expr_token);
9015
9016    Implement output-list expression.  */
9017
9018 void
9019 ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
9020 {
9021   ffestc_check_item_ ();
9022   if (!ffestc_ok_)
9023     return;
9024
9025   ffestd_R923B_item (expr);
9026 }
9027
9028 /* ffestc_R923B_finish -- INQUIRE statement list complete
9029
9030    ffestc_R923B_finish();
9031
9032    Just wrap up any local activities.  */
9033
9034 void
9035 ffestc_R923B_finish (void)
9036 {
9037   ffestc_check_finish_ ();
9038   if (!ffestc_ok_)
9039     return;
9040
9041   ffestd_R923B_finish ();
9042
9043   if (ffestc_shriek_after1_ != NULL)
9044     (*ffestc_shriek_after1_) (TRUE);
9045   ffestc_labeldef_branch_end_ ();
9046 }
9047
9048 /* ffestc_R1001 -- FORMAT statement
9049
9050    ffestc_R1001(format_list);
9051
9052    Make sure format_list is valid.  Update label's info to indicate it is a
9053    FORMAT label, and (perhaps) warn if there is no label!  */
9054
9055 void
9056 ffestc_R1001 (ffesttFormatList f)
9057 {
9058   ffestc_check_simple_ ();
9059   if (ffestc_order_format_ () != FFESTC_orderOK_)
9060     return;
9061   ffestc_labeldef_format_ ();
9062
9063   ffestd_R1001 (f);
9064 }
9065
9066 /* ffestc_R1102 -- PROGRAM statement
9067
9068    ffestc_R1102(name_token);
9069
9070    Make sure ffestc_kind_ identifies an empty block.  Make sure name_token
9071    gives a valid name.  Implement the beginning of a main program.  */
9072
9073 void
9074 ffestc_R1102 (ffelexToken name)
9075 {
9076   ffestw b;
9077   ffesymbol s;
9078
9079   assert (name != NULL);
9080
9081   ffestc_check_simple_ ();
9082   if (ffestc_order_unit_ () != FFESTC_orderOK_)
9083     return;
9084   ffestc_labeldef_useless_ ();
9085
9086   ffestc_blocknum_ = 0;
9087   b = ffestw_update (ffestw_push (NULL));
9088   ffestw_set_top_do (b, NULL);
9089   ffestw_set_state (b, FFESTV_statePROGRAM0);
9090   ffestw_set_blocknum (b, ffestc_blocknum_++);
9091   ffestw_set_shriek (b, ffestc_shriek_end_program_);
9092
9093   ffestw_set_name (b, ffelex_token_use (name));
9094
9095   s = ffesymbol_declare_programunit (name,
9096                                  ffelex_token_where_line (ffesta_tokens[0]),
9097                               ffelex_token_where_column (ffesta_tokens[0]));
9098
9099   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9100     {
9101       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9102       ffesymbol_set_info (s,
9103                           ffeinfo_new (FFEINFO_basictypeNONE,
9104                                        FFEINFO_kindtypeNONE,
9105                                        0,
9106                                        FFEINFO_kindPROGRAM,
9107                                        FFEINFO_whereLOCAL,
9108                                        FFETARGET_charactersizeNONE));
9109       ffesymbol_signal_unreported (s);
9110     }
9111   else
9112     ffesymbol_error (s, name);
9113
9114   ffestd_R1102 (s, name);
9115 }
9116
9117 /* ffestc_R1103 -- END PROGRAM statement
9118
9119    ffestc_R1103(name_token);
9120
9121    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
9122    NULL, make sure name_token gives the correct name.  Implement the end
9123    of the current program unit.  */
9124
9125 void
9126 ffestc_R1103 (ffelexToken name)
9127 {
9128   ffestc_check_simple_ ();
9129   if (ffestc_order_program_ () != FFESTC_orderOK_)
9130     return;
9131   ffestc_labeldef_notloop_ ();
9132
9133   if (name != NULL)
9134     {
9135       if (ffestw_name (ffestw_stack_top ()) == NULL)
9136         {
9137           ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
9138           ffebad_here (0, ffelex_token_where_line (name),
9139                        ffelex_token_where_column (name));
9140           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9141           ffebad_finish ();
9142         }
9143       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
9144         {
9145           ffebad_start (FFEBAD_UNIT_WRONG_NAME);
9146           ffebad_here (0, ffelex_token_where_line (name),
9147                        ffelex_token_where_column (name));
9148           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9149              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9150           ffebad_finish ();
9151         }
9152     }
9153
9154   ffestc_shriek_end_program_ (TRUE);
9155 }
9156
9157 /* ffestc_R1111 -- BLOCK DATA statement
9158
9159    ffestc_R1111(name_token);
9160
9161    Make sure ffestc_kind_ identifies no current program unit.  If not
9162    NULL, make sure name_token gives a valid name.  Implement the beginning
9163    of a block data program unit.  */
9164
9165 void
9166 ffestc_R1111 (ffelexToken name)
9167 {
9168   ffestw b;
9169   ffesymbol s;
9170
9171   ffestc_check_simple_ ();
9172   if (ffestc_order_unit_ () != FFESTC_orderOK_)
9173     return;
9174   ffestc_labeldef_useless_ ();
9175
9176   ffestc_blocknum_ = 0;
9177   b = ffestw_update (ffestw_push (NULL));
9178   ffestw_set_top_do (b, NULL);
9179   ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
9180   ffestw_set_blocknum (b, ffestc_blocknum_++);
9181   ffestw_set_shriek (b, ffestc_shriek_blockdata_);
9182
9183   if (name == NULL)
9184     ffestw_set_name (b, NULL);
9185   else
9186     ffestw_set_name (b, ffelex_token_use (name));
9187
9188   s = ffesymbol_declare_blockdataunit (name,
9189                                  ffelex_token_where_line (ffesta_tokens[0]),
9190                               ffelex_token_where_column (ffesta_tokens[0]));
9191
9192   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9193     {
9194       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9195       ffesymbol_set_info (s,
9196                           ffeinfo_new (FFEINFO_basictypeNONE,
9197                                        FFEINFO_kindtypeNONE,
9198                                        0,
9199                                        FFEINFO_kindBLOCKDATA,
9200                                        FFEINFO_whereLOCAL,
9201                                        FFETARGET_charactersizeNONE));
9202       ffesymbol_signal_unreported (s);
9203     }
9204   else
9205     ffesymbol_error (s, name);
9206
9207   ffestd_R1111 (s, name);
9208 }
9209
9210 /* ffestc_R1112 -- END BLOCK DATA statement
9211
9212    ffestc_R1112(name_token);
9213
9214    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
9215    NULL, make sure name_token gives the correct name.  Implement the end
9216    of the current program unit.  */
9217
9218 void
9219 ffestc_R1112 (ffelexToken name)
9220 {
9221   ffestc_check_simple_ ();
9222   if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
9223     return;
9224   ffestc_labeldef_useless_ ();
9225
9226   if (name != NULL)
9227     {
9228       if (ffestw_name (ffestw_stack_top ()) == NULL)
9229         {
9230           ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
9231           ffebad_here (0, ffelex_token_where_line (name),
9232                        ffelex_token_where_column (name));
9233           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9234           ffebad_finish ();
9235         }
9236       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
9237         {
9238           ffebad_start (FFEBAD_UNIT_WRONG_NAME);
9239           ffebad_here (0, ffelex_token_where_line (name),
9240                        ffelex_token_where_column (name));
9241           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9242              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9243           ffebad_finish ();
9244         }
9245     }
9246
9247   ffestc_shriek_blockdata_ (TRUE);
9248 }
9249
9250 /* ffestc_R1207_start -- EXTERNAL statement list begin
9251
9252    ffestc_R1207_start();
9253
9254    Verify that EXTERNAL is valid here, and begin accepting items in the list.  */
9255
9256 void
9257 ffestc_R1207_start (void)
9258 {
9259   ffestc_check_start_ ();
9260   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
9261     {
9262       ffestc_ok_ = FALSE;
9263       return;
9264     }
9265   ffestc_labeldef_useless_ ();
9266
9267   ffestd_R1207_start ();
9268
9269   ffestc_ok_ = TRUE;
9270 }
9271
9272 /* ffestc_R1207_item -- EXTERNAL statement for name
9273
9274    ffestc_R1207_item(name_token);
9275
9276    Make sure name_token identifies a valid object to be EXTERNALd.  */
9277
9278 void
9279 ffestc_R1207_item (ffelexToken name)
9280 {
9281   ffesymbol s;
9282   ffesymbolAttrs sa;
9283   ffesymbolAttrs na;
9284
9285   ffestc_check_item_ ();
9286   assert (name != NULL);
9287   if (!ffestc_ok_)
9288     return;
9289
9290   s = ffesymbol_declare_local (name, FALSE);
9291   sa = ffesymbol_attrs (s);
9292
9293   /* Figure out what kind of object we've got based on previous declarations
9294      of or references to the object. */
9295
9296   if (!ffesymbol_is_specable (s))
9297     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
9298   else if (sa & FFESYMBOL_attrsANY)
9299     na = FFESYMBOL_attrsANY;
9300   else if (!(sa & ~(FFESYMBOL_attrsDUMMY
9301                     | FFESYMBOL_attrsTYPE)))
9302     na = sa | FFESYMBOL_attrsEXTERNAL;
9303   else
9304     na = FFESYMBOL_attrsetNONE;
9305
9306   /* Now see what we've got for a new object: NONE means a new error cropped
9307      up; ANY means an old error to be ignored; otherwise, everything's ok,
9308      update the object (symbol) and continue on. */
9309
9310   if (na == FFESYMBOL_attrsetNONE)
9311     ffesymbol_error (s, name);
9312   else if (!(na & FFESYMBOL_attrsANY))
9313     {
9314       ffesymbol_set_attrs (s, na);
9315       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
9316       ffesymbol_set_explicitwhere (s, TRUE);
9317       ffesymbol_reference (s, name, FALSE);
9318       ffesymbol_signal_unreported (s);
9319     }
9320
9321   ffestd_R1207_item (name);
9322 }
9323
9324 /* ffestc_R1207_finish -- EXTERNAL statement list complete
9325
9326    ffestc_R1207_finish();
9327
9328    Just wrap up any local activities.  */
9329
9330 void
9331 ffestc_R1207_finish (void)
9332 {
9333   ffestc_check_finish_ ();
9334   if (!ffestc_ok_)
9335     return;
9336
9337   ffestd_R1207_finish ();
9338 }
9339
9340 /* ffestc_R1208_start -- INTRINSIC statement list begin
9341
9342    ffestc_R1208_start();
9343
9344    Verify that INTRINSIC is valid here, and begin accepting items in the list.  */
9345
9346 void
9347 ffestc_R1208_start (void)
9348 {
9349   ffestc_check_start_ ();
9350   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
9351     {
9352       ffestc_ok_ = FALSE;
9353       return;
9354     }
9355   ffestc_labeldef_useless_ ();
9356
9357   ffestd_R1208_start ();
9358
9359   ffestc_ok_ = TRUE;
9360 }
9361
9362 /* ffestc_R1208_item -- INTRINSIC statement for name
9363
9364    ffestc_R1208_item(name_token);
9365
9366    Make sure name_token identifies a valid object to be INTRINSICd.  */
9367
9368 void
9369 ffestc_R1208_item (ffelexToken name)
9370 {
9371   ffesymbol s;
9372   ffesymbolAttrs sa;
9373   ffesymbolAttrs na;
9374   ffeintrinGen gen;
9375   ffeintrinSpec spec;
9376   ffeintrinImp imp;
9377
9378   ffestc_check_item_ ();
9379   assert (name != NULL);
9380   if (!ffestc_ok_)
9381     return;
9382
9383   s = ffesymbol_declare_local (name, TRUE);
9384   sa = ffesymbol_attrs (s);
9385
9386   /* Figure out what kind of object we've got based on previous declarations
9387      of or references to the object. */
9388
9389   if (!ffesymbol_is_specable (s))
9390     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
9391   else if (sa & FFESYMBOL_attrsANY)
9392     na = sa;
9393   else if (!(sa & ~FFESYMBOL_attrsTYPE))
9394     {
9395       if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
9396                                   &gen, &spec, &imp)
9397           && ((imp == FFEINTRIN_impNONE)
9398 #if 0   /* Don't bother with this for now. */
9399               || ((ffeintrin_basictype (spec)
9400                    == ffesymbol_basictype (s))
9401                   && (ffeintrin_kindtype (spec)
9402                       == ffesymbol_kindtype (s)))
9403 #else
9404               || 1
9405 #endif
9406               || !(sa & FFESYMBOL_attrsTYPE)))
9407         na = sa | FFESYMBOL_attrsINTRINSIC;
9408       else
9409         na = FFESYMBOL_attrsetNONE;
9410     }
9411   else
9412     na = FFESYMBOL_attrsetNONE;
9413
9414   /* Now see what we've got for a new object: NONE means a new error cropped
9415      up; ANY means an old error to be ignored; otherwise, everything's ok,
9416      update the object (symbol) and continue on. */
9417
9418   if (na == FFESYMBOL_attrsetNONE)
9419     ffesymbol_error (s, name);
9420   else if (!(na & FFESYMBOL_attrsANY))
9421     {
9422       ffesymbol_set_attrs (s, na);
9423       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9424       ffesymbol_set_generic (s, gen);
9425       ffesymbol_set_specific (s, spec);
9426       ffesymbol_set_implementation (s, imp);
9427       ffesymbol_set_info (s,
9428                           ffeinfo_new (ffesymbol_basictype (s),
9429                                        ffesymbol_kindtype (s),
9430                                        0,
9431                                        FFEINFO_kindNONE,
9432                                        FFEINFO_whereINTRINSIC,
9433                                        ffesymbol_size (s)));
9434       ffesymbol_set_explicitwhere (s, TRUE);
9435       ffesymbol_reference (s, name, TRUE);
9436     }
9437
9438   ffesymbol_signal_unreported (s);
9439
9440   ffestd_R1208_item (name);
9441 }
9442
9443 /* ffestc_R1208_finish -- INTRINSIC statement list complete
9444
9445    ffestc_R1208_finish();
9446
9447    Just wrap up any local activities.  */
9448
9449 void
9450 ffestc_R1208_finish (void)
9451 {
9452   ffestc_check_finish_ ();
9453   if (!ffestc_ok_)
9454     return;
9455
9456   ffestd_R1208_finish ();
9457 }
9458
9459 /* ffestc_R1212 -- CALL statement
9460
9461    ffestc_R1212(expr,expr_token);
9462
9463    Make sure statement is valid here; implement.  */
9464
9465 void
9466 ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
9467 {
9468   ffebld item;                  /* ITEM. */
9469   ffebld labexpr;               /* LABTOK=>LABTER. */
9470   ffelab label;
9471   bool ok;                      /* TRUE if all LABTOKs were ok. */
9472   bool ok1;                     /* TRUE if a particular LABTOK is ok. */
9473
9474   ffestc_check_simple_ ();
9475   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9476     return;
9477   ffestc_labeldef_branch_begin_ ();
9478
9479   if (ffebld_op (expr) != FFEBLD_opSUBRREF)
9480     ffestd_R841 (FALSE);        /* CONTINUE. */
9481   else
9482     {
9483       ok = TRUE;
9484
9485       for (item = ffebld_right (expr);
9486            item != NULL;
9487            item = ffebld_trail (item))
9488         {
9489           if (((labexpr = ffebld_head (item)) != NULL)
9490               && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
9491             {
9492               ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
9493                                                 &label);
9494               ffelex_token_kill (ffebld_labtok (labexpr));
9495               if (!ok1)
9496                 {
9497                   label = NULL;
9498                   ok = FALSE;
9499                 }
9500               ffebld_set_op (labexpr, FFEBLD_opLABTER);
9501               ffebld_set_labter (labexpr, label);
9502             }
9503         }
9504
9505       if (ok)
9506         ffestd_R1212 (expr);
9507     }
9508
9509   if (ffestc_shriek_after1_ != NULL)
9510     (*ffestc_shriek_after1_) (TRUE);
9511   ffestc_labeldef_branch_end_ ();
9512 }
9513
9514 /* ffestc_R1219 -- FUNCTION statement
9515
9516    ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
9517          recursive);
9518
9519    Make sure statement is valid here, register arguments for the
9520    function name, and so on.
9521
9522    06-Apr-90  JCB  2.0
9523       Added the kind, len, and recursive arguments.  */
9524
9525 void
9526 ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
9527               ffelexToken final UNUSED, ffestpType type, ffebld kind,
9528               ffelexToken kindt, ffebld len, ffelexToken lent,
9529               ffelexToken recursive, ffelexToken result)
9530 {
9531   ffestw b;
9532   ffesymbol s;
9533   ffesymbol fs;                 /* FUNCTION symbol when dealing with RESULT
9534                                    symbol. */
9535   ffesymbolAttrs sa;
9536   ffesymbolAttrs na;
9537   ffelexToken res;
9538   bool separate_result;
9539
9540   assert ((funcname != NULL)
9541           && (ffelex_token_type (funcname) == FFELEX_typeNAME));
9542
9543   ffestc_check_simple_ ();
9544   if (ffestc_order_iface_ () != FFESTC_orderOK_)
9545     return;
9546   ffestc_labeldef_useless_ ();
9547
9548   ffestc_blocknum_ = 0;
9549   ffesta_is_entry_valid =
9550     (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
9551   b = ffestw_update (ffestw_push (NULL));
9552   ffestw_set_top_do (b, NULL);
9553   ffestw_set_state (b, FFESTV_stateFUNCTION0);
9554   ffestw_set_blocknum (b, ffestc_blocknum_++);
9555   ffestw_set_shriek (b, ffestc_shriek_function_);
9556   ffestw_set_name (b, ffelex_token_use (funcname));
9557
9558   if (type == FFESTP_typeNone)
9559     {
9560       ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
9561       ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
9562       ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
9563     }
9564   else
9565     {
9566       ffestc_establish_declstmt_ (type, ffesta_tokens[0],
9567                                   kind, kindt, len, lent);
9568       ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
9569     }
9570
9571   separate_result = (result != NULL)
9572     && (ffelex_token_strcmp (funcname, result) != 0);
9573
9574   if (separate_result)
9575     fs = ffesymbol_declare_funcnotresunit (funcname);   /* Global/local. */
9576   else
9577     fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
9578
9579   if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
9580     {
9581       ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
9582       ffesymbol_signal_unreported (fs);
9583
9584       /* Note that .basic_type and .kind_type might be NONE here. */
9585
9586       ffesymbol_set_info (fs,
9587                           ffeinfo_new (ffestc_local_.decl.basic_type,
9588                                        ffestc_local_.decl.kind_type,
9589                                        0,
9590                                        FFEINFO_kindFUNCTION,
9591                                        FFEINFO_whereLOCAL,
9592                                        ffestc_local_.decl.size));
9593
9594       /* Check whether the type info fits the filewide expectations;
9595          set ok flag accordingly.  */
9596
9597       ffesymbol_reference (fs, funcname, FALSE);
9598       if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
9599         ffestc_parent_ok_ = FALSE;
9600       else
9601         ffestc_parent_ok_ = TRUE;
9602     }
9603   else
9604     {
9605       if (ffesymbol_kind (fs) != FFEINFO_kindANY)
9606         ffesymbol_error (fs, funcname);
9607       ffestc_parent_ok_ = FALSE;
9608     }
9609
9610   if (ffestc_parent_ok_)
9611     {
9612       ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
9613       ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
9614       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
9615     }
9616
9617   if (result == NULL)
9618     res = funcname;
9619   else
9620     res = result;
9621
9622   s = ffesymbol_declare_funcresult (res);
9623   sa = ffesymbol_attrs (s);
9624
9625   /* Figure out what kind of object we've got based on previous declarations
9626      of or references to the object. */
9627
9628   if (sa & FFESYMBOL_attrsANY)
9629     na = FFESYMBOL_attrsANY;
9630   else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
9631     na = FFESYMBOL_attrsetNONE;
9632   else
9633     {
9634       na = FFESYMBOL_attrsRESULT;
9635       if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
9636         {
9637           na |= FFESYMBOL_attrsTYPE;
9638           if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
9639               && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
9640             na |= FFESYMBOL_attrsANYLEN;
9641         }
9642     }
9643
9644   /* Now see what we've got for a new object: NONE means a new error cropped
9645      up; ANY means an old error to be ignored; otherwise, everything's ok,
9646      update the object (symbol) and continue on. */
9647
9648   if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
9649     {
9650       if (!(na & FFESYMBOL_attrsANY))
9651         ffesymbol_error (s, res);
9652       ffesymbol_set_funcresult (fs, NULL);
9653       ffesymbol_set_funcresult (s, NULL);
9654       ffestc_parent_ok_ = FALSE;
9655     }
9656   else
9657     {
9658       ffesymbol_set_attrs (s, na);
9659       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
9660       ffesymbol_set_funcresult (fs, s);
9661       ffesymbol_set_funcresult (s, fs);
9662       if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
9663         {
9664           ffesymbol_set_info (s,
9665                               ffeinfo_new (ffestc_local_.decl.basic_type,
9666                                            ffestc_local_.decl.kind_type,
9667                                            0,
9668                                            FFEINFO_kindNONE,
9669                                            FFEINFO_whereNONE,
9670                                            ffestc_local_.decl.size));
9671         }
9672     }
9673
9674   ffesymbol_signal_unreported (fs);
9675
9676   ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
9677                 (recursive != NULL), result, separate_result);
9678 }
9679
9680 /* ffestc_R1221 -- END FUNCTION statement
9681
9682    ffestc_R1221(name_token);
9683
9684    Make sure ffestc_kind_ identifies the current kind of program unit.  If
9685    not NULL, make sure name_token gives the correct name.  Implement the end
9686    of the current program unit.  */
9687
9688 void
9689 ffestc_R1221 (ffelexToken name)
9690 {
9691   ffestc_check_simple_ ();
9692   if (ffestc_order_function_ () != FFESTC_orderOK_)
9693     return;
9694   ffestc_labeldef_notloop_ ();
9695
9696   if ((name != NULL)
9697     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
9698     {
9699       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
9700       ffebad_here (0, ffelex_token_where_line (name),
9701                    ffelex_token_where_column (name));
9702       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9703              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9704       ffebad_finish ();
9705     }
9706
9707   ffestc_shriek_function_ (TRUE);
9708 }
9709
9710 /* ffestc_R1223 -- SUBROUTINE statement
9711
9712    ffestc_R1223(subrname,arglist,ending_token,recursive_token);
9713
9714    Make sure statement is valid here, register arguments for the
9715    subroutine name, and so on.
9716
9717    06-Apr-90  JCB  2.0
9718       Added the recursive argument.  */
9719
9720 void
9721 ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
9722               ffelexToken final, ffelexToken recursive)
9723 {
9724   ffestw b;
9725   ffesymbol s;
9726
9727   assert ((subrname != NULL)
9728           && (ffelex_token_type (subrname) == FFELEX_typeNAME));
9729
9730   ffestc_check_simple_ ();
9731   if (ffestc_order_iface_ () != FFESTC_orderOK_)
9732     return;
9733   ffestc_labeldef_useless_ ();
9734
9735   ffestc_blocknum_ = 0;
9736   ffesta_is_entry_valid
9737     = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
9738   b = ffestw_update (ffestw_push (NULL));
9739   ffestw_set_top_do (b, NULL);
9740   ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
9741   ffestw_set_blocknum (b, ffestc_blocknum_++);
9742   ffestw_set_shriek (b, ffestc_shriek_subroutine_);
9743   ffestw_set_name (b, ffelex_token_use (subrname));
9744
9745   s = ffesymbol_declare_subrunit (subrname);
9746   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9747     {
9748       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9749       ffesymbol_set_info (s,
9750                           ffeinfo_new (FFEINFO_basictypeNONE,
9751                                        FFEINFO_kindtypeNONE,
9752                                        0,
9753                                        FFEINFO_kindSUBROUTINE,
9754                                        FFEINFO_whereLOCAL,
9755                                        FFETARGET_charactersizeNONE));
9756       ffestc_parent_ok_ = TRUE;
9757     }
9758   else
9759     {
9760       if (ffesymbol_kind (s) != FFEINFO_kindANY)
9761         ffesymbol_error (s, subrname);
9762       ffestc_parent_ok_ = FALSE;
9763     }
9764
9765   if (ffestc_parent_ok_)
9766     {
9767       ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
9768       ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
9769       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
9770     }
9771
9772   ffesymbol_signal_unreported (s);
9773
9774   ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
9775 }
9776
9777 /* ffestc_R1225 -- END SUBROUTINE statement
9778
9779    ffestc_R1225(name_token);
9780
9781    Make sure ffestc_kind_ identifies the current kind of program unit.  If
9782    not NULL, make sure name_token gives the correct name.  Implement the end
9783    of the current program unit.  */
9784
9785 void
9786 ffestc_R1225 (ffelexToken name)
9787 {
9788   ffestc_check_simple_ ();
9789   if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
9790     return;
9791   ffestc_labeldef_notloop_ ();
9792
9793   if ((name != NULL)
9794     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
9795     {
9796       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
9797       ffebad_here (0, ffelex_token_where_line (name),
9798                    ffelex_token_where_column (name));
9799       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9800              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9801       ffebad_finish ();
9802     }
9803
9804   ffestc_shriek_subroutine_ (TRUE);
9805 }
9806
9807 /* ffestc_R1226 -- ENTRY statement
9808
9809    ffestc_R1226(entryname,arglist,ending_token);
9810
9811    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
9812    entry point name, and so on.  */
9813
9814 void
9815 ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
9816               ffelexToken final UNUSED)
9817 {
9818   ffesymbol s;
9819   ffesymbol fs;
9820   ffesymbolAttrs sa;
9821   ffesymbolAttrs na;
9822   bool in_spec;                 /* TRUE if further specification statements
9823                                    may follow, FALSE if executable stmts. */
9824   bool in_func;                 /* TRUE if ENTRY is a FUNCTION, not
9825                                    SUBROUTINE. */
9826
9827   assert ((entryname != NULL)
9828           && (ffelex_token_type (entryname) == FFELEX_typeNAME));
9829
9830   ffestc_check_simple_ ();
9831   if (ffestc_order_entry_ () != FFESTC_orderOK_)
9832     return;
9833   ffestc_labeldef_useless_ ();
9834
9835   switch (ffestw_state (ffestw_stack_top ()))
9836     {
9837     case FFESTV_stateFUNCTION1:
9838     case FFESTV_stateFUNCTION2:
9839     case FFESTV_stateFUNCTION3:
9840       in_func = TRUE;
9841       in_spec = TRUE;
9842       break;
9843
9844     case FFESTV_stateFUNCTION4:
9845       in_func = TRUE;
9846       in_spec = FALSE;
9847       break;
9848
9849     case FFESTV_stateSUBROUTINE1:
9850     case FFESTV_stateSUBROUTINE2:
9851     case FFESTV_stateSUBROUTINE3:
9852       in_func = FALSE;
9853       in_spec = TRUE;
9854       break;
9855
9856     case FFESTV_stateSUBROUTINE4:
9857       in_func = FALSE;
9858       in_spec = FALSE;
9859       break;
9860
9861     default:
9862       assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
9863       in_func = FALSE;
9864       in_spec = FALSE;
9865       break;
9866     }
9867
9868   if (in_func)
9869     fs = ffesymbol_declare_funcunit (entryname);
9870   else
9871     fs = ffesymbol_declare_subrunit (entryname);
9872
9873   if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
9874     ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
9875   else
9876     {
9877       if (ffesymbol_kind (fs) != FFEINFO_kindANY)
9878         ffesymbol_error (fs, entryname);
9879     }
9880
9881   ++ffestc_entry_num_;
9882
9883   ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
9884   if (in_spec)
9885     ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
9886   else
9887     ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
9888   ffebld_end_list (&ffestc_local_.dummy.list_bottom);
9889
9890   if (in_func)
9891     {
9892       s = ffesymbol_declare_funcresult (entryname);
9893       ffesymbol_set_funcresult (fs, s);
9894       ffesymbol_set_funcresult (s, fs);
9895       sa = ffesymbol_attrs (s);
9896
9897       /* Figure out what kind of object we've got based on previous
9898          declarations of or references to the object. */
9899
9900       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
9901         na = FFESYMBOL_attrsetNONE;
9902       else if (sa & FFESYMBOL_attrsANY)
9903         na = FFESYMBOL_attrsANY;
9904       else if (!(sa & ~(FFESYMBOL_attrsANYLEN
9905                         | FFESYMBOL_attrsTYPE)))
9906         na = sa | FFESYMBOL_attrsRESULT;
9907       else
9908         na = FFESYMBOL_attrsetNONE;
9909
9910       /* Now see what we've got for a new object: NONE means a new error
9911          cropped up; ANY means an old error to be ignored; otherwise,
9912          everything's ok, update the object (symbol) and continue on. */
9913
9914       if (na == FFESYMBOL_attrsetNONE)
9915         {
9916           ffesymbol_error (s, entryname);
9917           ffestc_parent_ok_ = FALSE;
9918         }
9919       else if (na & FFESYMBOL_attrsANY)
9920         {
9921           ffestc_parent_ok_ = FALSE;
9922         }
9923       else
9924         {
9925           ffesymbol_set_attrs (s, na);
9926           if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9927             ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
9928           else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
9929             {
9930               ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9931               ffesymbol_set_info (s,
9932                                   ffeinfo_new (ffesymbol_basictype (s),
9933                                                ffesymbol_kindtype (s),
9934                                                0,
9935                                                FFEINFO_kindENTITY,
9936                                                FFEINFO_whereRESULT,
9937                                                ffesymbol_size (s)));
9938               ffesymbol_resolve_intrin (s);
9939               ffestorag_exec_layout (s);
9940             }
9941         }
9942
9943       /* Since ENTRY might appear after executable stmts, do what would have
9944          been done if it hadn't -- give symbol implicit type and
9945          exec-transition it.  */
9946
9947       if (!in_spec && ffesymbol_is_specable (s))
9948         {
9949           if (!ffeimplic_establish_symbol (s))  /* Do implicit typing. */
9950             ffesymbol_error (s, entryname);
9951           s = ffecom_sym_exec_transition (s);
9952         }
9953
9954       /* Use whatever type info is available for ENTRY to set up type for its
9955          global-name-space function symbol relative.  */
9956
9957       ffesymbol_set_info (fs,
9958                           ffeinfo_new (ffesymbol_basictype (s),
9959                                        ffesymbol_kindtype (s),
9960                                        0,
9961                                        FFEINFO_kindFUNCTION,
9962                                        FFEINFO_whereLOCAL,
9963                                        ffesymbol_size (s)));
9964
9965
9966       /* Check whether the type info fits the filewide expectations;
9967          set ok flag accordingly.  */
9968
9969       ffesymbol_reference (fs, entryname, FALSE);
9970
9971       /* ~~Question??:
9972          When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
9973          if FOO and IBAR would normally end up with different types?  I think
9974          the answer is that FOO is always given whatever type would be chosen
9975          for IBAR, rather than the other way around, and I think it ends up
9976          working that way for FUNCTION FOO() RESULT(IBAR), but this should be
9977          checked out in all its different combos. Related question is, is
9978          there any way that FOO in either case ends up without type info
9979          filled in?  Does anyone care?  */
9980
9981       ffesymbol_signal_unreported (s);
9982     }
9983   else
9984     {
9985       ffesymbol_set_info (fs,
9986                           ffeinfo_new (FFEINFO_basictypeNONE,
9987                                        FFEINFO_kindtypeNONE,
9988                                        0,
9989                                        FFEINFO_kindSUBROUTINE,
9990                                        FFEINFO_whereLOCAL,
9991                                        FFETARGET_charactersizeNONE));
9992     }
9993
9994   if (!in_spec)
9995     fs = ffecom_sym_exec_transition (fs);
9996
9997   ffesymbol_signal_unreported (fs);
9998
9999   ffestd_R1226 (fs);
10000 }
10001
10002 /* ffestc_R1227 -- RETURN statement
10003
10004    ffestc_R1227(expr,expr_token);
10005
10006    Make sure statement is valid here; implement.  expr and expr_token are
10007    both NULL if there was no expression.  */
10008
10009 void
10010 ffestc_R1227 (ffebld expr, ffelexToken expr_token)
10011 {
10012   ffestw b;
10013
10014   ffestc_check_simple_ ();
10015   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10016     return;
10017   ffestc_labeldef_notloop_begin_ ();
10018
10019   for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
10020     {
10021       switch (ffestw_state (b))
10022         {
10023         case FFESTV_statePROGRAM4:
10024         case FFESTV_stateSUBROUTINE4:
10025         case FFESTV_stateFUNCTION4:
10026           goto base;            /* :::::::::::::::::::: */
10027
10028         case FFESTV_stateNIL:
10029           assert ("bad state" == NULL);
10030           break;
10031
10032         default:
10033           break;
10034         }
10035     }
10036
10037  base:
10038   switch (ffestw_state (b))
10039     {
10040     case FFESTV_statePROGRAM4:
10041       if (ffe_is_pedantic ())
10042         {
10043           ffebad_start (FFEBAD_RETURN_IN_MAIN);
10044           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10045                        ffelex_token_where_column (ffesta_tokens[0]));
10046           ffebad_finish ();
10047         }
10048       if (expr != NULL)
10049         {
10050           ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
10051           ffebad_here (0, ffelex_token_where_line (expr_token),
10052                        ffelex_token_where_column (expr_token));
10053           ffebad_finish ();
10054           expr = NULL;
10055         }
10056       break;
10057
10058     case FFESTV_stateSUBROUTINE4:
10059       break;
10060
10061     case FFESTV_stateFUNCTION4:
10062       if (expr != NULL)
10063         {
10064           ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
10065           ffebad_here (0, ffelex_token_where_line (expr_token),
10066                        ffelex_token_where_column (expr_token));
10067           ffebad_finish ();
10068           expr = NULL;
10069         }
10070       break;
10071
10072     default:
10073       assert ("bad state #2" == NULL);
10074       break;
10075     }
10076
10077   ffestd_R1227 (expr);
10078
10079   if (ffestc_shriek_after1_ != NULL)
10080     (*ffestc_shriek_after1_) (TRUE);
10081
10082   /* notloop's that are actionif's can be the target of a loop-end
10083      statement if they're in the "then" part of a logical IF, as
10084      in "DO 10", "10 IF (...) RETURN".  */
10085
10086   ffestc_labeldef_branch_end_ ();
10087 }
10088
10089 /* ffestc_R1229_start -- STMTFUNCTION statement begin
10090
10091    ffestc_R1229_start(func_name,func_arg_list,close_paren);
10092
10093    Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
10094    "live" scope within the current scope, and expect the actual expression
10095    (or NULL) in ffestc_R1229_finish.  The reason there are two ffestc
10096    functions to handle this is so the scope can be established, allowing
10097    ffeexpr to assign proper characteristics to references to the dummy
10098    arguments.  */
10099
10100 void
10101 ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
10102                     ffelexToken final UNUSED)
10103 {
10104   ffesymbol s;
10105   ffesymbolAttrs sa;
10106   ffesymbolAttrs na;
10107
10108   ffestc_check_start_ ();
10109   if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
10110     {
10111       ffestc_ok_ = FALSE;
10112       return;
10113     }
10114   ffestc_labeldef_useless_ ();
10115
10116   assert (name != NULL);
10117   assert (args != NULL);
10118
10119   s = ffesymbol_declare_local (name, FALSE);
10120   sa = ffesymbol_attrs (s);
10121
10122   /* Figure out what kind of object we've got based on previous declarations
10123      of or references to the object. */
10124
10125   if (!ffesymbol_is_specable (s))
10126     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
10127   else if (sa & FFESYMBOL_attrsANY)
10128     na = FFESYMBOL_attrsANY;
10129   else if (!(sa & ~FFESYMBOL_attrsTYPE))
10130     na = sa | FFESYMBOL_attrsSFUNC;
10131   else
10132     na = FFESYMBOL_attrsetNONE;
10133
10134   /* Now see what we've got for a new object: NONE means a new error cropped
10135      up; ANY means an old error to be ignored; otherwise, everything's ok,
10136      update the object (symbol) and continue on. */
10137
10138   if (na == FFESYMBOL_attrsetNONE)
10139     {
10140       ffesymbol_error (s, name);
10141       ffestc_parent_ok_ = FALSE;
10142     }
10143   else if (na & FFESYMBOL_attrsANY)
10144     ffestc_parent_ok_ = FALSE;
10145   else
10146     {
10147       ffesymbol_set_attrs (s, na);
10148       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
10149       if (!ffeimplic_establish_symbol (s)
10150           || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
10151               && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
10152         {
10153           ffesymbol_error (s, ffesta_tokens[0]);
10154           ffestc_parent_ok_ = FALSE;
10155         }
10156       else
10157         {
10158           /* Tell ffeexpr that sfunc def is in progress.  */
10159           ffesymbol_set_sfexpr (s, ffebld_new_any ());
10160           ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
10161           ffestc_parent_ok_ = TRUE;
10162         }
10163     }
10164
10165   ffe_init_4 ();
10166
10167   if (ffestc_parent_ok_)
10168     {
10169       ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
10170       ffestc_sfdummy_argno_ = 0;
10171       ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
10172       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
10173     }
10174
10175   ffestc_local_.sfunc.symbol = s;
10176
10177   ffestd_R1229_start (name, args);
10178
10179   ffestc_ok_ = TRUE;
10180 }
10181
10182 /* ffestc_R1229_finish -- STMTFUNCTION statement list complete
10183
10184    ffestc_R1229_finish(expr,expr_token);
10185
10186    If expr is NULL, an error occurred parsing the expansion expression, so
10187    just cancel the effects of ffestc_R1229_start and pretend nothing
10188    happened.  Otherwise, install the expression as the expansion for the
10189    statement function named in _start_, then clean up.  */
10190
10191 void
10192 ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
10193 {
10194   ffestc_check_finish_ ();
10195   if (!ffestc_ok_)
10196     return;
10197
10198   if (ffestc_parent_ok_ && (expr != NULL))
10199     ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
10200                           ffeexpr_convert_to_sym (expr,
10201                                                   expr_token,
10202                                                   ffestc_local_.sfunc.symbol,
10203                                                   ffesta_tokens[0]));
10204
10205   ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
10206
10207   ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
10208
10209   ffe_terminate_4 ();
10210 }
10211
10212 /* ffestc_S3P4 -- INCLUDE line
10213
10214    ffestc_S3P4(filename,filename_token);
10215
10216    Make sure INCLUDE not preceded by any semicolons or a label def; implement.  */
10217
10218 void
10219 ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
10220 {
10221   ffestc_check_simple_ ();
10222   ffestc_labeldef_invalid_ ();
10223
10224   ffestd_S3P4 (filename);
10225 }
10226
10227 /* ffestc_V014_start -- VOLATILE statement list begin
10228
10229    ffestc_V014_start();
10230
10231    Verify that VOLATILE is valid here, and begin accepting items in the
10232    list.  */
10233
10234 void
10235 ffestc_V014_start (void)
10236 {
10237   ffestc_check_start_ ();
10238   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
10239     {
10240       ffestc_ok_ = FALSE;
10241       return;
10242     }
10243   ffestc_labeldef_useless_ ();
10244
10245   ffestd_V014_start ();
10246
10247   ffestc_ok_ = TRUE;
10248 }
10249
10250 /* ffestc_V014_item_object -- VOLATILE statement for object-name
10251
10252    ffestc_V014_item_object(name_token);
10253
10254    Make sure name_token identifies a valid object to be VOLATILEd.  */
10255
10256 void
10257 ffestc_V014_item_object (ffelexToken name)
10258 {
10259   ffestc_check_item_ ();
10260   assert (name != NULL);
10261   if (!ffestc_ok_)
10262     return;
10263
10264   ffestd_V014_item_object (name);
10265 }
10266
10267 /* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
10268
10269    ffestc_V014_item_cblock(name_token);
10270
10271    Make sure name_token identifies a valid common block to be VOLATILEd.  */
10272
10273 void
10274 ffestc_V014_item_cblock (ffelexToken name)
10275 {
10276   ffestc_check_item_ ();
10277   assert (name != NULL);
10278   if (!ffestc_ok_)
10279     return;
10280
10281   ffestd_V014_item_cblock (name);
10282 }
10283
10284 /* ffestc_V014_finish -- VOLATILE statement list complete
10285
10286    ffestc_V014_finish();
10287
10288    Just wrap up any local activities.  */
10289
10290 void
10291 ffestc_V014_finish (void)
10292 {
10293   ffestc_check_finish_ ();
10294   if (!ffestc_ok_)
10295     return;
10296
10297   ffestd_V014_finish ();
10298 }
10299
10300 /* ffestc_V020_start -- TYPE statement list begin
10301
10302    ffestc_V020_start();
10303
10304    Verify that TYPE is valid here, and begin accepting items in the
10305    list.  */
10306
10307 void
10308 ffestc_V020_start (void)
10309 {
10310   ffestvFormat format;
10311
10312   ffestc_check_start_ ();
10313   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10314     {
10315       ffestc_ok_ = FALSE;
10316       return;
10317     }
10318   ffestc_labeldef_branch_begin_ ();
10319
10320   if (!ffestc_subr_is_format_
10321       (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
10322     {
10323       ffestc_ok_ = FALSE;
10324       return;
10325     }
10326
10327   format = ffestc_subr_format_
10328     (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
10329   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10330
10331   ffestd_V020_start (format);
10332
10333   ffestc_ok_ = TRUE;
10334 }
10335
10336 /* ffestc_V020_item -- TYPE statement i/o item
10337
10338    ffestc_V020_item(expr,expr_token);
10339
10340    Implement output-list expression.  */
10341
10342 void
10343 ffestc_V020_item (ffebld expr, ffelexToken expr_token)
10344 {
10345   ffestc_check_item_ ();
10346   if (!ffestc_ok_)
10347     return;
10348
10349   if (ffestc_namelist_ != 0)
10350     {
10351       if (ffestc_namelist_ == 1)
10352         {
10353           ffestc_namelist_ = 2;
10354           ffebad_start (FFEBAD_NAMELIST_ITEMS);
10355           ffebad_here (0, ffelex_token_where_line (expr_token),
10356                        ffelex_token_where_column (expr_token));
10357           ffebad_finish ();
10358         }
10359       return;
10360     }
10361
10362   ffestd_V020_item (expr);
10363 }
10364
10365 /* ffestc_V020_finish -- TYPE statement list complete
10366
10367    ffestc_V020_finish();
10368
10369    Just wrap up any local activities.  */
10370
10371 void
10372 ffestc_V020_finish (void)
10373 {
10374   ffestc_check_finish_ ();
10375   if (!ffestc_ok_)
10376     return;
10377
10378   ffestd_V020_finish ();
10379
10380   if (ffestc_shriek_after1_ != NULL)
10381     (*ffestc_shriek_after1_) (TRUE);
10382   ffestc_labeldef_branch_end_ ();
10383 }
10384
10385 /* ffestc_V027_start -- VXT PARAMETER statement list begin
10386
10387    ffestc_V027_start();
10388
10389    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
10390
10391 void
10392 ffestc_V027_start (void)
10393 {
10394   ffestc_check_start_ ();
10395   if (ffestc_order_parameter_ () != FFESTC_orderOK_)
10396     {
10397       ffestc_ok_ = FALSE;
10398       return;
10399     }
10400   ffestc_labeldef_useless_ ();
10401
10402   ffestd_V027_start ();
10403
10404   ffestc_ok_ = TRUE;
10405 }
10406
10407 /* ffestc_V027_item -- VXT PARAMETER statement assignment
10408
10409    ffestc_V027_item(dest,dest_token,source,source_token);
10410
10411    Make sure the source is a valid source for the destination; make the
10412    assignment.  */
10413
10414 void
10415 ffestc_V027_item (ffelexToken dest_token, ffebld source,
10416                   ffelexToken source_token UNUSED)
10417 {
10418   ffestc_check_item_ ();
10419   if (!ffestc_ok_)
10420     return;
10421
10422   ffestd_V027_item (dest_token, source);
10423 }
10424
10425 /* ffestc_V027_finish -- VXT PARAMETER statement list complete
10426
10427    ffestc_V027_finish();
10428
10429    Just wrap up any local activities.  */
10430
10431 void
10432 ffestc_V027_finish (void)
10433 {
10434   ffestc_check_finish_ ();
10435   if (!ffestc_ok_)
10436     return;
10437
10438   ffestd_V027_finish ();
10439 }
10440
10441 /* Any executable statement.  Mainly make sure that one-shot things
10442    like the statement for a logical IF are reset.  */
10443
10444 void
10445 ffestc_any (void)
10446 {
10447   ffestc_check_simple_ ();
10448
10449   ffestc_order_any_ ();
10450
10451   ffestc_labeldef_any_ ();
10452
10453   if (ffestc_shriek_after1_ == NULL)
10454     return;
10455
10456   ffestd_any ();
10457
10458   (*ffestc_shriek_after1_) (TRUE);
10459 }