gcc/f/stc.c

   1 /* stc.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997 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 #if FFESTR_VXT
 174     struct
 175       {
 176         char list_state;        /* 0=>no field names allowed, 1=>error
 177                                    reported already, 2=>field names req'd,
 178                                    3=>have a field name. */
 179       }
 180     V003;
 181 #endif
 182   };                            /* Merge with the one in ffestc later. */
 183
 184 /* Static objects accessed by functions in this module. */
 185
 186 static bool ffestc_ok_;         /* _start_ fn's send this to _xyz_ fn's. */
 187 static bool ffestc_parent_ok_;  /* Parent sym for baby sym fn's ok. */
 188 static char ffestc_namelist_;   /* 0=>not namelist, 1=>namelist, 2=>error. */
 189 static union ffestc_local_u_ ffestc_local_;
 190 static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_;
 191 static ffestwShriek ffestc_shriek_after1_ = NULL;
 192 static unsigned long ffestc_blocknum_ = 0;      /* Next block# to assign. */
 193 static int ffestc_entry_num_;
 194 static int ffestc_sfdummy_argno_;
 195 static int ffestc_saved_entry_num_;
 196 static ffelab ffestc_label_;
 197
 198 /* Static functions (internal). */
 199
 200 static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t);
 201 static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt,
 202                                         ffebld len, ffelexToken lent);
 203 static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet,
 204                                         ffebld kind, ffelexToken kindt,
 205                                         ffebld len, ffelexToken lent);
 206 static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last);
 207 static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt,
 208                                               ffetargetCharacterSize val);
 209 static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt,
 210                                               ffetargetCharacterSize val);
 211 static void ffestc_labeldef_any_ (void);
 212 static bool ffestc_labeldef_begin_ (void);
 213 static void ffestc_labeldef_branch_begin_ (void);
 214 static void ffestc_labeldef_branch_end_ (void);
 215 static void ffestc_labeldef_endif_ (void);
 216 static void ffestc_labeldef_format_ (void);
 217 static void ffestc_labeldef_invalid_ (void);
 218 static void ffestc_labeldef_notloop_ (void);
 219 static void ffestc_labeldef_notloop_begin_ (void);
 220 static void ffestc_labeldef_useless_ (void);
 221 static bool ffestc_labelref_is_assignable_ (ffelexToken label_token,
 222                                             ffelab *label);
 223 static bool ffestc_labelref_is_branch_ (ffelexToken label_token,
 224                                         ffelab *label);
 225 static bool ffestc_labelref_is_format_ (ffelexToken label_token,
 226                                         ffelab *label);
 227 static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
 228                                          ffelab *label);
 229 #if FFESTR_F90
 230 static ffestcOrder_ ffestc_order_access_ (void);
 231 #endif
 232 static ffestcOrder_ ffestc_order_actiondo_ (void);
 233 static ffestcOrder_ ffestc_order_actionif_ (void);
 234 static ffestcOrder_ ffestc_order_actionwhere_ (void);
 235 static void ffestc_order_any_ (void);
 236 static void ffestc_order_bad_ (void);
 237 static ffestcOrder_ ffestc_order_blockdata_ (void);
 238 static ffestcOrder_ ffestc_order_blockspec_ (void);
 239 #if FFESTR_F90
 240 static ffestcOrder_ ffestc_order_component_ (void);
 241 #endif
 242 #if FFESTR_F90
 243 static ffestcOrder_ ffestc_order_contains_ (void);
 244 #endif
 245 static ffestcOrder_ ffestc_order_data_ (void);
 246 static ffestcOrder_ ffestc_order_data77_ (void);
 247 #if FFESTR_F90
 248 static ffestcOrder_ ffestc_order_derivedtype_ (void);
 249 #endif
 250 static ffestcOrder_ ffestc_order_do_ (void);
 251 static ffestcOrder_ ffestc_order_entry_ (void);
 252 static ffestcOrder_ ffestc_order_exec_ (void);
 253 static ffestcOrder_ ffestc_order_format_ (void);
 254 static ffestcOrder_ ffestc_order_function_ (void);
 255 static ffestcOrder_ ffestc_order_iface_ (void);
 256 static ffestcOrder_ ffestc_order_ifthen_ (void);
 257 static ffestcOrder_ ffestc_order_implicit_ (void);
 258 static ffestcOrder_ ffestc_order_implicitnone_ (void);
 259 #if FFESTR_F90
 260 static ffestcOrder_ ffestc_order_interface_ (void);
 261 #endif
 262 #if FFESTR_F90
 263 static ffestcOrder_ ffestc_order_map_ (void);
 264 #endif
 265 #if FFESTR_F90
 266 static ffestcOrder_ ffestc_order_module_ (void);
 267 #endif
 268 static ffestcOrder_ ffestc_order_parameter_ (void);
 269 static ffestcOrder_ ffestc_order_program_ (void);
 270 static ffestcOrder_ ffestc_order_progspec_ (void);
 271 #if FFESTR_F90
 272 static ffestcOrder_ ffestc_order_record_ (void);
 273 #endif
 274 static ffestcOrder_ ffestc_order_selectcase_ (void);
 275 static ffestcOrder_ ffestc_order_sfunc_ (void);
 276 #if FFESTR_F90
 277 static ffestcOrder_ ffestc_order_spec_ (void);
 278 #endif
 279 #if FFESTR_VXT
 280 static ffestcOrder_ ffestc_order_structure_ (void);
 281 #endif
 282 static ffestcOrder_ ffestc_order_subroutine_ (void);
 283 #if FFESTR_F90
 284 static ffestcOrder_ ffestc_order_type_ (void);
 285 #endif
 286 static ffestcOrder_ ffestc_order_typedecl_ (void);
 287 #if FFESTR_VXT
 288 static ffestcOrder_ ffestc_order_union_ (void);
 289 #endif
 290 static ffestcOrder_ ffestc_order_unit_ (void);
 291 #if FFESTR_F90
 292 static ffestcOrder_ ffestc_order_use_ (void);
 293 #endif
 294 #if FFESTR_VXT
 295 static ffestcOrder_ ffestc_order_vxtstructure_ (void);
 296 #endif
 297 #if FFESTR_F90
 298 static ffestcOrder_ ffestc_order_where_ (void);
 299 #endif
 300 static void ffestc_promote_dummy_ (ffelexToken t);
 301 static void ffestc_promote_execdummy_ (ffelexToken t);
 302 static void ffestc_promote_sfdummy_ (ffelexToken t);
 303 static void ffestc_shriek_begin_program_ (void);
 304 #if FFESTR_F90
 305 static void ffestc_shriek_begin_uses_ (void);
 306 #endif
 307 static void ffestc_shriek_blockdata_ (bool ok);
 308 static void ffestc_shriek_do_ (bool ok);
 309 static void ffestc_shriek_end_program_ (bool ok);
 310 #if FFESTR_F90
 311 static void ffestc_shriek_end_uses_ (bool ok);
 312 #endif
 313 static void ffestc_shriek_function_ (bool ok);
 314 static void ffestc_shriek_if_ (bool ok);
 315 static void ffestc_shriek_ifthen_ (bool ok);
 316 #if FFESTR_F90
 317 static void ffestc_shriek_interface_ (bool ok);
 318 #endif
 319 #if FFESTR_F90
 320 static void ffestc_shriek_map_ (bool ok);
 321 #endif
 322 #if FFESTR_F90
 323 static void ffestc_shriek_module_ (bool ok);
 324 #endif
 325 static void ffestc_shriek_select_ (bool ok);
 326 #if FFESTR_VXT
 327 static void ffestc_shriek_structure_ (bool ok);
 328 #endif
 329 static void ffestc_shriek_subroutine_ (bool ok);
 330 #if FFESTR_F90
 331 static void ffestc_shriek_type_ (bool ok);
 332 #endif
 333 #if FFESTR_VXT
 334 static void ffestc_shriek_union_ (bool ok);
 335 #endif
 336 #if FFESTR_F90
 337 static void ffestc_shriek_where_ (bool ok);
 338 #endif
 339 #if FFESTR_F90
 340 static void ffestc_shriek_wherethen_ (bool ok);
 341 #endif
 342 static int ffestc_subr_binsrch_ (const char **list, int size, ffestpFile *spec,
 343                                  const char *whine);
 344 static ffestvFormat ffestc_subr_format_ (ffestpFile *spec);
 345 static bool ffestc_subr_is_branch_ (ffestpFile *spec);
 346 static bool ffestc_subr_is_format_ (ffestpFile *spec);
 347 static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec);
 348 static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec,
 349                                  const char **target, int *length);
 350 static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec);
 351 static void ffestc_try_shriek_do_ (void);
 352
 353 /* Internal macros. */
 354
 355 #define ffestc_check_simple_() \
 356       assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_)
 357 #define ffestc_check_start_() \
 358       assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \
 359       ffestc_statelet_ = FFESTC_stateletATTRIB_
 360 #define ffestc_check_attrib_() \
 361       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_)
 362 #define ffestc_check_item_() \
 363       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
 364             || ffestc_statelet_ == FFESTC_stateletITEM_); \
 365       ffestc_statelet_ = FFESTC_stateletITEM_
 366 #define ffestc_check_item_startvals_() \
 367       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
 368             || ffestc_statelet_ == FFESTC_stateletITEM_); \
 369       ffestc_statelet_ = FFESTC_stateletITEMVALS_
 370 #define ffestc_check_item_value_() \
 371       assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_)
 372 #define ffestc_check_item_endvals_() \
 373       assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \
 374       ffestc_statelet_ = FFESTC_stateletITEM_
 375 #define ffestc_check_finish_() \
 376       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
 377             || ffestc_statelet_ == FFESTC_stateletITEM_); \
 378       ffestc_statelet_ = FFESTC_stateletSIMPLE_
 379 #define ffestc_order_action_() ffestc_order_exec_()
 380 #if FFESTR_F90
 381 #define ffestc_order_interfacespec_() ffestc_order_derivedtype_()
 382 #endif
 383 #define ffestc_shriek_if_lost_ ffestc_shriek_if_
 384 #if FFESTR_F90
 385 #define ffestc_shriek_where_lost_ ffestc_shriek_where_
 386 #endif
 387 \f
 388 /* ffestc_establish_declinfo_ -- Determine specific type/params info for entity
 389
 390    ffestc_establish_declinfo_(kind,kind_token,len,len_token);
 391
 392    Must be called after _declstmt_ called to establish base type.  */
 393
 394 static void
 395 ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len,
 396                             ffelexToken lent)
 397 {
 398   ffeinfoBasictype bt = ffestc_local_.decl.basic_type;
 399   ffeinfoKindtype kt;
 400   ffetargetCharacterSize val;
 401
 402   if (kindt == NULL)
 403     kt = ffestc_local_.decl.stmt_kind_type;
 404   else if (!ffestc_local_.decl.per_var_kind_ok)
 405     {
 406       ffebad_start (FFEBAD_KINDTYPE);
 407       ffebad_here (0, ffelex_token_where_line (kindt),
 408                    ffelex_token_where_column (kindt));
 409       ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
 410                    ffelex_token_where_column (ffesta_tokens[0]));
 411       ffebad_finish ();
 412       kt = ffestc_local_.decl.stmt_kind_type;
 413     }
 414   else
 415     {
 416       if (kind == NULL)
 417         {
 418           assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
 419           val = atol (ffelex_token_text (kindt));
 420           kt = ffestc_kindtype_star_ (bt, val);
 421         }
 422       else if (ffebld_op (kind) == FFEBLD_opANY)
 423         kt = ffestc_local_.decl.stmt_kind_type;
 424       else
 425         {
 426           assert (ffebld_op (kind) == FFEBLD_opCONTER);
 427           assert (ffeinfo_basictype (ffebld_info (kind))
 428                   == FFEINFO_basictypeINTEGER);
 429           assert (ffeinfo_kindtype (ffebld_info (kind))
 430                   == FFEINFO_kindtypeINTEGERDEFAULT);
 431           val = ffebld_constant_integerdefault (ffebld_conter (kind));
 432           kt = ffestc_kindtype_kind_ (bt, val);
 433         }
 434
 435       if (kt == FFEINFO_kindtypeNONE)
 436         {                       /* Not valid kind type. */
 437           ffebad_start (FFEBAD_KINDTYPE);
 438           ffebad_here (0, ffelex_token_where_line (kindt),
 439                        ffelex_token_where_column (kindt));
 440           ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
 441                        ffelex_token_where_column (ffesta_tokens[0]));
 442           ffebad_finish ();
 443           kt = ffestc_local_.decl.stmt_kind_type;
 444         }
 445     }
 446
 447   ffestc_local_.decl.kind_type = kt;
 448
 449   /* Now check length specification for CHARACTER data type. */
 450
 451   if (((len == NULL) && (lent == NULL))
 452       || (bt != FFEINFO_basictypeCHARACTER))
 453     val = ffestc_local_.decl.stmt_size;
 454   else
 455     {
 456       if (len == NULL)
 457         {
 458           assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
 459           val = atol (ffelex_token_text (lent));
 460         }
 461       else if (ffebld_op (len) == FFEBLD_opSTAR)
 462         val = FFETARGET_charactersizeNONE;
 463       else if (ffebld_op (len) == FFEBLD_opANY)
 464         val = FFETARGET_charactersizeNONE;
 465       else
 466         {
 467           assert (ffebld_op (len) == FFEBLD_opCONTER);
 468           assert (ffeinfo_basictype (ffebld_info (len))
 469                   == FFEINFO_basictypeINTEGER);
 470           assert (ffeinfo_kindtype (ffebld_info (len))
 471                   == FFEINFO_kindtypeINTEGERDEFAULT);
 472           val = ffebld_constant_integerdefault (ffebld_conter (len));
 473         }
 474     }
 475
 476   if ((val == 0) && !(0 && ffe_is_90 ()))
 477     {
 478       val = 1;
 479       ffebad_start (FFEBAD_ZERO_SIZE);
 480       ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
 481       ffebad_finish ();
 482     }
 483   ffestc_local_.decl.size = val;
 484 }
 485
 486 /* ffestc_establish_declstmt_ -- Establish host-specific type/params info
 487
 488    ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
 489          len_token);  */
 490
 491 static void
 492 ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
 493                             ffelexToken kindt, ffebld len, ffelexToken lent)
 494 {
 495   ffeinfoBasictype bt;
 496   ffeinfoKindtype ktd;          /* Default kindtype. */
 497   ffeinfoKindtype kt;
 498   ffetargetCharacterSize val;
 499   bool per_var_kind_ok = TRUE;
 500
 501   /* Determine basictype and default kindtype. */
 502
 503   switch (type)
 504     {
 505     case FFESTP_typeINTEGER:
 506       bt = FFEINFO_basictypeINTEGER;
 507       ktd = FFEINFO_kindtypeINTEGERDEFAULT;
 508       break;
 509
 510     case FFESTP_typeBYTE:
 511       bt = FFEINFO_basictypeINTEGER;
 512       ktd = FFEINFO_kindtypeINTEGER2;
 513       break;
 514
 515     case FFESTP_typeWORD:
 516       bt = FFEINFO_basictypeINTEGER;
 517       ktd = FFEINFO_kindtypeINTEGER3;
 518       break;
 519
 520     case FFESTP_typeREAL:
 521       bt = FFEINFO_basictypeREAL;
 522       ktd = FFEINFO_kindtypeREALDEFAULT;
 523       break;
 524
 525     case FFESTP_typeCOMPLEX:
 526       bt = FFEINFO_basictypeCOMPLEX;
 527       ktd = FFEINFO_kindtypeREALDEFAULT;
 528       break;
 529
 530     case FFESTP_typeLOGICAL:
 531       bt = FFEINFO_basictypeLOGICAL;
 532       ktd = FFEINFO_kindtypeLOGICALDEFAULT;
 533       break;
 534
 535     case FFESTP_typeCHARACTER:
 536       bt = FFEINFO_basictypeCHARACTER;
 537       ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
 538       break;
 539
 540     case FFESTP_typeDBLPRCSN:
 541       bt = FFEINFO_basictypeREAL;
 542       ktd = FFEINFO_kindtypeREALDOUBLE;
 543       per_var_kind_ok = FALSE;
 544       break;
 545
 546     case FFESTP_typeDBLCMPLX:
 547       bt = FFEINFO_basictypeCOMPLEX;
 548 #if FFETARGET_okCOMPLEX2
 549       ktd = FFEINFO_kindtypeREALDOUBLE;
 550 #else
 551       ktd = FFEINFO_kindtypeREALDEFAULT;
 552       ffebad_start (FFEBAD_BAD_DBLCMPLX);
 553       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
 554                    ffelex_token_where_column (ffesta_tokens[0]));
 555       ffebad_finish ();
 556 #endif
 557       per_var_kind_ok = FALSE;
 558       break;
 559
 560     default:
 561       assert ("Unexpected type (F90 TYPE?)!" == NULL);
 562       bt = FFEINFO_basictypeNONE;
 563       ktd = FFEINFO_kindtypeNONE;
 564       break;
 565     }
 566
 567   if (kindt == NULL)
 568     kt = ktd;
 569   else
 570     {                           /* Not necessarily default kind type. */
 571       if (kind == NULL)
 572         {                       /* Shouldn't happen for CHARACTER. */
 573           assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
 574           val = atol (ffelex_token_text (kindt));
 575           kt = ffestc_kindtype_star_ (bt, val);
 576         }
 577       else if (ffebld_op (kind) == FFEBLD_opANY)
 578         kt = ktd;
 579       else
 580         {
 581           assert (ffebld_op (kind) == FFEBLD_opCONTER);
 582           assert (ffeinfo_basictype (ffebld_info (kind))
 583                   == FFEINFO_basictypeINTEGER);
 584           assert (ffeinfo_kindtype (ffebld_info (kind))
 585                   == FFEINFO_kindtypeINTEGERDEFAULT);
 586           val = ffebld_constant_integerdefault (ffebld_conter (kind));
 587           kt = ffestc_kindtype_kind_ (bt, val);
 588         }
 589
 590       if (kt == FFEINFO_kindtypeNONE)
 591         {                       /* Not valid kind type. */
 592           ffebad_start (FFEBAD_KINDTYPE);
 593           ffebad_here (0, ffelex_token_where_line (kindt),
 594                        ffelex_token_where_column (kindt));
 595           ffebad_here (1, ffelex_token_where_line (typet),
 596                        ffelex_token_where_column (typet));
 597           ffebad_finish ();
 598           kt = ktd;
 599         }
 600     }
 601
 602   ffestc_local_.decl.basic_type = bt;
 603   ffestc_local_.decl.stmt_kind_type = kt;
 604   ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok;
 605
 606   /* Now check length specification for CHARACTER data type. */
 607
 608   if (((len == NULL) && (lent == NULL))
 609       || (type != FFESTP_typeCHARACTER))
 610     val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
 611   else
 612     {
 613       if (len == NULL)
 614         {
 615           assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
 616           val = atol (ffelex_token_text (lent));
 617         }
 618       else if (ffebld_op (len) == FFEBLD_opSTAR)
 619         val = FFETARGET_charactersizeNONE;
 620       else if (ffebld_op (len) == FFEBLD_opANY)
 621         val = FFETARGET_charactersizeNONE;
 622       else
 623         {
 624           assert (ffebld_op (len) == FFEBLD_opCONTER);
 625           assert (ffeinfo_basictype (ffebld_info (len))
 626                   == FFEINFO_basictypeINTEGER);
 627           assert (ffeinfo_kindtype (ffebld_info (len))
 628                   == FFEINFO_kindtypeINTEGERDEFAULT);
 629           val = ffebld_constant_integerdefault (ffebld_conter (len));
 630         }
 631     }
 632
 633   if ((val == 0) && !(0 && ffe_is_90 ()))
 634     {
 635       val = 1;
 636       ffebad_start (FFEBAD_ZERO_SIZE);
 637       ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
 638       ffebad_finish ();
 639     }
 640   ffestc_local_.decl.stmt_size = val;
 641 }
 642
 643 /* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)
 644
 645    ffestc_establish_impletter_(first_letter_token,last_letter_token);  */
 646
 647 static void
 648 ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
 649 {
 650   bool ok = FALSE;              /* Stays FALSE if first letter > last. */
 651   char c;
 652
 653   if (last == NULL)
 654     ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)),
 655                                       ffestc_local_.decl.basic_type,
 656                                       ffestc_local_.decl.kind_type,
 657                                       ffestc_local_.decl.size);
 658   else
 659     {
 660       for (c = *(ffelex_token_text (first));
 661            c <= *(ffelex_token_text (last));
 662            c++)
 663         {
 664           ok = ffeimplic_establish_initial (c,
 665                                             ffestc_local_.decl.basic_type,
 666                                             ffestc_local_.decl.kind_type,
 667                                             ffestc_local_.decl.size);
 668           if (!ok)
 669             break;
 670         }
 671     }
 672
 673   if (!ok)
 674     {
 675       char cs[2];
 676
 677       cs[0] = c;
 678       cs[1] = '\0';
 679
 680       ffebad_start (FFEBAD_BAD_IMPLICIT);
 681       ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
 682       ffebad_string (cs);
 683       ffebad_finish ();
 684     }
 685 }
 686
 687 /* ffestc_init_3 -- Initialize ffestc for new program unit
 688
 689    ffestc_init_3();  */
 690
 691 void
 692 ffestc_init_3 ()
 693 {
 694   ffestv_save_state_ = FFESTV_savestateNONE;
 695   ffestc_entry_num_ = 0;
 696   ffestv_num_label_defines_ = 0;
 697 }
 698
 699 /* ffestc_init_4 -- Initialize ffestc for new scoping unit
 700
 701    ffestc_init_4();
 702
 703    For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
 704    defs, and statement function defs.  */
 705
 706 void
 707 ffestc_init_4 ()
 708 {
 709   ffestc_saved_entry_num_ = ffestc_entry_num_;
 710   ffestc_entry_num_ = 0;
 711 }
 712
 713 /* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value
 714
 715    ffeinfoKindtype kt;
 716    ffeinfoBasictype bt;
 717    ffetargetCharacterSize val;
 718    kt = ffestc_kindtype_kind_(bt,val);
 719    if (kt == FFEINFO_kindtypeNONE)
 720        // unsupported/invalid KIND= value for type  */
 721
 722 static ffeinfoKindtype
 723 ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
 724 {
 725   ffetype type;
 726   ffetype base_type;
 727   ffeinfoKindtype kt;
 728
 729   base_type = ffeinfo_type (bt, 1);     /* ~~ */
 730   assert (base_type != NULL);
 731
 732   type = ffetype_lookup_kind (base_type, (int) val);
 733   if (type == NULL)
 734     return FFEINFO_kindtypeNONE;
 735
 736   for (kt = 1; kt < FFEINFO_kindtype; ++kt)
 737     if (ffeinfo_type (bt, kt) == type)
 738       return kt;
 739
 740   return FFEINFO_kindtypeNONE;
 741 }
 742
 743 /* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value
 744
 745    ffeinfoKindtype kt;
 746    ffeinfoBasictype bt;
 747    ffetargetCharacterSize val;
 748    kt = ffestc_kindtype_star_(bt,val);
 749    if (kt == FFEINFO_kindtypeNONE)
 750        // unsupported/invalid * value for type  */
 751
 752 static ffeinfoKindtype
 753 ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
 754 {
 755   ffetype type;
 756   ffetype base_type;
 757   ffeinfoKindtype kt;
 758
 759   base_type = ffeinfo_type (bt, 1);     /* ~~ */
 760   assert (base_type != NULL);
 761
 762   type = ffetype_lookup_star (base_type, (int) val);
 763   if (type == NULL)
 764     return FFEINFO_kindtypeNONE;
 765
 766   for (kt = 1; kt < FFEINFO_kindtype; ++kt)
 767     if (ffeinfo_type (bt, kt) == type)
 768       return kt;
 769
 770   return FFEINFO_kindtypeNONE;
 771 }
 772
 773 /* Define label as usable for anything without complaint.  */
 774
 775 static void
 776 ffestc_labeldef_any_ ()
 777 {
 778   if ((ffesta_label_token == NULL)
 779       || !ffestc_labeldef_begin_ ())
 780     return;
 781
 782   ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 783   ffestd_labeldef_any (ffestc_label_);
 784
 785   ffestc_labeldef_branch_end_ ();
 786 }
 787
 788 /* ffestc_labeldef_begin_ -- Define label as unknown, initially
 789
 790    ffestc_labeldef_begin_();  */
 791
 792 static bool
 793 ffestc_labeldef_begin_ ()
 794 {
 795   ffelabValue label_value;
 796   ffelab label;
 797
 798   label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
 799   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
 800     {
 801       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
 802       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 803                    ffelex_token_where_column (ffesta_label_token));
 804       ffebad_finish ();
 805     }
 806
 807   label = ffelab_find (label_value);
 808   if (label == NULL)
 809     {
 810       label = ffestc_label_ = ffelab_new (label_value);
 811       ffestv_num_label_defines_++;
 812       ffelab_set_definition_line (label,
 813           ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
 814       ffelab_set_definition_column (label,
 815       ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
 816
 817       return TRUE;
 818     }
 819
 820   if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
 821     {
 822       ffestv_num_label_defines_++;
 823       ffestc_label_ = label;
 824       ffelab_set_definition_line (label,
 825           ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
 826       ffelab_set_definition_column (label,
 827       ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
 828
 829       return TRUE;
 830     }
 831
 832   ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED);
 833   ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 834                ffelex_token_where_column (ffesta_label_token));
 835   ffebad_here (1, ffelab_definition_line (label),
 836                ffelab_definition_column (label));
 837   ffebad_string (ffelex_token_text (ffesta_label_token));
 838   ffebad_finish ();
 839
 840   ffelex_token_kill (ffesta_label_token);
 841   ffesta_label_token = NULL;
 842   return FALSE;
 843 }
 844
 845 /* ffestc_labeldef_branch_begin_ -- Define label as a branch target one
 846
 847    ffestc_labeldef_branch_begin_();  */
 848
 849 static void
 850 ffestc_labeldef_branch_begin_ ()
 851 {
 852   if ((ffesta_label_token == NULL)
 853       || (ffestc_shriek_after1_ != NULL)
 854       || !ffestc_labeldef_begin_ ())
 855     return;
 856
 857   switch (ffelab_type (ffestc_label_))
 858     {
 859     case FFELAB_typeUNKNOWN:
 860     case FFELAB_typeASSIGNABLE:
 861       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
 862       ffelab_set_blocknum (ffestc_label_,
 863                            ffestw_blocknum (ffestw_stack_top ()));
 864       ffestd_labeldef_branch (ffestc_label_);
 865       break;
 866
 867     case FFELAB_typeNOTLOOP:
 868       if (ffelab_blocknum (ffestc_label_)
 869           < ffestw_blocknum (ffestw_stack_top ()))
 870         {
 871           ffebad_start (FFEBAD_LABEL_BLOCK);
 872           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 873                        ffelex_token_where_column (ffesta_label_token));
 874           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
 875                        ffelab_firstref_column (ffestc_label_));
 876           ffebad_finish ();
 877         }
 878       ffelab_set_blocknum (ffestc_label_,
 879                            ffestw_blocknum (ffestw_stack_top ()));
 880       ffestd_labeldef_branch (ffestc_label_);
 881       break;
 882
 883     case FFELAB_typeLOOPEND:
 884       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
 885           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
 886         {                       /* Unterminated block. */
 887           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 888           ffestd_labeldef_any (ffestc_label_);
 889
 890           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
 891           ffebad_here (0, ffelab_doref_line (ffestc_label_),
 892                        ffelab_doref_column (ffestc_label_));
 893           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
 894           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
 895                        ffelex_token_where_column (ffesta_label_token));
 896           ffebad_finish ();
 897           break;
 898         }
 899       ffestd_labeldef_branch (ffestc_label_);
 900       /* Leave something around for _branch_end_() to handle. */
 901       return;
 902
 903     case FFELAB_typeFORMAT:
 904       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 905       ffestd_labeldef_any (ffestc_label_);
 906
 907       ffebad_start (FFEBAD_LABEL_USE_DEF);
 908       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 909                    ffelex_token_where_column (ffesta_label_token));
 910       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
 911                    ffelab_firstref_column (ffestc_label_));
 912       ffebad_finish ();
 913       break;
 914
 915     default:
 916       assert ("bad label" == NULL);
 917       /* Fall through.  */
 918     case FFELAB_typeANY:
 919       break;
 920     }
 921
 922   ffestc_try_shriek_do_ ();
 923
 924   ffelex_token_kill (ffesta_label_token);
 925   ffesta_label_token = NULL;
 926 }
 927
 928 /* Define possible end of labeled-DO-loop.  Call only after calling
 929    ffestc_labeldef_branch_begin_, or when other branch_* functions
 930    recognize that a label might also be serving as a branch end (in
 931    which case they must issue a diagnostic).  */
 932
 933 static void
 934 ffestc_labeldef_branch_end_ ()
 935 {
 936   if (ffesta_label_token == NULL)
 937     return;
 938
 939   assert (ffestc_label_ != NULL);
 940   assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND)
 941           || (ffelab_type (ffestc_label_) == FFELAB_typeANY));
 942
 943   while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
 944          && (ffestw_label (ffestw_stack_top ()) == ffestc_label_))
 945     ffestc_shriek_do_ (TRUE);
 946
 947   ffestc_try_shriek_do_ ();
 948
 949   ffelex_token_kill (ffesta_label_token);
 950   ffesta_label_token = NULL;
 951 }
 952
 953 /* ffestc_labeldef_endif_ -- Define label as an END IF one
 954
 955    ffestc_labeldef_endif_();  */
 956
 957 static void
 958 ffestc_labeldef_endif_ ()
 959 {
 960   if ((ffesta_label_token == NULL)
 961       || (ffestc_shriek_after1_ != NULL)
 962       || !ffestc_labeldef_begin_ ())
 963     return;
 964
 965   switch (ffelab_type (ffestc_label_))
 966     {
 967     case FFELAB_typeUNKNOWN:
 968     case FFELAB_typeASSIGNABLE:
 969       ffelab_set_type (ffestc_label_, FFELAB_typeENDIF);
 970       ffelab_set_blocknum (ffestc_label_,
 971                    ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
 972       ffestd_labeldef_endif (ffestc_label_);
 973       break;
 974
 975     case FFELAB_typeNOTLOOP:
 976       if (ffelab_blocknum (ffestc_label_)
 977           < ffestw_blocknum (ffestw_previous (ffestw_stack_top ())))
 978         {
 979           ffebad_start (FFEBAD_LABEL_BLOCK);
 980           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
 981                        ffelex_token_where_column (ffesta_label_token));
 982           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
 983                        ffelab_firstref_column (ffestc_label_));
 984           ffebad_finish ();
 985         }
 986       ffelab_set_blocknum (ffestc_label_,
 987                    ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
 988       ffestd_labeldef_endif (ffestc_label_);
 989       break;
 990
 991     case FFELAB_typeLOOPEND:
 992       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
 993           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
 994         {                       /* Unterminated block. */
 995           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
 996           ffestd_labeldef_any (ffestc_label_);
 997
 998           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
 999           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1000                        ffelab_doref_column (ffestc_label_));
1001           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1002           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1003                        ffelex_token_where_column (ffesta_label_token));
1004           ffebad_finish ();
1005           break;
1006         }
1007       ffestd_labeldef_endif (ffestc_label_);
1008       ffebad_start (FFEBAD_LABEL_USE_DEF);
1009       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1010                    ffelex_token_where_column (ffesta_label_token));
1011       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1012                    ffelab_doref_column (ffestc_label_));
1013       ffebad_finish ();
1014       ffestc_labeldef_branch_end_ ();
1015       return;
1016
1017     case FFELAB_typeFORMAT:
1018       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1019       ffestd_labeldef_any (ffestc_label_);
1020
1021       ffebad_start (FFEBAD_LABEL_USE_DEF);
1022       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1023                    ffelex_token_where_column (ffesta_label_token));
1024       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1025                    ffelab_firstref_column (ffestc_label_));
1026       ffebad_finish ();
1027       break;
1028
1029     default:
1030       assert ("bad label" == NULL);
1031       /* Fall through.  */
1032     case FFELAB_typeANY:
1033       break;
1034     }
1035
1036   ffestc_try_shriek_do_ ();
1037
1038   ffelex_token_kill (ffesta_label_token);
1039   ffesta_label_token = NULL;
1040 }
1041
1042 /* ffestc_labeldef_format_ -- Define label as a FORMAT one
1043
1044    ffestc_labeldef_format_();  */
1045
1046 static void
1047 ffestc_labeldef_format_ ()
1048 {
1049   if ((ffesta_label_token == NULL)
1050       || (ffestc_shriek_after1_ != NULL))
1051     {
1052       ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF);
1053       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1054                    ffelex_token_where_column (ffesta_tokens[0]));
1055       ffebad_finish ();
1056       return;
1057     }
1058
1059   if (!ffestc_labeldef_begin_ ())
1060     return;
1061
1062   switch (ffelab_type (ffestc_label_))
1063     {
1064     case FFELAB_typeUNKNOWN:
1065     case FFELAB_typeASSIGNABLE:
1066       ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT);
1067       ffestd_labeldef_format (ffestc_label_);
1068       break;
1069
1070     case FFELAB_typeFORMAT:
1071       ffestd_labeldef_format (ffestc_label_);
1072       break;
1073
1074     case FFELAB_typeLOOPEND:
1075       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1076           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1077         {                       /* Unterminated block. */
1078           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1079           ffestd_labeldef_any (ffestc_label_);
1080
1081           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1082           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1083                        ffelab_doref_column (ffestc_label_));
1084           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1085           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1086                        ffelex_token_where_column (ffesta_label_token));
1087           ffebad_finish ();
1088           break;
1089         }
1090       ffestd_labeldef_format (ffestc_label_);
1091       ffebad_start (FFEBAD_LABEL_USE_DEF);
1092       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1093                    ffelex_token_where_column (ffesta_label_token));
1094       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1095                    ffelab_doref_column (ffestc_label_));
1096       ffebad_finish ();
1097       ffestc_labeldef_branch_end_ ();
1098       return;
1099
1100     case FFELAB_typeNOTLOOP:
1101       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1102       ffestd_labeldef_any (ffestc_label_);
1103
1104       ffebad_start (FFEBAD_LABEL_USE_DEF);
1105       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1106                    ffelex_token_where_column (ffesta_label_token));
1107       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1108                    ffelab_firstref_column (ffestc_label_));
1109       ffebad_finish ();
1110       break;
1111
1112     default:
1113       assert ("bad label" == NULL);
1114       /* Fall through.  */
1115     case FFELAB_typeANY:
1116       break;
1117     }
1118
1119   ffestc_try_shriek_do_ ();
1120
1121   ffelex_token_kill (ffesta_label_token);
1122   ffesta_label_token = NULL;
1123 }
1124
1125 /* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present
1126
1127    ffestc_labeldef_invalid_();  */
1128
1129 static void
1130 ffestc_labeldef_invalid_ ()
1131 {
1132   if ((ffesta_label_token == NULL)
1133       || (ffestc_shriek_after1_ != NULL)
1134       || !ffestc_labeldef_begin_ ())
1135     return;
1136
1137   ffebad_start (FFEBAD_INVALID_LABEL_DEF);
1138   ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1139                ffelex_token_where_column (ffesta_label_token));
1140   ffebad_finish ();
1141
1142   ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1143   ffestd_labeldef_any (ffestc_label_);
1144
1145   ffestc_try_shriek_do_ ();
1146
1147   ffelex_token_kill (ffesta_label_token);
1148   ffesta_label_token = NULL;
1149 }
1150
1151 /* Define label as a non-loop-ending one on a statement that can't
1152    be in the "then" part of a logical IF, such as a block-IF statement.  */
1153
1154 static void
1155 ffestc_labeldef_notloop_ ()
1156 {
1157   if (ffesta_label_token == NULL)
1158     return;
1159
1160   assert (ffestc_shriek_after1_ == NULL);
1161
1162   if (!ffestc_labeldef_begin_ ())
1163     return;
1164
1165   switch (ffelab_type (ffestc_label_))
1166     {
1167     case FFELAB_typeUNKNOWN:
1168     case FFELAB_typeASSIGNABLE:
1169       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
1170       ffelab_set_blocknum (ffestc_label_,
1171                            ffestw_blocknum (ffestw_stack_top ()));
1172       ffestd_labeldef_notloop (ffestc_label_);
1173       break;
1174
1175     case FFELAB_typeNOTLOOP:
1176       if (ffelab_blocknum (ffestc_label_)
1177           < ffestw_blocknum (ffestw_stack_top ()))
1178         {
1179           ffebad_start (FFEBAD_LABEL_BLOCK);
1180           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1181                        ffelex_token_where_column (ffesta_label_token));
1182           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1183                        ffelab_firstref_column (ffestc_label_));
1184           ffebad_finish ();
1185         }
1186       ffelab_set_blocknum (ffestc_label_,
1187                            ffestw_blocknum (ffestw_stack_top ()));
1188       ffestd_labeldef_notloop (ffestc_label_);
1189       break;
1190
1191     case FFELAB_typeLOOPEND:
1192       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1193           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1194         {                       /* Unterminated block. */
1195           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1196           ffestd_labeldef_any (ffestc_label_);
1197
1198           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1199           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1200                        ffelab_doref_column (ffestc_label_));
1201           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1202           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1203                        ffelex_token_where_column (ffesta_label_token));
1204           ffebad_finish ();
1205           break;
1206         }
1207       ffestd_labeldef_notloop (ffestc_label_);
1208       ffebad_start (FFEBAD_LABEL_USE_DEF);
1209       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1210                    ffelex_token_where_column (ffesta_label_token));
1211       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1212                    ffelab_doref_column (ffestc_label_));
1213       ffebad_finish ();
1214       ffestc_labeldef_branch_end_ ();
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 /* Define label as a non-loop-ending one.  Use this when it is
1243    possible that the pending label is inhibited because we're in
1244    the midst of a logical-IF, and thus _branch_end_ is going to
1245    be called after the current statement to resolve a potential
1246    loop-ending label.  */
1247
1248 static void
1249 ffestc_labeldef_notloop_begin_ ()
1250 {
1251   if ((ffesta_label_token == NULL)
1252       || (ffestc_shriek_after1_ != NULL)
1253       || !ffestc_labeldef_begin_ ())
1254     return;
1255
1256   switch (ffelab_type (ffestc_label_))
1257     {
1258     case FFELAB_typeUNKNOWN:
1259     case FFELAB_typeASSIGNABLE:
1260       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
1261       ffelab_set_blocknum (ffestc_label_,
1262                            ffestw_blocknum (ffestw_stack_top ()));
1263       ffestd_labeldef_notloop (ffestc_label_);
1264       break;
1265
1266     case FFELAB_typeNOTLOOP:
1267       if (ffelab_blocknum (ffestc_label_)
1268           < ffestw_blocknum (ffestw_stack_top ()))
1269         {
1270           ffebad_start (FFEBAD_LABEL_BLOCK);
1271           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1272                        ffelex_token_where_column (ffesta_label_token));
1273           ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1274                        ffelab_firstref_column (ffestc_label_));
1275           ffebad_finish ();
1276         }
1277       ffelab_set_blocknum (ffestc_label_,
1278                            ffestw_blocknum (ffestw_stack_top ()));
1279       ffestd_labeldef_notloop (ffestc_label_);
1280       break;
1281
1282     case FFELAB_typeLOOPEND:
1283       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1284           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1285         {                       /* Unterminated block. */
1286           ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1287           ffestd_labeldef_any (ffestc_label_);
1288
1289           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1290           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1291                        ffelab_doref_column (ffestc_label_));
1292           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1293           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1294                        ffelex_token_where_column (ffesta_label_token));
1295           ffebad_finish ();
1296           break;
1297         }
1298       ffestd_labeldef_branch (ffestc_label_);
1299       ffebad_start (FFEBAD_LABEL_USE_DEF);
1300       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1301                    ffelex_token_where_column (ffesta_label_token));
1302       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1303                    ffelab_doref_column (ffestc_label_));
1304       ffebad_finish ();
1305       return;
1306
1307     case FFELAB_typeFORMAT:
1308       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1309       ffestd_labeldef_any (ffestc_label_);
1310
1311       ffebad_start (FFEBAD_LABEL_USE_DEF);
1312       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1313                    ffelex_token_where_column (ffesta_label_token));
1314       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1315                    ffelab_firstref_column (ffestc_label_));
1316       ffebad_finish ();
1317       break;
1318
1319     default:
1320       assert ("bad label" == NULL);
1321       /* Fall through.  */
1322     case FFELAB_typeANY:
1323       break;
1324     }
1325
1326   ffestc_try_shriek_do_ ();
1327
1328   ffelex_token_kill (ffesta_label_token);
1329   ffesta_label_token = NULL;
1330 }
1331
1332 /* ffestc_labeldef_useless_ -- Define label as a useless one
1333
1334    ffestc_labeldef_useless_();  */
1335
1336 static void
1337 ffestc_labeldef_useless_ ()
1338 {
1339   if ((ffesta_label_token == NULL)
1340       || (ffestc_shriek_after1_ != NULL)
1341       || !ffestc_labeldef_begin_ ())
1342     return;
1343
1344   switch (ffelab_type (ffestc_label_))
1345     {
1346     case FFELAB_typeUNKNOWN:
1347       ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS);
1348       ffestd_labeldef_useless (ffestc_label_);
1349       break;
1350
1351     case FFELAB_typeLOOPEND:
1352       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1353       ffestd_labeldef_any (ffestc_label_);
1354
1355       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1356           || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
1357         {                       /* Unterminated block. */
1358           ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
1359           ffebad_here (0, ffelab_doref_line (ffestc_label_),
1360                        ffelab_doref_column (ffestc_label_));
1361           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1362           ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
1363                        ffelex_token_where_column (ffesta_label_token));
1364           ffebad_finish ();
1365           break;
1366         }
1367       ffebad_start (FFEBAD_LABEL_USE_DEF);
1368       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1369                    ffelex_token_where_column (ffesta_label_token));
1370       ffebad_here (1, ffelab_doref_line (ffestc_label_),
1371                    ffelab_doref_column (ffestc_label_));
1372       ffebad_finish ();
1373       ffestc_labeldef_branch_end_ ();
1374       return;
1375
1376     case FFELAB_typeASSIGNABLE:
1377     case FFELAB_typeFORMAT:
1378     case FFELAB_typeNOTLOOP:
1379       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
1380       ffestd_labeldef_any (ffestc_label_);
1381
1382       ffebad_start (FFEBAD_LABEL_USE_DEF);
1383       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1384                    ffelex_token_where_column (ffesta_label_token));
1385       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
1386                    ffelab_firstref_column (ffestc_label_));
1387       ffebad_finish ();
1388       break;
1389
1390     default:
1391       assert ("bad label" == NULL);
1392       /* Fall through.  */
1393     case FFELAB_typeANY:
1394       break;
1395     }
1396
1397   ffestc_try_shriek_do_ ();
1398
1399   ffelex_token_kill (ffesta_label_token);
1400   ffesta_label_token = NULL;
1401 }
1402
1403 /* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt
1404
1405    if (ffestc_labelref_is_assignable_(label_token,&label))
1406        // label ref is ok, label is filled in with ffelab object  */
1407
1408 static bool
1409 ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label)
1410 {
1411   ffelab label;
1412   ffelabValue label_value;
1413
1414   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1415   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1416     {
1417       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1418       ffebad_here (0, ffelex_token_where_line (label_token),
1419                    ffelex_token_where_column (label_token));
1420       ffebad_finish ();
1421       return FALSE;
1422     }
1423
1424   label = ffelab_find (label_value);
1425   if (label == NULL)
1426     {
1427       label = ffelab_new (label_value);
1428       ffelab_set_firstref_line (label,
1429                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1430       ffelab_set_firstref_column (label,
1431              ffewhere_column_use (ffelex_token_where_column (label_token)));
1432     }
1433
1434   switch (ffelab_type (label))
1435     {
1436     case FFELAB_typeUNKNOWN:
1437       ffelab_set_type (label, FFELAB_typeASSIGNABLE);
1438       break;
1439
1440     case FFELAB_typeASSIGNABLE:
1441     case FFELAB_typeLOOPEND:
1442     case FFELAB_typeFORMAT:
1443     case FFELAB_typeNOTLOOP:
1444     case FFELAB_typeENDIF:
1445       break;
1446
1447     case FFELAB_typeUSELESS:
1448       ffelab_set_type (label, FFELAB_typeANY);
1449       ffestd_labeldef_any (label);
1450
1451       ffebad_start (FFEBAD_LABEL_USE_DEF);
1452       ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1453       ffebad_here (1, ffelex_token_where_line (label_token),
1454                    ffelex_token_where_column (label_token));
1455       ffebad_finish ();
1456
1457       ffestc_try_shriek_do_ ();
1458
1459       return FALSE;
1460
1461     default:
1462       assert ("bad label" == NULL);
1463       /* Fall through.  */
1464     case FFELAB_typeANY:
1465       break;
1466     }
1467
1468   *x_label = label;
1469   return TRUE;
1470 }
1471
1472 /* ffestc_labelref_is_branch_ -- Reference to label in branch stmt
1473
1474    if (ffestc_labelref_is_branch_(label_token,&label))
1475        // label ref is ok, label is filled in with ffelab object  */
1476
1477 static bool
1478 ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label)
1479 {
1480   ffelab label;
1481   ffelabValue label_value;
1482   ffestw block;
1483   unsigned long blocknum;
1484
1485   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1486   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1487     {
1488       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1489       ffebad_here (0, ffelex_token_where_line (label_token),
1490                    ffelex_token_where_column (label_token));
1491       ffebad_finish ();
1492       return FALSE;
1493     }
1494
1495   label = ffelab_find (label_value);
1496   if (label == NULL)
1497     {
1498       label = ffelab_new (label_value);
1499       ffelab_set_firstref_line (label,
1500                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1501       ffelab_set_firstref_column (label,
1502              ffewhere_column_use (ffelex_token_where_column (label_token)));
1503     }
1504
1505   switch (ffelab_type (label))
1506     {
1507     case FFELAB_typeUNKNOWN:
1508     case FFELAB_typeASSIGNABLE:
1509       ffelab_set_type (label, FFELAB_typeNOTLOOP);
1510       ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ()));
1511       break;
1512
1513     case FFELAB_typeLOOPEND:
1514       if (ffelab_blocknum (label) != 0)
1515         break;                  /* Already taken care of. */
1516       for (block = ffestw_top_do (ffestw_stack_top ());
1517            (block != NULL) && (ffestw_label (block) != label);
1518            block = ffestw_top_do (ffestw_previous (block)))
1519         ;                       /* Find most recent DO <label> ancestor. */
1520       if (block == NULL)
1521         {                       /* Reference to within a (dead) block. */
1522           ffebad_start (FFEBAD_LABEL_BLOCK);
1523           ffebad_here (0, ffelab_definition_line (label),
1524                        ffelab_definition_column (label));
1525           ffebad_here (1, ffelex_token_where_line (label_token),
1526                        ffelex_token_where_column (label_token));
1527           ffebad_finish ();
1528           break;
1529         }
1530       ffelab_set_blocknum (label, ffestw_blocknum (block));
1531       ffelab_set_firstref_line (label,
1532                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1533       ffelab_set_firstref_column (label,
1534              ffewhere_column_use (ffelex_token_where_column (label_token)));
1535       break;
1536
1537     case FFELAB_typeNOTLOOP:
1538     case FFELAB_typeENDIF:
1539       if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
1540         break;
1541       blocknum = ffelab_blocknum (label);
1542       for (block = ffestw_stack_top ();
1543            ffestw_blocknum (block) > blocknum;
1544            block = ffestw_previous (block))
1545         ;                       /* Find most recent common ancestor. */
1546       if (ffelab_blocknum (label) == ffestw_blocknum (block))
1547         break;                  /* Check again. */
1548       if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
1549         {                       /* Reference to within a (dead) block. */
1550           ffebad_start (FFEBAD_LABEL_BLOCK);
1551           ffebad_here (0, ffelab_definition_line (label),
1552                        ffelab_definition_column (label));
1553           ffebad_here (1, ffelex_token_where_line (label_token),
1554                        ffelex_token_where_column (label_token));
1555           ffebad_finish ();
1556           break;
1557         }
1558       ffelab_set_blocknum (label, ffestw_blocknum (block));
1559       break;
1560
1561     case FFELAB_typeFORMAT:
1562       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1563         {
1564           ffelab_set_type (label, FFELAB_typeANY);
1565           ffestd_labeldef_any (label);
1566
1567           ffebad_start (FFEBAD_LABEL_USE_USE);
1568           ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1569           ffebad_here (1, ffelex_token_where_line (label_token),
1570                        ffelex_token_where_column (label_token));
1571           ffebad_finish ();
1572
1573           ffestc_try_shriek_do_ ();
1574
1575           return FALSE;
1576         }
1577       /* Fall through. */
1578     case FFELAB_typeUSELESS:
1579       ffelab_set_type (label, FFELAB_typeANY);
1580       ffestd_labeldef_any (label);
1581
1582       ffebad_start (FFEBAD_LABEL_USE_DEF);
1583       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1584       ffebad_here (1, ffelex_token_where_line (label_token),
1585                    ffelex_token_where_column (label_token));
1586       ffebad_finish ();
1587
1588       ffestc_try_shriek_do_ ();
1589
1590       return FALSE;
1591
1592     default:
1593       assert ("bad label" == NULL);
1594       /* Fall through.  */
1595     case FFELAB_typeANY:
1596       break;
1597     }
1598
1599   *x_label = label;
1600   return TRUE;
1601 }
1602
1603 /* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification
1604
1605    if (ffestc_labelref_is_format_(label_token,&label))
1606        // label ref is ok, label is filled in with ffelab object  */
1607
1608 static bool
1609 ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
1610 {
1611   ffelab label;
1612   ffelabValue label_value;
1613
1614   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1615   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1616     {
1617       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1618       ffebad_here (0, ffelex_token_where_line (label_token),
1619                    ffelex_token_where_column (label_token));
1620       ffebad_finish ();
1621       return FALSE;
1622     }
1623
1624   label = ffelab_find (label_value);
1625   if (label == NULL)
1626     {
1627       label = ffelab_new (label_value);
1628       ffelab_set_firstref_line (label,
1629                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1630       ffelab_set_firstref_column (label,
1631              ffewhere_column_use (ffelex_token_where_column (label_token)));
1632     }
1633
1634   switch (ffelab_type (label))
1635     {
1636     case FFELAB_typeUNKNOWN:
1637     case FFELAB_typeASSIGNABLE:
1638       ffelab_set_type (label, FFELAB_typeFORMAT);
1639       break;
1640
1641     case FFELAB_typeFORMAT:
1642       break;
1643
1644     case FFELAB_typeLOOPEND:
1645     case FFELAB_typeNOTLOOP:
1646       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1647         {
1648           ffelab_set_type (label, FFELAB_typeANY);
1649           ffestd_labeldef_any (label);
1650
1651           ffebad_start (FFEBAD_LABEL_USE_USE);
1652           ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1653           ffebad_here (1, ffelex_token_where_line (label_token),
1654                        ffelex_token_where_column (label_token));
1655           ffebad_finish ();
1656
1657           ffestc_try_shriek_do_ ();
1658
1659           return FALSE;
1660         }
1661       /* Fall through. */
1662     case FFELAB_typeUSELESS:
1663     case FFELAB_typeENDIF:
1664       ffelab_set_type (label, FFELAB_typeANY);
1665       ffestd_labeldef_any (label);
1666
1667       ffebad_start (FFEBAD_LABEL_USE_DEF);
1668       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1669       ffebad_here (1, ffelex_token_where_line (label_token),
1670                    ffelex_token_where_column (label_token));
1671       ffebad_finish ();
1672
1673       ffestc_try_shriek_do_ ();
1674
1675       return FALSE;
1676
1677     default:
1678       assert ("bad label" == NULL);
1679       /* Fall through.  */
1680     case FFELAB_typeANY:
1681       break;
1682     }
1683
1684   ffestc_try_shriek_do_ ();
1685
1686   *x_label = label;
1687   return TRUE;
1688 }
1689
1690 /* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt
1691
1692    if (ffestc_labelref_is_loopend_(label_token,&label))
1693        // label ref is ok, label is filled in with ffelab object  */
1694
1695 static bool
1696 ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
1697 {
1698   ffelab label;
1699   ffelabValue label_value;
1700
1701   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
1702   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
1703     {
1704       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
1705       ffebad_here (0, ffelex_token_where_line (label_token),
1706                    ffelex_token_where_column (label_token));
1707       ffebad_finish ();
1708       return FALSE;
1709     }
1710
1711   label = ffelab_find (label_value);
1712   if (label == NULL)
1713     {
1714       label = ffelab_new (label_value);
1715       ffelab_set_doref_line (label,
1716                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1717       ffelab_set_doref_column (label,
1718              ffewhere_column_use (ffelex_token_where_column (label_token)));
1719     }
1720
1721   switch (ffelab_type (label))
1722     {
1723     case FFELAB_typeASSIGNABLE:
1724       ffelab_set_doref_line (label,
1725                  ffewhere_line_use (ffelex_token_where_line (label_token)));
1726       ffelab_set_doref_column (label,
1727              ffewhere_column_use (ffelex_token_where_column (label_token)));
1728       ffewhere_line_kill (ffelab_firstref_line (label));
1729       ffelab_set_firstref_line (label, ffewhere_line_unknown ());
1730       ffewhere_column_kill (ffelab_firstref_column (label));
1731       ffelab_set_firstref_column (label, ffewhere_column_unknown ());
1732       /* Fall through. */
1733     case FFELAB_typeUNKNOWN:
1734       ffelab_set_type (label, FFELAB_typeLOOPEND);
1735       ffelab_set_blocknum (label, 0);
1736       break;
1737
1738     case FFELAB_typeLOOPEND:
1739       if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
1740         {                       /* Def must follow all refs. */
1741           ffelab_set_type (label, FFELAB_typeANY);
1742           ffestd_labeldef_any (label);
1743
1744           ffebad_start (FFEBAD_LABEL_DEF_DO);
1745           ffebad_here (0, ffelab_definition_line (label),
1746                        ffelab_definition_column (label));
1747           ffebad_here (1, ffelex_token_where_line (label_token),
1748                        ffelex_token_where_column (label_token));
1749           ffebad_finish ();
1750
1751           ffestc_try_shriek_do_ ();
1752
1753           return FALSE;
1754         }
1755       if (ffelab_blocknum (label) != 0)
1756         {                       /* Had a branch ref earlier, can't go inside
1757                                    this new block! */
1758           ffelab_set_type (label, FFELAB_typeANY);
1759           ffestd_labeldef_any (label);
1760
1761           ffebad_start (FFEBAD_LABEL_USE_USE);
1762           ffebad_here (0, ffelab_firstref_line (label),
1763                        ffelab_firstref_column (label));
1764           ffebad_here (1, ffelex_token_where_line (label_token),
1765                        ffelex_token_where_column (label_token));
1766           ffebad_finish ();
1767
1768           ffestc_try_shriek_do_ ();
1769
1770           return FALSE;
1771         }
1772       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
1773           || (ffestw_label (ffestw_stack_top ()) != label))
1774         {                       /* Top of stack interrupts flow between two
1775                                    DOs specifying label. */
1776           ffelab_set_type (label, FFELAB_typeANY);
1777           ffestd_labeldef_any (label);
1778
1779           ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO);
1780           ffebad_here (0, ffelab_doref_line (label),
1781                        ffelab_doref_column (label));
1782           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
1783           ffebad_here (2, ffelex_token_where_line (label_token),
1784                        ffelex_token_where_column (label_token));
1785           ffebad_finish ();
1786
1787           ffestc_try_shriek_do_ ();
1788
1789           return FALSE;
1790         }
1791       break;
1792
1793     case FFELAB_typeNOTLOOP:
1794     case FFELAB_typeFORMAT:
1795       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
1796         {
1797           ffelab_set_type (label, FFELAB_typeANY);
1798           ffestd_labeldef_any (label);
1799
1800           ffebad_start (FFEBAD_LABEL_USE_USE);
1801           ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
1802           ffebad_here (1, ffelex_token_where_line (label_token),
1803                        ffelex_token_where_column (label_token));
1804           ffebad_finish ();
1805
1806           ffestc_try_shriek_do_ ();
1807
1808           return FALSE;
1809         }
1810       /* Fall through. */
1811     case FFELAB_typeUSELESS:
1812     case FFELAB_typeENDIF:
1813       ffelab_set_type (label, FFELAB_typeANY);
1814       ffestd_labeldef_any (label);
1815
1816       ffebad_start (FFEBAD_LABEL_USE_DEF);
1817       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
1818       ffebad_here (1, ffelex_token_where_line (label_token),
1819                    ffelex_token_where_column (label_token));
1820       ffebad_finish ();
1821
1822       ffestc_try_shriek_do_ ();
1823
1824       return FALSE;
1825
1826     default:
1827       assert ("bad label" == NULL);
1828       /* Fall through.  */
1829     case FFELAB_typeANY:
1830       break;
1831     }
1832
1833   *x_label = label;
1834   return TRUE;
1835 }
1836
1837 /* ffestc_order_access_ -- Check ordering on <access> statement
1838
1839    if (ffestc_order_access_() != FFESTC_orderOK_)
1840        return;  */
1841
1842 #if FFESTR_F90
1843 static ffestcOrder_
1844 ffestc_order_access_ ()
1845 {
1846   recurse:
1847
1848   switch (ffestw_state (ffestw_stack_top ()))
1849     {
1850     case FFESTV_stateNIL:
1851       ffestc_shriek_begin_program_ ();
1852       goto recurse;             /* :::::::::::::::::::: */
1853
1854     case FFESTV_stateMODULE0:
1855     case FFESTV_stateMODULE1:
1856     case FFESTV_stateMODULE2:
1857       ffestw_update (NULL);
1858       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
1859       return FFESTC_orderOK_;
1860
1861     case FFESTV_stateMODULE3:
1862       return FFESTC_orderOK_;
1863
1864     case FFESTV_stateUSE:
1865 #if FFESTR_F90
1866       ffestc_shriek_end_uses_ (TRUE);
1867 #endif
1868       goto recurse;             /* :::::::::::::::::::: */
1869
1870     case FFESTV_stateWHERE:
1871       ffestc_order_bad_ ();
1872 #if FFESTR_F90
1873       ffestc_shriek_where_ (FALSE);
1874 #endif
1875       return FFESTC_orderBAD_;
1876
1877     case FFESTV_stateIF:
1878       ffestc_order_bad_ ();
1879       ffestc_shriek_if_ (FALSE);
1880       return FFESTC_orderBAD_;
1881
1882     default:
1883       ffestc_order_bad_ ();
1884       return FFESTC_orderBAD_;
1885     }
1886 }
1887
1888 #endif
1889 /* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
1890
1891    if (ffestc_order_actiondo_() != FFESTC_orderOK_)
1892        return;  */
1893
1894 static ffestcOrder_
1895 ffestc_order_actiondo_ ()
1896 {
1897   recurse:
1898
1899   switch (ffestw_state (ffestw_stack_top ()))
1900     {
1901     case FFESTV_stateNIL:
1902       ffestc_shriek_begin_program_ ();
1903       goto recurse;             /* :::::::::::::::::::: */
1904
1905     case FFESTV_stateDO:
1906       return FFESTC_orderOK_;
1907
1908     case FFESTV_stateIFTHEN:
1909     case FFESTV_stateSELECT1:
1910       if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1911         break;
1912       return FFESTC_orderOK_;
1913
1914     case FFESTV_stateIF:
1915       if (ffestw_top_do (ffestw_stack_top ()) == NULL)
1916         break;
1917       ffestc_shriek_after1_ = ffestc_shriek_if_;
1918       return FFESTC_orderOK_;
1919
1920     case FFESTV_stateUSE:
1921 #if FFESTR_F90
1922       ffestc_shriek_end_uses_ (TRUE);
1923 #endif
1924       goto recurse;             /* :::::::::::::::::::: */
1925
1926     case FFESTV_stateWHERE:
1927       ffestc_order_bad_ ();
1928 #if FFESTR_F90
1929       ffestc_shriek_where_ (FALSE);
1930 #endif
1931       return FFESTC_orderBAD_;
1932
1933     default:
1934       break;
1935     }
1936   ffestc_order_bad_ ();
1937   return FFESTC_orderBAD_;
1938 }
1939
1940 /* ffestc_order_actionif_ -- Check ordering on <actionif> statement
1941
1942    if (ffestc_order_actionif_() != FFESTC_orderOK_)
1943        return;  */
1944
1945 static ffestcOrder_
1946 ffestc_order_actionif_ ()
1947 {
1948   bool update;
1949
1950 recurse:
1951
1952   switch (ffestw_state (ffestw_stack_top ()))
1953     {
1954     case FFESTV_stateNIL:
1955       ffestc_shriek_begin_program_ ();
1956       goto recurse;             /* :::::::::::::::::::: */
1957
1958     case FFESTV_statePROGRAM0:
1959     case FFESTV_statePROGRAM1:
1960     case FFESTV_statePROGRAM2:
1961     case FFESTV_statePROGRAM3:
1962       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
1963       update = TRUE;
1964       break;
1965
1966     case FFESTV_stateSUBROUTINE0:
1967     case FFESTV_stateSUBROUTINE1:
1968     case FFESTV_stateSUBROUTINE2:
1969     case FFESTV_stateSUBROUTINE3:
1970       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
1971       update = TRUE;
1972       break;
1973
1974     case FFESTV_stateFUNCTION0:
1975     case FFESTV_stateFUNCTION1:
1976     case FFESTV_stateFUNCTION2:
1977     case FFESTV_stateFUNCTION3:
1978       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
1979       update = TRUE;
1980       break;
1981
1982     case FFESTV_statePROGRAM4:
1983     case FFESTV_stateSUBROUTINE4:
1984     case FFESTV_stateFUNCTION4:
1985       update = FALSE;
1986       break;
1987
1988     case FFESTV_stateIFTHEN:
1989     case FFESTV_stateDO:
1990     case FFESTV_stateSELECT1:
1991       return FFESTC_orderOK_;
1992
1993     case FFESTV_stateIF:
1994       ffestc_shriek_after1_ = ffestc_shriek_if_;
1995       return FFESTC_orderOK_;
1996
1997     case FFESTV_stateUSE:
1998 #if FFESTR_F90
1999       ffestc_shriek_end_uses_ (TRUE);
2000 #endif
2001       goto recurse;             /* :::::::::::::::::::: */
2002
2003     case FFESTV_stateWHERE:
2004       ffestc_order_bad_ ();
2005 #if FFESTR_F90
2006       ffestc_shriek_where_ (FALSE);
2007 #endif
2008       return FFESTC_orderBAD_;
2009
2010     default:
2011       ffestc_order_bad_ ();
2012       return FFESTC_orderBAD_;
2013     }
2014
2015   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2016     {
2017     case FFESTV_stateINTERFACE0:
2018       ffestc_order_bad_ ();
2019       if (update)
2020         ffestw_update (NULL);
2021       return FFESTC_orderBAD_;
2022
2023     default:
2024       if (update)
2025         ffestw_update (NULL);
2026       return FFESTC_orderOK_;
2027     }
2028 }
2029
2030 /* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement
2031
2032    if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
2033        return;  */
2034
2035 static ffestcOrder_
2036 ffestc_order_actionwhere_ ()
2037 {
2038   bool update;
2039
2040 recurse:
2041
2042   switch (ffestw_state (ffestw_stack_top ()))
2043     {
2044     case FFESTV_stateNIL:
2045       ffestc_shriek_begin_program_ ();
2046       goto recurse;             /* :::::::::::::::::::: */
2047
2048     case FFESTV_statePROGRAM0:
2049     case FFESTV_statePROGRAM1:
2050     case FFESTV_statePROGRAM2:
2051     case FFESTV_statePROGRAM3:
2052       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2053       update = TRUE;
2054       break;
2055
2056     case FFESTV_stateSUBROUTINE0:
2057     case FFESTV_stateSUBROUTINE1:
2058     case FFESTV_stateSUBROUTINE2:
2059     case FFESTV_stateSUBROUTINE3:
2060       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2061       update = TRUE;
2062       break;
2063
2064     case FFESTV_stateFUNCTION0:
2065     case FFESTV_stateFUNCTION1:
2066     case FFESTV_stateFUNCTION2:
2067     case FFESTV_stateFUNCTION3:
2068       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2069       update = TRUE;
2070       break;
2071
2072     case FFESTV_statePROGRAM4:
2073     case FFESTV_stateSUBROUTINE4:
2074     case FFESTV_stateFUNCTION4:
2075       update = FALSE;
2076       break;
2077
2078     case FFESTV_stateWHERETHEN:
2079     case FFESTV_stateIFTHEN:
2080     case FFESTV_stateDO:
2081     case FFESTV_stateSELECT1:
2082       return FFESTC_orderOK_;
2083
2084     case FFESTV_stateWHERE:
2085 #if FFESTR_F90
2086       ffestc_shriek_after1_ = ffestc_shriek_where_;
2087 #endif
2088       return FFESTC_orderOK_;
2089
2090     case FFESTV_stateIF:
2091       ffestc_shriek_after1_ = ffestc_shriek_if_;
2092       return FFESTC_orderOK_;
2093
2094     case FFESTV_stateUSE:
2095 #if FFESTR_F90
2096       ffestc_shriek_end_uses_ (TRUE);
2097 #endif
2098       goto recurse;             /* :::::::::::::::::::: */
2099
2100     default:
2101       ffestc_order_bad_ ();
2102       return FFESTC_orderBAD_;
2103     }
2104
2105   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2106     {
2107     case FFESTV_stateINTERFACE0:
2108       ffestc_order_bad_ ();
2109       if (update)
2110         ffestw_update (NULL);
2111       return FFESTC_orderBAD_;
2112
2113     default:
2114       if (update)
2115         ffestw_update (NULL);
2116       return FFESTC_orderOK_;
2117     }
2118 }
2119
2120 /* Check ordering on "any" statement.  Like _actionwhere_, but
2121    doesn't produce any diagnostics.  */
2122
2123 static void
2124 ffestc_order_any_ ()
2125 {
2126   bool update;
2127
2128 recurse:
2129
2130   switch (ffestw_state (ffestw_stack_top ()))
2131     {
2132     case FFESTV_stateNIL:
2133       ffestc_shriek_begin_program_ ();
2134       goto recurse;             /* :::::::::::::::::::: */
2135
2136     case FFESTV_statePROGRAM0:
2137     case FFESTV_statePROGRAM1:
2138     case FFESTV_statePROGRAM2:
2139     case FFESTV_statePROGRAM3:
2140       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2141       update = TRUE;
2142       break;
2143
2144     case FFESTV_stateSUBROUTINE0:
2145     case FFESTV_stateSUBROUTINE1:
2146     case FFESTV_stateSUBROUTINE2:
2147     case FFESTV_stateSUBROUTINE3:
2148       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2149       update = TRUE;
2150       break;
2151
2152     case FFESTV_stateFUNCTION0:
2153     case FFESTV_stateFUNCTION1:
2154     case FFESTV_stateFUNCTION2:
2155     case FFESTV_stateFUNCTION3:
2156       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2157       update = TRUE;
2158       break;
2159
2160     case FFESTV_statePROGRAM4:
2161     case FFESTV_stateSUBROUTINE4:
2162     case FFESTV_stateFUNCTION4:
2163       update = FALSE;
2164       break;
2165
2166     case FFESTV_stateWHERETHEN:
2167     case FFESTV_stateIFTHEN:
2168     case FFESTV_stateDO:
2169     case FFESTV_stateSELECT1:
2170       return;
2171
2172     case FFESTV_stateWHERE:
2173 #if FFESTR_F90
2174       ffestc_shriek_after1_ = ffestc_shriek_where_;
2175 #endif
2176       return;
2177
2178     case FFESTV_stateIF:
2179       ffestc_shriek_after1_ = ffestc_shriek_if_;
2180       return;
2181
2182     case FFESTV_stateUSE:
2183 #if FFESTR_F90
2184       ffestc_shriek_end_uses_ (TRUE);
2185 #endif
2186       goto recurse;             /* :::::::::::::::::::: */
2187
2188     default:
2189       return;
2190     }
2191
2192   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2193     {
2194     case FFESTV_stateINTERFACE0:
2195       if (update)
2196         ffestw_update (NULL);
2197       return;
2198
2199     default:
2200       if (update)
2201         ffestw_update (NULL);
2202       return;
2203     }
2204 }
2205
2206 /* ffestc_order_bad_ -- Whine about statement ordering violation
2207
2208    ffestc_order_bad_();
2209
2210    Uses current ffesta_tokens[0] and, if available, info on where current
2211    state started to produce generic message.  Someday we should do
2212    fancier things than this, but this just gets things creaking along for
2213    now.  */
2214
2215 static void
2216 ffestc_order_bad_ ()
2217 {
2218   if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
2219     {
2220       ffebad_start (FFEBAD_ORDER_1);
2221       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2222                    ffelex_token_where_column (ffesta_tokens[0]));
2223       ffebad_finish ();
2224     }
2225   else
2226     {
2227       ffebad_start (FFEBAD_ORDER_2);
2228       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2229                    ffelex_token_where_column (ffesta_tokens[0]));
2230       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
2231       ffebad_finish ();
2232     }
2233   ffestc_labeldef_useless_ ();  /* Any label definition is useless. */
2234 }
2235
2236 /* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement
2237
2238    if (ffestc_order_blockdata_() != FFESTC_orderOK_)
2239        return;  */
2240
2241 static ffestcOrder_
2242 ffestc_order_blockdata_ ()
2243 {
2244   recurse:
2245
2246   switch (ffestw_state (ffestw_stack_top ()))
2247     {
2248     case FFESTV_stateBLOCKDATA0:
2249     case FFESTV_stateBLOCKDATA1:
2250     case FFESTV_stateBLOCKDATA2:
2251     case FFESTV_stateBLOCKDATA3:
2252     case FFESTV_stateBLOCKDATA4:
2253     case FFESTV_stateBLOCKDATA5:
2254       return FFESTC_orderOK_;
2255
2256     case FFESTV_stateUSE:
2257 #if FFESTR_F90
2258       ffestc_shriek_end_uses_ (TRUE);
2259 #endif
2260       goto recurse;             /* :::::::::::::::::::: */
2261
2262     case FFESTV_stateWHERE:
2263       ffestc_order_bad_ ();
2264 #if FFESTR_F90
2265       ffestc_shriek_where_ (FALSE);
2266 #endif
2267       return FFESTC_orderBAD_;
2268
2269     case FFESTV_stateIF:
2270       ffestc_order_bad_ ();
2271       ffestc_shriek_if_ (FALSE);
2272       return FFESTC_orderBAD_;
2273
2274     default:
2275       ffestc_order_bad_ ();
2276       return FFESTC_orderBAD_;
2277     }
2278 }
2279
2280 /* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement
2281
2282    if (ffestc_order_blockspec_() != FFESTC_orderOK_)
2283        return;  */
2284
2285 static ffestcOrder_
2286 ffestc_order_blockspec_ ()
2287 {
2288   recurse:
2289
2290   switch (ffestw_state (ffestw_stack_top ()))
2291     {
2292     case FFESTV_stateNIL:
2293       ffestc_shriek_begin_program_ ();
2294       goto recurse;             /* :::::::::::::::::::: */
2295
2296     case FFESTV_statePROGRAM0:
2297     case FFESTV_statePROGRAM1:
2298     case FFESTV_statePROGRAM2:
2299       ffestw_update (NULL);
2300       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
2301       return FFESTC_orderOK_;
2302
2303     case FFESTV_stateSUBROUTINE0:
2304     case FFESTV_stateSUBROUTINE1:
2305     case FFESTV_stateSUBROUTINE2:
2306       ffestw_update (NULL);
2307       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
2308       return FFESTC_orderOK_;
2309
2310     case FFESTV_stateFUNCTION0:
2311     case FFESTV_stateFUNCTION1:
2312     case FFESTV_stateFUNCTION2:
2313       ffestw_update (NULL);
2314       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
2315       return FFESTC_orderOK_;
2316
2317     case FFESTV_stateMODULE0:
2318     case FFESTV_stateMODULE1:
2319     case FFESTV_stateMODULE2:
2320       ffestw_update (NULL);
2321       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
2322       return FFESTC_orderOK_;
2323
2324     case FFESTV_stateBLOCKDATA0:
2325     case FFESTV_stateBLOCKDATA1:
2326     case FFESTV_stateBLOCKDATA2:
2327       ffestw_update (NULL);
2328       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
2329       return FFESTC_orderOK_;
2330
2331     case FFESTV_statePROGRAM3:
2332     case FFESTV_stateSUBROUTINE3:
2333     case FFESTV_stateFUNCTION3:
2334     case FFESTV_stateMODULE3:
2335     case FFESTV_stateBLOCKDATA3:
2336       return FFESTC_orderOK_;
2337
2338     case FFESTV_stateUSE:
2339 #if FFESTR_F90
2340       ffestc_shriek_end_uses_ (TRUE);
2341 #endif
2342       goto recurse;             /* :::::::::::::::::::: */
2343
2344     case FFESTV_stateWHERE:
2345       ffestc_order_bad_ ();
2346 #if FFESTR_F90
2347       ffestc_shriek_where_ (FALSE);
2348 #endif
2349       return FFESTC_orderBAD_;
2350
2351     case FFESTV_stateIF:
2352       ffestc_order_bad_ ();
2353       ffestc_shriek_if_ (FALSE);
2354       return FFESTC_orderBAD_;
2355
2356     default:
2357       ffestc_order_bad_ ();
2358       return FFESTC_orderBAD_;
2359     }
2360 }
2361
2362 /* ffestc_order_component_ -- Check ordering on <component-decl> statement
2363
2364    if (ffestc_order_component_() != FFESTC_orderOK_)
2365        return;  */
2366
2367 #if FFESTR_F90
2368 static ffestcOrder_
2369 ffestc_order_component_ ()
2370 {
2371   switch (ffestw_state (ffestw_stack_top ()))
2372     {
2373     case FFESTV_stateTYPE:
2374     case FFESTV_stateSTRUCTURE:
2375     case FFESTV_stateMAP:
2376       return FFESTC_orderOK_;
2377
2378     case FFESTV_stateWHERE:
2379       ffestc_order_bad_ ();
2380       ffestc_shriek_where_ (FALSE);
2381       return FFESTC_orderBAD_;
2382
2383     case FFESTV_stateIF:
2384       ffestc_order_bad_ ();
2385       ffestc_shriek_if_ (FALSE);
2386       return FFESTC_orderBAD_;
2387
2388     default:
2389       ffestc_order_bad_ ();
2390       return FFESTC_orderBAD_;
2391     }
2392 }
2393
2394 #endif
2395 /* ffestc_order_contains_ -- Check ordering on CONTAINS statement
2396
2397    if (ffestc_order_contains_() != FFESTC_orderOK_)
2398        return;  */
2399
2400 #if FFESTR_F90
2401 static ffestcOrder_
2402 ffestc_order_contains_ ()
2403 {
2404   recurse:
2405
2406   switch (ffestw_state (ffestw_stack_top ()))
2407     {
2408     case FFESTV_stateNIL:
2409       ffestc_shriek_begin_program_ ();
2410       goto recurse;             /* :::::::::::::::::::: */
2411
2412     case FFESTV_statePROGRAM0:
2413     case FFESTV_statePROGRAM1:
2414     case FFESTV_statePROGRAM2:
2415     case FFESTV_statePROGRAM3:
2416     case FFESTV_statePROGRAM4:
2417       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5);
2418       break;
2419
2420     case FFESTV_stateSUBROUTINE0:
2421     case FFESTV_stateSUBROUTINE1:
2422     case FFESTV_stateSUBROUTINE2:
2423     case FFESTV_stateSUBROUTINE3:
2424     case FFESTV_stateSUBROUTINE4:
2425       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5);
2426       break;
2427
2428     case FFESTV_stateFUNCTION0:
2429     case FFESTV_stateFUNCTION1:
2430     case FFESTV_stateFUNCTION2:
2431     case FFESTV_stateFUNCTION3:
2432     case FFESTV_stateFUNCTION4:
2433       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5);
2434       break;
2435
2436     case FFESTV_stateMODULE0:
2437     case FFESTV_stateMODULE1:
2438     case FFESTV_stateMODULE2:
2439     case FFESTV_stateMODULE3:
2440     case FFESTV_stateMODULE4:
2441       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5);
2442       break;
2443
2444     case FFESTV_stateUSE:
2445       ffestc_shriek_end_uses_ (TRUE);
2446       goto recurse;             /* :::::::::::::::::::: */
2447
2448     case FFESTV_stateWHERE:
2449       ffestc_order_bad_ ();
2450       ffestc_shriek_where_ (FALSE);
2451       return FFESTC_orderBAD_;
2452
2453     case FFESTV_stateIF:
2454       ffestc_order_bad_ ();
2455       ffestc_shriek_if_ (FALSE);
2456       return FFESTC_orderBAD_;
2457
2458     default:
2459       ffestc_order_bad_ ();
2460       return FFESTC_orderBAD_;
2461     }
2462
2463   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2464     {
2465     case FFESTV_stateNIL:
2466       ffestw_update (NULL);
2467       return FFESTC_orderOK_;
2468
2469     default:
2470       ffestc_order_bad_ ();
2471       ffestw_update (NULL);
2472       return FFESTC_orderBAD_;
2473     }
2474 }
2475
2476 #endif
2477 /* ffestc_order_data_ -- Check ordering on DATA statement
2478
2479    if (ffestc_order_data_() != FFESTC_orderOK_)
2480        return;  */
2481
2482 static ffestcOrder_
2483 ffestc_order_data_ ()
2484 {
2485   recurse:
2486
2487   switch (ffestw_state (ffestw_stack_top ()))
2488     {
2489     case FFESTV_stateNIL:
2490       ffestc_shriek_begin_program_ ();
2491       goto recurse;             /* :::::::::::::::::::: */
2492
2493     case FFESTV_statePROGRAM0:
2494     case FFESTV_statePROGRAM1:
2495       ffestw_update (NULL);
2496       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
2497       return FFESTC_orderOK_;
2498
2499     case FFESTV_stateSUBROUTINE0:
2500     case FFESTV_stateSUBROUTINE1:
2501       ffestw_update (NULL);
2502       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
2503       return FFESTC_orderOK_;
2504
2505     case FFESTV_stateFUNCTION0:
2506     case FFESTV_stateFUNCTION1:
2507       ffestw_update (NULL);
2508       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
2509       return FFESTC_orderOK_;
2510
2511     case FFESTV_stateBLOCKDATA0:
2512     case FFESTV_stateBLOCKDATA1:
2513       ffestw_update (NULL);
2514       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
2515       return FFESTC_orderOK_;
2516
2517     case FFESTV_statePROGRAM2:
2518     case FFESTV_stateSUBROUTINE2:
2519     case FFESTV_stateFUNCTION2:
2520     case FFESTV_stateBLOCKDATA2:
2521     case FFESTV_statePROGRAM3:
2522     case FFESTV_stateSUBROUTINE3:
2523     case FFESTV_stateFUNCTION3:
2524     case FFESTV_stateBLOCKDATA3:
2525     case FFESTV_statePROGRAM4:
2526     case FFESTV_stateSUBROUTINE4:
2527     case FFESTV_stateFUNCTION4:
2528     case FFESTV_stateBLOCKDATA4:
2529     case FFESTV_stateWHERETHEN:
2530     case FFESTV_stateIFTHEN:
2531     case FFESTV_stateDO:
2532     case FFESTV_stateSELECT0:
2533     case FFESTV_stateSELECT1:
2534       return FFESTC_orderOK_;
2535
2536     case FFESTV_stateUSE:
2537 #if FFESTR_F90
2538       ffestc_shriek_end_uses_ (TRUE);
2539 #endif
2540       goto recurse;             /* :::::::::::::::::::: */
2541
2542     case FFESTV_stateWHERE:
2543       ffestc_order_bad_ ();
2544 #if FFESTR_F90
2545       ffestc_shriek_where_ (FALSE);
2546 #endif
2547       return FFESTC_orderBAD_;
2548
2549     case FFESTV_stateIF:
2550       ffestc_order_bad_ ();
2551       ffestc_shriek_if_ (FALSE);
2552       return FFESTC_orderBAD_;
2553
2554     default:
2555       ffestc_order_bad_ ();
2556       return FFESTC_orderBAD_;
2557     }
2558 }
2559
2560 /* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement
2561
2562    if (ffestc_order_data77_() != FFESTC_orderOK_)
2563        return;  */
2564
2565 static ffestcOrder_
2566 ffestc_order_data77_ ()
2567 {
2568   recurse:
2569
2570   switch (ffestw_state (ffestw_stack_top ()))
2571     {
2572     case FFESTV_stateNIL:
2573       ffestc_shriek_begin_program_ ();
2574       goto recurse;             /* :::::::::::::::::::: */
2575
2576     case FFESTV_statePROGRAM0:
2577     case FFESTV_statePROGRAM1:
2578     case FFESTV_statePROGRAM2:
2579     case FFESTV_statePROGRAM3:
2580       ffestw_update (NULL);
2581       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2582       return FFESTC_orderOK_;
2583
2584     case FFESTV_stateSUBROUTINE0:
2585     case FFESTV_stateSUBROUTINE1:
2586     case FFESTV_stateSUBROUTINE2:
2587     case FFESTV_stateSUBROUTINE3:
2588       ffestw_update (NULL);
2589       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2590       return FFESTC_orderOK_;
2591
2592     case FFESTV_stateFUNCTION0:
2593     case FFESTV_stateFUNCTION1:
2594     case FFESTV_stateFUNCTION2:
2595     case FFESTV_stateFUNCTION3:
2596       ffestw_update (NULL);
2597       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2598       return FFESTC_orderOK_;
2599
2600     case FFESTV_stateBLOCKDATA0:
2601     case FFESTV_stateBLOCKDATA1:
2602     case FFESTV_stateBLOCKDATA2:
2603     case FFESTV_stateBLOCKDATA3:
2604       ffestw_update (NULL);
2605       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4);
2606       return FFESTC_orderOK_;
2607
2608     case FFESTV_statePROGRAM4:
2609     case FFESTV_stateSUBROUTINE4:
2610     case FFESTV_stateFUNCTION4:
2611     case FFESTV_stateBLOCKDATA4:
2612       return FFESTC_orderOK_;
2613
2614     case FFESTV_stateWHERETHEN:
2615     case FFESTV_stateIFTHEN:
2616     case FFESTV_stateDO:
2617     case FFESTV_stateSELECT0:
2618     case FFESTV_stateSELECT1:
2619       return FFESTC_orderOK_;
2620
2621     case FFESTV_stateUSE:
2622 #if FFESTR_F90
2623       ffestc_shriek_end_uses_ (TRUE);
2624 #endif
2625       goto recurse;             /* :::::::::::::::::::: */
2626
2627     case FFESTV_stateWHERE:
2628       ffestc_order_bad_ ();
2629 #if FFESTR_F90
2630       ffestc_shriek_where_ (FALSE);
2631 #endif
2632       return FFESTC_orderBAD_;
2633
2634     case FFESTV_stateIF:
2635       ffestc_order_bad_ ();
2636       ffestc_shriek_if_ (FALSE);
2637       return FFESTC_orderBAD_;
2638
2639     default:
2640       ffestc_order_bad_ ();
2641       return FFESTC_orderBAD_;
2642     }
2643 }
2644
2645 /* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement
2646
2647    if (ffestc_order_derivedtype_() != FFESTC_orderOK_)
2648        return;  */
2649
2650 #if FFESTR_F90
2651 static ffestcOrder_
2652 ffestc_order_derivedtype_ ()
2653 {
2654   recurse:
2655
2656   switch (ffestw_state (ffestw_stack_top ()))
2657     {
2658     case FFESTV_stateNIL:
2659       ffestc_shriek_begin_program_ ();
2660       goto recurse;             /* :::::::::::::::::::: */
2661
2662     case FFESTV_statePROGRAM0:
2663     case FFESTV_statePROGRAM1:
2664     case FFESTV_statePROGRAM2:
2665       ffestw_update (NULL);
2666       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
2667       return FFESTC_orderOK_;
2668
2669     case FFESTV_stateSUBROUTINE0:
2670     case FFESTV_stateSUBROUTINE1:
2671     case FFESTV_stateSUBROUTINE2:
2672       ffestw_update (NULL);
2673       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
2674       return FFESTC_orderOK_;
2675
2676     case FFESTV_stateFUNCTION0:
2677     case FFESTV_stateFUNCTION1:
2678     case FFESTV_stateFUNCTION2:
2679       ffestw_update (NULL);
2680       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
2681       return FFESTC_orderOK_;
2682
2683     case FFESTV_stateMODULE0:
2684     case FFESTV_stateMODULE1:
2685     case FFESTV_stateMODULE2:
2686       ffestw_update (NULL);
2687       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
2688       return FFESTC_orderOK_;
2689
2690     case FFESTV_statePROGRAM3:
2691     case FFESTV_stateSUBROUTINE3:
2692     case FFESTV_stateFUNCTION3:
2693     case FFESTV_stateMODULE3:
2694       return FFESTC_orderOK_;
2695
2696     case FFESTV_stateUSE:
2697       ffestc_shriek_end_uses_ (TRUE);
2698       goto recurse;             /* :::::::::::::::::::: */
2699
2700     case FFESTV_stateWHERE:
2701       ffestc_order_bad_ ();
2702       ffestc_shriek_where_ (FALSE);
2703       return FFESTC_orderBAD_;
2704
2705     case FFESTV_stateIF:
2706       ffestc_order_bad_ ();
2707       ffestc_shriek_if_ (FALSE);
2708       return FFESTC_orderBAD_;
2709
2710     default:
2711       ffestc_order_bad_ ();
2712       return FFESTC_orderBAD_;
2713     }
2714 }
2715
2716 #endif
2717 /* ffestc_order_do_ -- Check ordering on <do> statement
2718
2719    if (ffestc_order_do_() != FFESTC_orderOK_)
2720        return;  */
2721
2722 static ffestcOrder_
2723 ffestc_order_do_ ()
2724 {
2725   switch (ffestw_state (ffestw_stack_top ()))
2726     {
2727     case FFESTV_stateDO:
2728       return FFESTC_orderOK_;
2729
2730     case FFESTV_stateWHERE:
2731       ffestc_order_bad_ ();
2732 #if FFESTR_F90
2733       ffestc_shriek_where_ (FALSE);
2734 #endif
2735       return FFESTC_orderBAD_;
2736
2737     case FFESTV_stateIF:
2738       ffestc_order_bad_ ();
2739       ffestc_shriek_if_ (FALSE);
2740       return FFESTC_orderBAD_;
2741
2742     default:
2743       ffestc_order_bad_ ();
2744       return FFESTC_orderBAD_;
2745     }
2746 }
2747
2748 /* ffestc_order_entry_ -- Check ordering on ENTRY statement
2749
2750    if (ffestc_order_entry_() != FFESTC_orderOK_)
2751        return;  */
2752
2753 static ffestcOrder_
2754 ffestc_order_entry_ ()
2755 {
2756   recurse:
2757
2758   switch (ffestw_state (ffestw_stack_top ()))
2759     {
2760     case FFESTV_stateNIL:
2761       ffestc_shriek_begin_program_ ();
2762       goto recurse;             /* :::::::::::::::::::: */
2763
2764     case FFESTV_stateSUBROUTINE0:
2765       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2766       break;
2767
2768     case FFESTV_stateFUNCTION0:
2769       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2770       break;
2771
2772     case FFESTV_stateSUBROUTINE1:
2773     case FFESTV_stateSUBROUTINE2:
2774     case FFESTV_stateFUNCTION1:
2775     case FFESTV_stateFUNCTION2:
2776     case FFESTV_stateSUBROUTINE3:
2777     case FFESTV_stateFUNCTION3:
2778     case FFESTV_stateSUBROUTINE4:
2779     case FFESTV_stateFUNCTION4:
2780       break;
2781
2782     case FFESTV_stateUSE:
2783 #if FFESTR_F90
2784       ffestc_shriek_end_uses_ (TRUE);
2785 #endif
2786       goto recurse;             /* :::::::::::::::::::: */
2787
2788     case FFESTV_stateWHERE:
2789       ffestc_order_bad_ ();
2790 #if FFESTR_F90
2791       ffestc_shriek_where_ (FALSE);
2792 #endif
2793       return FFESTC_orderBAD_;
2794
2795     case FFESTV_stateIF:
2796       ffestc_order_bad_ ();
2797       ffestc_shriek_if_ (FALSE);
2798       return FFESTC_orderBAD_;
2799
2800     default:
2801       ffestc_order_bad_ ();
2802       return FFESTC_orderBAD_;
2803     }
2804
2805   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2806     {
2807     case FFESTV_stateNIL:
2808     case FFESTV_stateMODULE5:
2809       ffestw_update (NULL);
2810       return FFESTC_orderOK_;
2811
2812     default:
2813       ffestc_order_bad_ ();
2814       ffestw_update (NULL);
2815       return FFESTC_orderBAD_;
2816     }
2817 }
2818
2819 /* ffestc_order_exec_ -- Check ordering on <exec> statement
2820
2821    if (ffestc_order_exec_() != FFESTC_orderOK_)
2822        return;  */
2823
2824 static ffestcOrder_
2825 ffestc_order_exec_ ()
2826 {
2827   bool update;
2828
2829 recurse:
2830
2831   switch (ffestw_state (ffestw_stack_top ()))
2832     {
2833     case FFESTV_stateNIL:
2834       ffestc_shriek_begin_program_ ();
2835       goto recurse;             /* :::::::::::::::::::: */
2836
2837     case FFESTV_statePROGRAM0:
2838     case FFESTV_statePROGRAM1:
2839     case FFESTV_statePROGRAM2:
2840     case FFESTV_statePROGRAM3:
2841       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
2842       update = TRUE;
2843       break;
2844
2845     case FFESTV_stateSUBROUTINE0:
2846     case FFESTV_stateSUBROUTINE1:
2847     case FFESTV_stateSUBROUTINE2:
2848     case FFESTV_stateSUBROUTINE3:
2849       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
2850       update = TRUE;
2851       break;
2852
2853     case FFESTV_stateFUNCTION0:
2854     case FFESTV_stateFUNCTION1:
2855     case FFESTV_stateFUNCTION2:
2856     case FFESTV_stateFUNCTION3:
2857       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
2858       update = TRUE;
2859       break;
2860
2861     case FFESTV_statePROGRAM4:
2862     case FFESTV_stateSUBROUTINE4:
2863     case FFESTV_stateFUNCTION4:
2864       update = FALSE;
2865       break;
2866
2867     case FFESTV_stateIFTHEN:
2868     case FFESTV_stateDO:
2869     case FFESTV_stateSELECT1:
2870       return FFESTC_orderOK_;
2871
2872     case FFESTV_stateUSE:
2873 #if FFESTR_F90
2874       ffestc_shriek_end_uses_ (TRUE);
2875 #endif
2876       goto recurse;             /* :::::::::::::::::::: */
2877
2878     case FFESTV_stateWHERE:
2879       ffestc_order_bad_ ();
2880 #if FFESTR_F90
2881       ffestc_shriek_where_ (FALSE);
2882 #endif
2883       return FFESTC_orderBAD_;
2884
2885     case FFESTV_stateIF:
2886       ffestc_order_bad_ ();
2887       ffestc_shriek_if_ (FALSE);
2888       return FFESTC_orderBAD_;
2889
2890     default:
2891       ffestc_order_bad_ ();
2892       return FFESTC_orderBAD_;
2893     }
2894
2895   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
2896     {
2897     case FFESTV_stateINTERFACE0:
2898       ffestc_order_bad_ ();
2899       if (update)
2900         ffestw_update (NULL);
2901       return FFESTC_orderBAD_;
2902
2903     default:
2904       if (update)
2905         ffestw_update (NULL);
2906       return FFESTC_orderOK_;
2907     }
2908 }
2909
2910 /* ffestc_order_format_ -- Check ordering on FORMAT statement
2911
2912    if (ffestc_order_format_() != FFESTC_orderOK_)
2913        return;  */
2914
2915 static ffestcOrder_
2916 ffestc_order_format_ ()
2917 {
2918   recurse:
2919
2920   switch (ffestw_state (ffestw_stack_top ()))
2921     {
2922     case FFESTV_stateNIL:
2923       ffestc_shriek_begin_program_ ();
2924       goto recurse;             /* :::::::::::::::::::: */
2925
2926     case FFESTV_statePROGRAM0:
2927       ffestw_update (NULL);
2928       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
2929       return FFESTC_orderOK_;
2930
2931     case FFESTV_stateSUBROUTINE0:
2932       ffestw_update (NULL);
2933       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
2934       return FFESTC_orderOK_;
2935
2936     case FFESTV_stateFUNCTION0:
2937       ffestw_update (NULL);
2938       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
2939       return FFESTC_orderOK_;
2940
2941     case FFESTV_statePROGRAM1:
2942     case FFESTV_statePROGRAM2:
2943     case FFESTV_stateSUBROUTINE1:
2944     case FFESTV_stateSUBROUTINE2:
2945     case FFESTV_stateFUNCTION1:
2946     case FFESTV_stateFUNCTION2:
2947     case FFESTV_statePROGRAM3:
2948     case FFESTV_stateSUBROUTINE3:
2949     case FFESTV_stateFUNCTION3:
2950     case FFESTV_statePROGRAM4:
2951     case FFESTV_stateSUBROUTINE4:
2952     case FFESTV_stateFUNCTION4:
2953     case FFESTV_stateWHERETHEN:
2954     case FFESTV_stateIFTHEN:
2955     case FFESTV_stateDO:
2956     case FFESTV_stateSELECT0:
2957     case FFESTV_stateSELECT1:
2958       return FFESTC_orderOK_;
2959
2960     case FFESTV_stateUSE:
2961 #if FFESTR_F90
2962       ffestc_shriek_end_uses_ (TRUE);
2963 #endif
2964       goto recurse;             /* :::::::::::::::::::: */
2965
2966     case FFESTV_stateWHERE:
2967       ffestc_order_bad_ ();
2968 #if FFESTR_F90
2969       ffestc_shriek_where_ (FALSE);
2970 #endif
2971       return FFESTC_orderBAD_;
2972
2973     case FFESTV_stateIF:
2974       ffestc_order_bad_ ();
2975       ffestc_shriek_if_ (FALSE);
2976       return FFESTC_orderBAD_;
2977
2978     default:
2979       ffestc_order_bad_ ();
2980       return FFESTC_orderBAD_;
2981     }
2982 }
2983
2984 /* ffestc_order_function_ -- Check ordering on <function> statement
2985
2986    if (ffestc_order_function_() != FFESTC_orderOK_)
2987        return;  */
2988
2989 static ffestcOrder_
2990 ffestc_order_function_ ()
2991 {
2992   recurse:
2993
2994   switch (ffestw_state (ffestw_stack_top ()))
2995     {
2996     case FFESTV_stateFUNCTION0:
2997     case FFESTV_stateFUNCTION1:
2998     case FFESTV_stateFUNCTION2:
2999     case FFESTV_stateFUNCTION3:
3000     case FFESTV_stateFUNCTION4:
3001     case FFESTV_stateFUNCTION5:
3002       return FFESTC_orderOK_;
3003
3004     case FFESTV_stateUSE:
3005 #if FFESTR_F90
3006       ffestc_shriek_end_uses_ (TRUE);
3007 #endif
3008       goto recurse;             /* :::::::::::::::::::: */
3009
3010     case FFESTV_stateWHERE:
3011       ffestc_order_bad_ ();
3012 #if FFESTR_F90
3013       ffestc_shriek_where_ (FALSE);
3014 #endif
3015       return FFESTC_orderBAD_;
3016
3017     case FFESTV_stateIF:
3018       ffestc_order_bad_ ();
3019       ffestc_shriek_if_ (FALSE);
3020       return FFESTC_orderBAD_;
3021
3022     default:
3023       ffestc_order_bad_ ();
3024       return FFESTC_orderBAD_;
3025     }
3026 }
3027
3028 /* ffestc_order_iface_ -- Check ordering on <iface> statement
3029
3030    if (ffestc_order_iface_() != FFESTC_orderOK_)
3031        return;  */
3032
3033 static ffestcOrder_
3034 ffestc_order_iface_ ()
3035 {
3036   switch (ffestw_state (ffestw_stack_top ()))
3037     {
3038     case FFESTV_stateNIL:
3039     case FFESTV_statePROGRAM5:
3040     case FFESTV_stateSUBROUTINE5:
3041     case FFESTV_stateFUNCTION5:
3042     case FFESTV_stateMODULE5:
3043     case FFESTV_stateINTERFACE0:
3044       return FFESTC_orderOK_;
3045
3046     case FFESTV_stateWHERE:
3047       ffestc_order_bad_ ();
3048 #if FFESTR_F90
3049       ffestc_shriek_where_ (FALSE);
3050 #endif
3051       return FFESTC_orderBAD_;
3052
3053     case FFESTV_stateIF:
3054       ffestc_order_bad_ ();
3055       ffestc_shriek_if_ (FALSE);
3056       return FFESTC_orderBAD_;
3057
3058     default:
3059       ffestc_order_bad_ ();
3060       return FFESTC_orderBAD_;
3061     }
3062 }
3063
3064 /* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement
3065
3066    if (ffestc_order_ifthen_() != FFESTC_orderOK_)
3067        return;  */
3068
3069 static ffestcOrder_
3070 ffestc_order_ifthen_ ()
3071 {
3072   switch (ffestw_state (ffestw_stack_top ()))
3073     {
3074     case FFESTV_stateIFTHEN:
3075       return FFESTC_orderOK_;
3076
3077     case FFESTV_stateWHERE:
3078       ffestc_order_bad_ ();
3079 #if FFESTR_F90
3080       ffestc_shriek_where_ (FALSE);
3081 #endif
3082       return FFESTC_orderBAD_;
3083
3084     case FFESTV_stateIF:
3085       ffestc_order_bad_ ();
3086       ffestc_shriek_if_ (FALSE);
3087       return FFESTC_orderBAD_;
3088
3089     default:
3090       ffestc_order_bad_ ();
3091       return FFESTC_orderBAD_;
3092     }
3093 }
3094
3095 /* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement
3096
3097    if (ffestc_order_implicit_() != FFESTC_orderOK_)
3098        return;  */
3099
3100 static ffestcOrder_
3101 ffestc_order_implicit_ ()
3102 {
3103   recurse:
3104
3105   switch (ffestw_state (ffestw_stack_top ()))
3106     {
3107     case FFESTV_stateNIL:
3108       ffestc_shriek_begin_program_ ();
3109       goto recurse;             /* :::::::::::::::::::: */
3110
3111     case FFESTV_statePROGRAM0:
3112     case FFESTV_statePROGRAM1:
3113       ffestw_update (NULL);
3114       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
3115       return FFESTC_orderOK_;
3116
3117     case FFESTV_stateSUBROUTINE0:
3118     case FFESTV_stateSUBROUTINE1:
3119       ffestw_update (NULL);
3120       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
3121       return FFESTC_orderOK_;
3122
3123     case FFESTV_stateFUNCTION0:
3124     case FFESTV_stateFUNCTION1:
3125       ffestw_update (NULL);
3126       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
3127       return FFESTC_orderOK_;
3128
3129     case FFESTV_stateMODULE0:
3130     case FFESTV_stateMODULE1:
3131       ffestw_update (NULL);
3132       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
3133       return FFESTC_orderOK_;
3134
3135     case FFESTV_stateBLOCKDATA0:
3136     case FFESTV_stateBLOCKDATA1:
3137       ffestw_update (NULL);
3138       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
3139       return FFESTC_orderOK_;
3140
3141     case FFESTV_statePROGRAM2:
3142     case FFESTV_stateSUBROUTINE2:
3143     case FFESTV_stateFUNCTION2:
3144     case FFESTV_stateMODULE2:
3145     case FFESTV_stateBLOCKDATA2:
3146       return FFESTC_orderOK_;
3147
3148     case FFESTV_stateUSE:
3149 #if FFESTR_F90
3150       ffestc_shriek_end_uses_ (TRUE);
3151 #endif
3152       goto recurse;             /* :::::::::::::::::::: */
3153
3154     case FFESTV_stateWHERE:
3155       ffestc_order_bad_ ();
3156 #if FFESTR_F90
3157       ffestc_shriek_where_ (FALSE);
3158 #endif
3159       return FFESTC_orderBAD_;
3160
3161     case FFESTV_stateIF:
3162       ffestc_order_bad_ ();
3163       ffestc_shriek_if_ (FALSE);
3164       return FFESTC_orderBAD_;
3165
3166     default:
3167       ffestc_order_bad_ ();
3168       return FFESTC_orderBAD_;
3169     }
3170 }
3171
3172 /* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement
3173
3174    if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
3175        return;  */
3176
3177 static ffestcOrder_
3178 ffestc_order_implicitnone_ ()
3179 {
3180   recurse:
3181
3182   switch (ffestw_state (ffestw_stack_top ()))
3183     {
3184     case FFESTV_stateNIL:
3185       ffestc_shriek_begin_program_ ();
3186       goto recurse;             /* :::::::::::::::::::: */
3187
3188     case FFESTV_statePROGRAM0:
3189     case FFESTV_statePROGRAM1:
3190       ffestw_update (NULL);
3191       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3192       return FFESTC_orderOK_;
3193
3194     case FFESTV_stateSUBROUTINE0:
3195     case FFESTV_stateSUBROUTINE1:
3196       ffestw_update (NULL);
3197       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3198       return FFESTC_orderOK_;
3199
3200     case FFESTV_stateFUNCTION0:
3201     case FFESTV_stateFUNCTION1:
3202       ffestw_update (NULL);
3203       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3204       return FFESTC_orderOK_;
3205
3206     case FFESTV_stateMODULE0:
3207     case FFESTV_stateMODULE1:
3208       ffestw_update (NULL);
3209       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3210       return FFESTC_orderOK_;
3211
3212     case FFESTV_stateBLOCKDATA0:
3213     case FFESTV_stateBLOCKDATA1:
3214       ffestw_update (NULL);
3215       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
3216       return FFESTC_orderOK_;
3217
3218     case FFESTV_stateUSE:
3219 #if FFESTR_F90
3220       ffestc_shriek_end_uses_ (TRUE);
3221 #endif
3222       goto recurse;             /* :::::::::::::::::::: */
3223
3224     case FFESTV_stateWHERE:
3225       ffestc_order_bad_ ();
3226 #if FFESTR_F90
3227       ffestc_shriek_where_ (FALSE);
3228 #endif
3229       return FFESTC_orderBAD_;
3230
3231     case FFESTV_stateIF:
3232       ffestc_order_bad_ ();
3233       ffestc_shriek_if_ (FALSE);
3234       return FFESTC_orderBAD_;
3235
3236     default:
3237       ffestc_order_bad_ ();
3238       return FFESTC_orderBAD_;
3239     }
3240 }
3241
3242 /* ffestc_order_interface_ -- Check ordering on <interface> statement
3243
3244    if (ffestc_order_interface_() != FFESTC_orderOK_)
3245        return;  */
3246
3247 #if FFESTR_F90
3248 static ffestcOrder_
3249 ffestc_order_interface_ ()
3250 {
3251   switch (ffestw_state (ffestw_stack_top ()))
3252     {
3253     case FFESTV_stateINTERFACE0:
3254     case FFESTV_stateINTERFACE1:
3255       return FFESTC_orderOK_;
3256
3257     case FFESTV_stateWHERE:
3258       ffestc_order_bad_ ();
3259       ffestc_shriek_where_ (FALSE);
3260       return FFESTC_orderBAD_;
3261
3262     case FFESTV_stateIF:
3263       ffestc_order_bad_ ();
3264       ffestc_shriek_if_ (FALSE);
3265       return FFESTC_orderBAD_;
3266
3267     default:
3268       ffestc_order_bad_ ();
3269       return FFESTC_orderBAD_;
3270     }
3271 }
3272
3273 #endif
3274 /* ffestc_order_map_ -- Check ordering on <map> statement
3275
3276    if (ffestc_order_map_() != FFESTC_orderOK_)
3277        return;  */
3278
3279 #if FFESTR_VXT
3280 static ffestcOrder_
3281 ffestc_order_map_ ()
3282 {
3283   switch (ffestw_state (ffestw_stack_top ()))
3284     {
3285     case FFESTV_stateMAP:
3286       return FFESTC_orderOK_;
3287
3288     case FFESTV_stateWHERE:
3289       ffestc_order_bad_ ();
3290       ffestc_shriek_where_ (FALSE);
3291       return FFESTC_orderBAD_;
3292
3293     case FFESTV_stateIF:
3294       ffestc_order_bad_ ();
3295       ffestc_shriek_if_ (FALSE);
3296       return FFESTC_orderBAD_;
3297
3298     default:
3299       ffestc_order_bad_ ();
3300       return FFESTC_orderBAD_;
3301     }
3302 }
3303
3304 #endif
3305 /* ffestc_order_module_ -- Check ordering on <module> statement
3306
3307    if (ffestc_order_module_() != FFESTC_orderOK_)
3308        return;  */
3309
3310 #if FFESTR_F90
3311 static ffestcOrder_
3312 ffestc_order_module_ ()
3313 {
3314   recurse:
3315
3316   switch (ffestw_state (ffestw_stack_top ()))
3317     {
3318     case FFESTV_stateMODULE0:
3319     case FFESTV_stateMODULE1:
3320     case FFESTV_stateMODULE2:
3321     case FFESTV_stateMODULE3:
3322     case FFESTV_stateMODULE4:
3323     case FFESTV_stateMODULE5:
3324       return FFESTC_orderOK_;
3325
3326     case FFESTV_stateUSE:
3327       ffestc_shriek_end_uses_ (TRUE);
3328       goto recurse;             /* :::::::::::::::::::: */
3329
3330     case FFESTV_stateWHERE:
3331       ffestc_order_bad_ ();
3332       ffestc_shriek_where_ (FALSE);
3333       return FFESTC_orderBAD_;
3334
3335     case FFESTV_stateIF:
3336       ffestc_order_bad_ ();
3337       ffestc_shriek_if_ (FALSE);
3338       return FFESTC_orderBAD_;
3339
3340     default:
3341       ffestc_order_bad_ ();
3342       return FFESTC_orderBAD_;
3343     }
3344 }
3345
3346 #endif
3347 /* ffestc_order_parameter_ -- Check ordering on <parameter> statement
3348
3349    if (ffestc_order_parameter_() != FFESTC_orderOK_)
3350        return;  */
3351
3352 static ffestcOrder_
3353 ffestc_order_parameter_ ()
3354 {
3355   recurse:
3356
3357   switch (ffestw_state (ffestw_stack_top ()))
3358     {
3359     case FFESTV_stateNIL:
3360       ffestc_shriek_begin_program_ ();
3361       goto recurse;             /* :::::::::::::::::::: */
3362
3363     case FFESTV_statePROGRAM0:
3364     case FFESTV_statePROGRAM1:
3365       ffestw_update (NULL);
3366       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
3367       return FFESTC_orderOK_;
3368
3369     case FFESTV_stateSUBROUTINE0:
3370     case FFESTV_stateSUBROUTINE1:
3371       ffestw_update (NULL);
3372       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
3373       return FFESTC_orderOK_;
3374
3375     case FFESTV_stateFUNCTION0:
3376     case FFESTV_stateFUNCTION1:
3377       ffestw_update (NULL);
3378       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
3379       return FFESTC_orderOK_;
3380
3381     case FFESTV_stateMODULE0:
3382     case FFESTV_stateMODULE1:
3383       ffestw_update (NULL);
3384       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
3385       return FFESTC_orderOK_;
3386
3387     case FFESTV_stateBLOCKDATA0:
3388     case FFESTV_stateBLOCKDATA1:
3389       ffestw_update (NULL);
3390       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
3391       return FFESTC_orderOK_;
3392
3393     case FFESTV_statePROGRAM2:
3394     case FFESTV_stateSUBROUTINE2:
3395     case FFESTV_stateFUNCTION2:
3396     case FFESTV_stateMODULE2:
3397     case FFESTV_stateBLOCKDATA2:
3398     case FFESTV_statePROGRAM3:
3399     case FFESTV_stateSUBROUTINE3:
3400     case FFESTV_stateFUNCTION3:
3401     case FFESTV_stateMODULE3:
3402     case FFESTV_stateBLOCKDATA3:
3403     case FFESTV_stateTYPE:      /* GNU extension here! */
3404     case FFESTV_stateSTRUCTURE:
3405     case FFESTV_stateUNION:
3406     case FFESTV_stateMAP:
3407       return FFESTC_orderOK_;
3408
3409     case FFESTV_stateUSE:
3410 #if FFESTR_F90
3411       ffestc_shriek_end_uses_ (TRUE);
3412 #endif
3413       goto recurse;             /* :::::::::::::::::::: */
3414
3415     case FFESTV_stateWHERE:
3416       ffestc_order_bad_ ();
3417 #if FFESTR_F90
3418       ffestc_shriek_where_ (FALSE);
3419 #endif
3420       return FFESTC_orderBAD_;
3421
3422     case FFESTV_stateIF:
3423       ffestc_order_bad_ ();
3424       ffestc_shriek_if_ (FALSE);
3425       return FFESTC_orderBAD_;
3426
3427     default:
3428       ffestc_order_bad_ ();
3429       return FFESTC_orderBAD_;
3430     }
3431 }
3432
3433 /* ffestc_order_program_ -- Check ordering on <program> statement
3434
3435    if (ffestc_order_program_() != FFESTC_orderOK_)
3436        return;  */
3437
3438 static ffestcOrder_
3439 ffestc_order_program_ ()
3440 {
3441   recurse:
3442
3443   switch (ffestw_state (ffestw_stack_top ()))
3444     {
3445     case FFESTV_stateNIL:
3446       ffestc_shriek_begin_program_ ();
3447       goto recurse;             /* :::::::::::::::::::: */
3448
3449     case FFESTV_statePROGRAM0:
3450     case FFESTV_statePROGRAM1:
3451     case FFESTV_statePROGRAM2:
3452     case FFESTV_statePROGRAM3:
3453     case FFESTV_statePROGRAM4:
3454     case FFESTV_statePROGRAM5:
3455       return FFESTC_orderOK_;
3456
3457     case FFESTV_stateUSE:
3458 #if FFESTR_F90
3459       ffestc_shriek_end_uses_ (TRUE);
3460 #endif
3461       goto recurse;             /* :::::::::::::::::::: */
3462
3463     case FFESTV_stateWHERE:
3464       ffestc_order_bad_ ();
3465 #if FFESTR_F90
3466       ffestc_shriek_where_ (FALSE);
3467 #endif
3468       return FFESTC_orderBAD_;
3469
3470     case FFESTV_stateIF:
3471       ffestc_order_bad_ ();
3472       ffestc_shriek_if_ (FALSE);
3473       return FFESTC_orderBAD_;
3474
3475     default:
3476       ffestc_order_bad_ ();
3477       return FFESTC_orderBAD_;
3478     }
3479 }
3480
3481 /* ffestc_order_progspec_ -- Check ordering on <progspec> statement
3482
3483    if (ffestc_order_progspec_() != FFESTC_orderOK_)
3484        return;  */
3485
3486 static ffestcOrder_
3487 ffestc_order_progspec_ ()
3488 {
3489   recurse:
3490
3491   switch (ffestw_state (ffestw_stack_top ()))
3492     {
3493     case FFESTV_stateNIL:
3494       ffestc_shriek_begin_program_ ();
3495       goto recurse;             /* :::::::::::::::::::: */
3496
3497     case FFESTV_statePROGRAM0:
3498     case FFESTV_statePROGRAM1:
3499     case FFESTV_statePROGRAM2:
3500       ffestw_update (NULL);
3501       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3502       return FFESTC_orderOK_;
3503
3504     case FFESTV_stateSUBROUTINE0:
3505     case FFESTV_stateSUBROUTINE1:
3506     case FFESTV_stateSUBROUTINE2:
3507       ffestw_update (NULL);
3508       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3509       return FFESTC_orderOK_;
3510
3511     case FFESTV_stateFUNCTION0:
3512     case FFESTV_stateFUNCTION1:
3513     case FFESTV_stateFUNCTION2:
3514       ffestw_update (NULL);
3515       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3516       return FFESTC_orderOK_;
3517
3518     case FFESTV_stateMODULE0:
3519     case FFESTV_stateMODULE1:
3520     case FFESTV_stateMODULE2:
3521       ffestw_update (NULL);
3522       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3523       return FFESTC_orderOK_;
3524
3525     case FFESTV_statePROGRAM3:
3526     case FFESTV_stateSUBROUTINE3:
3527     case FFESTV_stateFUNCTION3:
3528     case FFESTV_stateMODULE3:
3529       return FFESTC_orderOK_;
3530
3531     case FFESTV_stateBLOCKDATA0:
3532     case FFESTV_stateBLOCKDATA1:
3533     case FFESTV_stateBLOCKDATA2:
3534       ffestw_update (NULL);
3535       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
3536       if (ffe_is_pedantic ())
3537         {
3538           ffebad_start (FFEBAD_BLOCKDATA_STMT);
3539           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3540                        ffelex_token_where_column (ffesta_tokens[0]));
3541           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
3542           ffebad_finish ();
3543         }
3544       return FFESTC_orderOK_;
3545
3546     case FFESTV_stateUSE:
3547 #if FFESTR_F90
3548       ffestc_shriek_end_uses_ (TRUE);
3549 #endif
3550       goto recurse;             /* :::::::::::::::::::: */
3551
3552     case FFESTV_stateWHERE:
3553       ffestc_order_bad_ ();
3554 #if FFESTR_F90
3555       ffestc_shriek_where_ (FALSE);
3556 #endif
3557       return FFESTC_orderBAD_;
3558
3559     case FFESTV_stateIF:
3560       ffestc_order_bad_ ();
3561       ffestc_shriek_if_ (FALSE);
3562       return FFESTC_orderBAD_;
3563
3564     default:
3565       ffestc_order_bad_ ();
3566       return FFESTC_orderBAD_;
3567     }
3568 }
3569
3570 /* ffestc_order_record_ -- Check ordering on RECORD statement
3571
3572    if (ffestc_order_record_() != FFESTC_orderOK_)
3573        return;  */
3574
3575 #if FFESTR_VXT
3576 static ffestcOrder_
3577 ffestc_order_record_ ()
3578 {
3579   recurse:
3580
3581   switch (ffestw_state (ffestw_stack_top ()))
3582     {
3583     case FFESTV_stateNIL:
3584       ffestc_shriek_begin_program_ ();
3585       goto recurse;             /* :::::::::::::::::::: */
3586
3587     case FFESTV_statePROGRAM0:
3588     case FFESTV_statePROGRAM1:
3589     case FFESTV_statePROGRAM2:
3590       ffestw_update (NULL);
3591       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3592       return FFESTC_orderOK_;
3593
3594     case FFESTV_stateSUBROUTINE0:
3595     case FFESTV_stateSUBROUTINE1:
3596     case FFESTV_stateSUBROUTINE2:
3597       ffestw_update (NULL);
3598       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3599       return FFESTC_orderOK_;
3600
3601     case FFESTV_stateFUNCTION0:
3602     case FFESTV_stateFUNCTION1:
3603     case FFESTV_stateFUNCTION2:
3604       ffestw_update (NULL);
3605       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3606       return FFESTC_orderOK_;
3607
3608     case FFESTV_stateMODULE0:
3609     case FFESTV_stateMODULE1:
3610     case FFESTV_stateMODULE2:
3611       ffestw_update (NULL);
3612       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3613       return FFESTC_orderOK_;
3614
3615     case FFESTV_stateBLOCKDATA0:
3616     case FFESTV_stateBLOCKDATA1:
3617     case FFESTV_stateBLOCKDATA2:
3618       ffestw_update (NULL);
3619       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
3620       return FFESTC_orderOK_;
3621
3622     case FFESTV_statePROGRAM3:
3623     case FFESTV_stateSUBROUTINE3:
3624     case FFESTV_stateFUNCTION3:
3625     case FFESTV_stateMODULE3:
3626     case FFESTV_stateBLOCKDATA3:
3627     case FFESTV_stateSTRUCTURE:
3628     case FFESTV_stateMAP:
3629       return FFESTC_orderOK_;
3630
3631     case FFESTV_stateUSE:
3632 #if FFESTR_F90
3633       ffestc_shriek_end_uses_ (TRUE);
3634 #endif
3635       goto recurse;             /* :::::::::::::::::::: */
3636
3637     case FFESTV_stateWHERE:
3638       ffestc_order_bad_ ();
3639 #if FFESTR_F90
3640       ffestc_shriek_where_ (FALSE);
3641 #endif
3642       return FFESTC_orderBAD_;
3643
3644     case FFESTV_stateIF:
3645       ffestc_order_bad_ ();
3646       ffestc_shriek_if_ (FALSE);
3647       return FFESTC_orderBAD_;
3648
3649     default:
3650       ffestc_order_bad_ ();
3651       return FFESTC_orderBAD_;
3652     }
3653 }
3654
3655 #endif
3656 /* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
3657
3658    if (ffestc_order_selectcase_() != FFESTC_orderOK_)
3659        return;  */
3660
3661 static ffestcOrder_
3662 ffestc_order_selectcase_ ()
3663 {
3664   switch (ffestw_state (ffestw_stack_top ()))
3665     {
3666     case FFESTV_stateSELECT0:
3667     case FFESTV_stateSELECT1:
3668       return FFESTC_orderOK_;
3669
3670     case FFESTV_stateWHERE:
3671       ffestc_order_bad_ ();
3672 #if FFESTR_F90
3673       ffestc_shriek_where_ (FALSE);
3674 #endif
3675       return FFESTC_orderBAD_;
3676
3677     case FFESTV_stateIF:
3678       ffestc_order_bad_ ();
3679       ffestc_shriek_if_ (FALSE);
3680       return FFESTC_orderBAD_;
3681
3682     default:
3683       ffestc_order_bad_ ();
3684       return FFESTC_orderBAD_;
3685     }
3686 }
3687
3688 /* ffestc_order_sfunc_ -- Check ordering on statement-function definition
3689
3690    if (ffestc_order_sfunc_() != FFESTC_orderOK_)
3691        return;  */
3692
3693 static ffestcOrder_
3694 ffestc_order_sfunc_ ()
3695 {
3696   recurse:
3697
3698   switch (ffestw_state (ffestw_stack_top ()))
3699     {
3700     case FFESTV_stateNIL:
3701       ffestc_shriek_begin_program_ ();
3702       goto recurse;             /* :::::::::::::::::::: */
3703
3704     case FFESTV_statePROGRAM0:
3705     case FFESTV_statePROGRAM1:
3706     case FFESTV_statePROGRAM2:
3707       ffestw_update (NULL);
3708       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3709       return FFESTC_orderOK_;
3710
3711     case FFESTV_stateSUBROUTINE0:
3712     case FFESTV_stateSUBROUTINE1:
3713     case FFESTV_stateSUBROUTINE2:
3714       ffestw_update (NULL);
3715       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3716       return FFESTC_orderOK_;
3717
3718     case FFESTV_stateFUNCTION0:
3719     case FFESTV_stateFUNCTION1:
3720     case FFESTV_stateFUNCTION2:
3721       ffestw_update (NULL);
3722       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3723       return FFESTC_orderOK_;
3724
3725     case FFESTV_statePROGRAM3:
3726     case FFESTV_stateSUBROUTINE3:
3727     case FFESTV_stateFUNCTION3:
3728       return FFESTC_orderOK_;
3729
3730     case FFESTV_stateUSE:
3731 #if FFESTR_F90
3732       ffestc_shriek_end_uses_ (TRUE);
3733 #endif
3734       goto recurse;             /* :::::::::::::::::::: */
3735
3736     case FFESTV_stateWHERE:
3737       ffestc_order_bad_ ();
3738 #if FFESTR_F90
3739       ffestc_shriek_where_ (FALSE);
3740 #endif
3741       return FFESTC_orderBAD_;
3742
3743     case FFESTV_stateIF:
3744       ffestc_order_bad_ ();
3745       ffestc_shriek_if_ (FALSE);
3746       return FFESTC_orderBAD_;
3747
3748     default:
3749       ffestc_order_bad_ ();
3750       return FFESTC_orderBAD_;
3751     }
3752 }
3753
3754 /* ffestc_order_spec_ -- Check ordering on <spec> statement
3755
3756    if (ffestc_order_spec_() != FFESTC_orderOK_)
3757        return;  */
3758
3759 #if FFESTR_F90
3760 static ffestcOrder_
3761 ffestc_order_spec_ ()
3762 {
3763   recurse:
3764
3765   switch (ffestw_state (ffestw_stack_top ()))
3766     {
3767     case FFESTV_stateNIL:
3768       ffestc_shriek_begin_program_ ();
3769       goto recurse;             /* :::::::::::::::::::: */
3770
3771     case FFESTV_stateSUBROUTINE0:
3772     case FFESTV_stateSUBROUTINE1:
3773     case FFESTV_stateSUBROUTINE2:
3774       ffestw_update (NULL);
3775       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3776       return FFESTC_orderOK_;
3777
3778     case FFESTV_stateFUNCTION0:
3779     case FFESTV_stateFUNCTION1:
3780     case FFESTV_stateFUNCTION2:
3781       ffestw_update (NULL);
3782       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3783       return FFESTC_orderOK_;
3784
3785     case FFESTV_stateMODULE0:
3786     case FFESTV_stateMODULE1:
3787     case FFESTV_stateMODULE2:
3788       ffestw_update (NULL);
3789       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3790       return FFESTC_orderOK_;
3791
3792     case FFESTV_stateSUBROUTINE3:
3793     case FFESTV_stateFUNCTION3:
3794     case FFESTV_stateMODULE3:
3795       return FFESTC_orderOK_;
3796
3797     case FFESTV_stateUSE:
3798 #if FFESTR_F90
3799       ffestc_shriek_end_uses_ (TRUE);
3800 #endif
3801       goto recurse;             /* :::::::::::::::::::: */
3802
3803     case FFESTV_stateWHERE:
3804       ffestc_order_bad_ ();
3805 #if FFESTR_F90
3806       ffestc_shriek_where_ (FALSE);
3807 #endif
3808       return FFESTC_orderBAD_;
3809
3810     case FFESTV_stateIF:
3811       ffestc_order_bad_ ();
3812       ffestc_shriek_if_ (FALSE);
3813       return FFESTC_orderBAD_;
3814
3815     default:
3816       ffestc_order_bad_ ();
3817       return FFESTC_orderBAD_;
3818     }
3819 }
3820
3821 #endif
3822 /* ffestc_order_structure_ -- Check ordering on <structure> statement
3823
3824    if (ffestc_order_structure_() != FFESTC_orderOK_)
3825        return;  */
3826
3827 #if FFESTR_VXT
3828 static ffestcOrder_
3829 ffestc_order_structure_ ()
3830 {
3831   switch (ffestw_state (ffestw_stack_top ()))
3832     {
3833     case FFESTV_stateSTRUCTURE:
3834       return FFESTC_orderOK_;
3835
3836     case FFESTV_stateWHERE:
3837       ffestc_order_bad_ ();
3838 #if FFESTR_F90
3839       ffestc_shriek_where_ (FALSE);
3840 #endif
3841       return FFESTC_orderBAD_;
3842
3843     case FFESTV_stateIF:
3844       ffestc_order_bad_ ();
3845       ffestc_shriek_if_ (FALSE);
3846       return FFESTC_orderBAD_;
3847
3848     default:
3849       ffestc_order_bad_ ();
3850       return FFESTC_orderBAD_;
3851     }
3852 }
3853
3854 #endif
3855 /* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
3856
3857    if (ffestc_order_subroutine_() != FFESTC_orderOK_)
3858        return;  */
3859
3860 static ffestcOrder_
3861 ffestc_order_subroutine_ ()
3862 {
3863   recurse:
3864
3865   switch (ffestw_state (ffestw_stack_top ()))
3866     {
3867     case FFESTV_stateSUBROUTINE0:
3868     case FFESTV_stateSUBROUTINE1:
3869     case FFESTV_stateSUBROUTINE2:
3870     case FFESTV_stateSUBROUTINE3:
3871     case FFESTV_stateSUBROUTINE4:
3872     case FFESTV_stateSUBROUTINE5:
3873       return FFESTC_orderOK_;
3874
3875     case FFESTV_stateUSE:
3876 #if FFESTR_F90
3877       ffestc_shriek_end_uses_ (TRUE);
3878 #endif
3879       goto recurse;             /* :::::::::::::::::::: */
3880
3881     case FFESTV_stateWHERE:
3882       ffestc_order_bad_ ();
3883 #if FFESTR_F90
3884       ffestc_shriek_where_ (FALSE);
3885 #endif
3886       return FFESTC_orderBAD_;
3887
3888     case FFESTV_stateIF:
3889       ffestc_order_bad_ ();
3890       ffestc_shriek_if_ (FALSE);
3891       return FFESTC_orderBAD_;
3892
3893     default:
3894       ffestc_order_bad_ ();
3895       return FFESTC_orderBAD_;
3896     }
3897 }
3898
3899 /* ffestc_order_type_ -- Check ordering on <type> statement
3900
3901    if (ffestc_order_type_() != FFESTC_orderOK_)
3902        return;  */
3903
3904 #if FFESTR_F90
3905 static ffestcOrder_
3906 ffestc_order_type_ ()
3907 {
3908   switch (ffestw_state (ffestw_stack_top ()))
3909     {
3910     case FFESTV_stateTYPE:
3911       return FFESTC_orderOK_;
3912
3913     case FFESTV_stateWHERE:
3914       ffestc_order_bad_ ();
3915       ffestc_shriek_where_ (FALSE);
3916       return FFESTC_orderBAD_;
3917
3918     case FFESTV_stateIF:
3919       ffestc_order_bad_ ();
3920       ffestc_shriek_if_ (FALSE);
3921       return FFESTC_orderBAD_;
3922
3923     default:
3924       ffestc_order_bad_ ();
3925       return FFESTC_orderBAD_;
3926     }
3927 }
3928
3929 #endif
3930 /* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
3931
3932    if (ffestc_order_typedecl_() != FFESTC_orderOK_)
3933        return;  */
3934
3935 static ffestcOrder_
3936 ffestc_order_typedecl_ ()
3937 {
3938   recurse:
3939
3940   switch (ffestw_state (ffestw_stack_top ()))
3941     {
3942     case FFESTV_stateNIL:
3943       ffestc_shriek_begin_program_ ();
3944       goto recurse;             /* :::::::::::::::::::: */
3945
3946     case FFESTV_statePROGRAM0:
3947     case FFESTV_statePROGRAM1:
3948     case FFESTV_statePROGRAM2:
3949       ffestw_update (NULL);
3950       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
3951       return FFESTC_orderOK_;
3952
3953     case FFESTV_stateSUBROUTINE0:
3954     case FFESTV_stateSUBROUTINE1:
3955     case FFESTV_stateSUBROUTINE2:
3956       ffestw_update (NULL);
3957       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
3958       return FFESTC_orderOK_;
3959
3960     case FFESTV_stateFUNCTION0:
3961     case FFESTV_stateFUNCTION1:
3962     case FFESTV_stateFUNCTION2:
3963       ffestw_update (NULL);
3964       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
3965       return FFESTC_orderOK_;
3966
3967     case FFESTV_stateMODULE0:
3968     case FFESTV_stateMODULE1:
3969     case FFESTV_stateMODULE2:
3970       ffestw_update (NULL);
3971       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
3972       return FFESTC_orderOK_;
3973
3974     case FFESTV_stateBLOCKDATA0:
3975     case FFESTV_stateBLOCKDATA1:
3976     case FFESTV_stateBLOCKDATA2:
3977       ffestw_update (NULL);
3978       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
3979       return FFESTC_orderOK_;
3980
3981     case FFESTV_statePROGRAM3:
3982     case FFESTV_stateSUBROUTINE3:
3983     case FFESTV_stateFUNCTION3:
3984     case FFESTV_stateMODULE3:
3985     case FFESTV_stateBLOCKDATA3:
3986       return FFESTC_orderOK_;
3987
3988     case FFESTV_stateUSE:
3989 #if FFESTR_F90
3990       ffestc_shriek_end_uses_ (TRUE);
3991 #endif
3992       goto recurse;             /* :::::::::::::::::::: */
3993
3994     case FFESTV_stateWHERE:
3995       ffestc_order_bad_ ();
3996 #if FFESTR_F90
3997       ffestc_shriek_where_ (FALSE);
3998 #endif
3999       return FFESTC_orderBAD_;
4000
4001     case FFESTV_stateIF:
4002       ffestc_order_bad_ ();
4003       ffestc_shriek_if_ (FALSE);
4004       return FFESTC_orderBAD_;
4005
4006     default:
4007       ffestc_order_bad_ ();
4008       return FFESTC_orderBAD_;
4009     }
4010 }
4011
4012 /* ffestc_order_union_ -- Check ordering on <union> statement
4013
4014    if (ffestc_order_union_() != FFESTC_orderOK_)
4015        return;  */
4016
4017 #if FFESTR_VXT
4018 static ffestcOrder_
4019 ffestc_order_union_ ()
4020 {
4021   switch (ffestw_state (ffestw_stack_top ()))
4022     {
4023     case FFESTV_stateUNION:
4024       return FFESTC_orderOK_;
4025
4026     case FFESTV_stateWHERE:
4027       ffestc_order_bad_ ();
4028 #if FFESTR_F90
4029       ffestc_shriek_where_ (FALSE);
4030 #endif
4031       return FFESTC_orderBAD_;
4032
4033     case FFESTV_stateIF:
4034       ffestc_order_bad_ ();
4035       ffestc_shriek_if_ (FALSE);
4036       return FFESTC_orderBAD_;
4037
4038     default:
4039       ffestc_order_bad_ ();
4040       return FFESTC_orderBAD_;
4041     }
4042 }
4043
4044 #endif
4045 /* ffestc_order_unit_ -- Check ordering on <unit> statement
4046
4047    if (ffestc_order_unit_() != FFESTC_orderOK_)
4048        return;  */
4049
4050 static ffestcOrder_
4051 ffestc_order_unit_ ()
4052 {
4053   switch (ffestw_state (ffestw_stack_top ()))
4054     {
4055     case FFESTV_stateNIL:
4056       return FFESTC_orderOK_;
4057
4058     case FFESTV_stateWHERE:
4059       ffestc_order_bad_ ();
4060 #if FFESTR_F90
4061       ffestc_shriek_where_ (FALSE);
4062 #endif
4063       return FFESTC_orderBAD_;
4064
4065     case FFESTV_stateIF:
4066       ffestc_order_bad_ ();
4067       ffestc_shriek_if_ (FALSE);
4068       return FFESTC_orderBAD_;
4069
4070     default:
4071       ffestc_order_bad_ ();
4072       return FFESTC_orderBAD_;
4073     }
4074 }
4075
4076 /* ffestc_order_use_ -- Check ordering on USE statement
4077
4078    if (ffestc_order_use_() != FFESTC_orderOK_)
4079        return;  */
4080
4081 #if FFESTR_F90
4082 static ffestcOrder_
4083 ffestc_order_use_ ()
4084 {
4085   recurse:
4086
4087   switch (ffestw_state (ffestw_stack_top ()))
4088     {
4089     case FFESTV_stateNIL:
4090       ffestc_shriek_begin_program_ ();
4091       goto recurse;             /* :::::::::::::::::::: */
4092
4093     case FFESTV_statePROGRAM0:
4094       ffestw_update (NULL);
4095       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
4096       ffestc_shriek_begin_uses_ ();
4097       goto recurse;             /* :::::::::::::::::::: */
4098
4099     case FFESTV_stateSUBROUTINE0:
4100       ffestw_update (NULL);
4101       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
4102       ffestc_shriek_begin_uses_ ();
4103       goto recurse;             /* :::::::::::::::::::: */
4104
4105     case FFESTV_stateFUNCTION0:
4106       ffestw_update (NULL);
4107       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
4108       ffestc_shriek_begin_uses_ ();
4109       goto recurse;             /* :::::::::::::::::::: */
4110
4111     case FFESTV_stateMODULE0:
4112       ffestw_update (NULL);
4113       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1);
4114       ffestc_shriek_begin_uses_ ();
4115       goto recurse;             /* :::::::::::::::::::: */
4116
4117     case FFESTV_stateUSE:
4118       return FFESTC_orderOK_;
4119
4120     case FFESTV_stateWHERE:
4121       ffestc_order_bad_ ();
4122       ffestc_shriek_where_ (FALSE);
4123       return FFESTC_orderBAD_;
4124
4125     case FFESTV_stateIF:
4126       ffestc_order_bad_ ();
4127       ffestc_shriek_if_ (FALSE);
4128       return FFESTC_orderBAD_;
4129
4130     default:
4131       ffestc_order_bad_ ();
4132       return FFESTC_orderBAD_;
4133     }
4134 }
4135
4136 #endif
4137 /* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement
4138
4139    if (ffestc_order_vxtstructure_() != FFESTC_orderOK_)
4140        return;  */
4141
4142 #if FFESTR_VXT
4143 static ffestcOrder_
4144 ffestc_order_vxtstructure_ ()
4145 {
4146   recurse:
4147
4148   switch (ffestw_state (ffestw_stack_top ()))
4149     {
4150     case FFESTV_stateNIL:
4151       ffestc_shriek_begin_program_ ();
4152       goto recurse;             /* :::::::::::::::::::: */
4153
4154     case FFESTV_statePROGRAM0:
4155     case FFESTV_statePROGRAM1:
4156     case FFESTV_statePROGRAM2:
4157       ffestw_update (NULL);
4158       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
4159       return FFESTC_orderOK_;
4160
4161     case FFESTV_stateSUBROUTINE0:
4162     case FFESTV_stateSUBROUTINE1:
4163     case FFESTV_stateSUBROUTINE2:
4164       ffestw_update (NULL);
4165       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
4166       return FFESTC_orderOK_;
4167
4168     case FFESTV_stateFUNCTION0:
4169     case FFESTV_stateFUNCTION1:
4170     case FFESTV_stateFUNCTION2:
4171       ffestw_update (NULL);
4172       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
4173       return FFESTC_orderOK_;
4174
4175     case FFESTV_stateMODULE0:
4176     case FFESTV_stateMODULE1:
4177     case FFESTV_stateMODULE2:
4178       ffestw_update (NULL);
4179       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
4180       return FFESTC_orderOK_;
4181
4182     case FFESTV_stateBLOCKDATA0:
4183     case FFESTV_stateBLOCKDATA1:
4184     case FFESTV_stateBLOCKDATA2:
4185       ffestw_update (NULL);
4186       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
4187       return FFESTC_orderOK_;
4188
4189     case FFESTV_statePROGRAM3:
4190     case FFESTV_stateSUBROUTINE3:
4191     case FFESTV_stateFUNCTION3:
4192     case FFESTV_stateMODULE3:
4193     case FFESTV_stateBLOCKDATA3:
4194     case FFESTV_stateSTRUCTURE:
4195     case FFESTV_stateMAP:
4196       return FFESTC_orderOK_;
4197
4198     case FFESTV_stateUSE:
4199 #if FFESTR_F90
4200       ffestc_shriek_end_uses_ (TRUE);
4201 #endif
4202       goto recurse;             /* :::::::::::::::::::: */
4203
4204     case FFESTV_stateWHERE:
4205       ffestc_order_bad_ ();
4206 #if FFESTR_F90
4207       ffestc_shriek_where_ (FALSE);
4208 #endif
4209       return FFESTC_orderBAD_;
4210
4211     case FFESTV_stateIF:
4212       ffestc_order_bad_ ();
4213       ffestc_shriek_if_ (FALSE);
4214       return FFESTC_orderBAD_;
4215
4216     default:
4217       ffestc_order_bad_ ();
4218       return FFESTC_orderBAD_;
4219     }
4220 }
4221
4222 #endif
4223 /* ffestc_order_where_ -- Check ordering on <where> statement
4224
4225    if (ffestc_order_where_() != FFESTC_orderOK_)
4226        return;  */
4227
4228 #if FFESTR_F90
4229 static ffestcOrder_
4230 ffestc_order_where_ ()
4231 {
4232   switch (ffestw_state (ffestw_stack_top ()))
4233     {
4234     case FFESTV_stateWHERETHEN:
4235       return FFESTC_orderOK_;
4236
4237     case FFESTV_stateWHERE:
4238       ffestc_order_bad_ ();
4239       ffestc_shriek_where_ (FALSE);
4240       return FFESTC_orderBAD_;
4241
4242     case FFESTV_stateIF:
4243       ffestc_order_bad_ ();
4244       ffestc_shriek_if_ (FALSE);
4245       return FFESTC_orderBAD_;
4246
4247     default:
4248       ffestc_order_bad_ ();
4249       return FFESTC_orderBAD_;
4250     }
4251 }
4252
4253 #endif
4254 /* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
4255    ENTRY (prior to the first executable statement).  */
4256
4257 static void
4258 ffestc_promote_dummy_ (ffelexToken t)
4259 {
4260   ffesymbol s;
4261   ffesymbolAttrs sa;
4262   ffesymbolAttrs na;
4263   ffebld e;
4264   bool sfref_ok;
4265
4266   assert (t != NULL);
4267
4268   if (ffelex_token_type (t) == FFELEX_typeASTERISK)
4269     {
4270       ffebld_append_item (&ffestc_local_.dummy.list_bottom,
4271                           ffebld_new_star ());
4272       return;                   /* Don't bother with alternate returns! */
4273     }
4274
4275   s = ffesymbol_declare_local (t, FALSE);
4276   sa = ffesymbol_attrs (s);
4277
4278   /* Figure out what kind of object we've got based on previous declarations
4279      of or references to the object. */
4280
4281   sfref_ok = FALSE;
4282
4283   if (sa & FFESYMBOL_attrsANY)
4284     na = sa;
4285   else if (sa & FFESYMBOL_attrsDUMMY)
4286     {
4287       if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
4288         {                       /* Seen this one twice in this list! */
4289           na = FFESYMBOL_attrsetNONE;
4290         }
4291       else
4292         na = sa;
4293       sfref_ok = TRUE;          /* Ok for sym to be ref'd in sfuncdef
4294                                    previously, since already declared as a
4295                                    dummy arg. */
4296     }
4297   else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
4298                     | FFESYMBOL_attrsADJUSTS
4299                     | FFESYMBOL_attrsANY
4300                     | FFESYMBOL_attrsANYLEN
4301                     | FFESYMBOL_attrsANYSIZE
4302                     | FFESYMBOL_attrsARRAY
4303                     | FFESYMBOL_attrsDUMMY
4304                     | FFESYMBOL_attrsEXTERNAL
4305                     | FFESYMBOL_attrsSFARG
4306                     | FFESYMBOL_attrsTYPE)))
4307     na = sa | FFESYMBOL_attrsDUMMY;
4308   else
4309     na = FFESYMBOL_attrsetNONE;
4310
4311   if (!ffesymbol_is_specable (s)
4312       && (!sfref_ok
4313           || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
4314     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
4315
4316   /* Now see what we've got for a new object: NONE means a new error cropped
4317      up; ANY means an old error to be ignored; otherwise, everything's ok,
4318      update the object (symbol) and continue on. */
4319
4320   if (na == FFESYMBOL_attrsetNONE)
4321     ffesymbol_error (s, t);
4322   else if (!(na & FFESYMBOL_attrsANY))
4323     {
4324       ffesymbol_set_attrs (s, na);
4325       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
4326         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
4327       ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
4328       ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
4329       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
4330                              FFEINTRIN_impNONE);
4331       ffebld_set_info (e,
4332                        ffeinfo_new (FFEINFO_basictypeNONE,
4333                                     FFEINFO_kindtypeNONE,
4334                                     0,
4335                                     FFEINFO_kindNONE,
4336                                     FFEINFO_whereNONE,
4337                                     FFETARGET_charactersizeNONE));
4338       ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4339       ffesymbol_signal_unreported (s);
4340     }
4341 }
4342
4343 /* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
4344
4345    ffestc_promote_execdummy_(t);
4346
4347    Invoked for each token in dummy arg list of ENTRY when the statement
4348    follows the first executable statement.  */
4349
4350 static void
4351 ffestc_promote_execdummy_ (ffelexToken t)
4352 {
4353   ffesymbol s;
4354   ffesymbolAttrs sa;
4355   ffesymbolAttrs na;
4356   ffesymbolState ss;
4357   ffesymbolState ns;
4358   ffeinfoKind kind;
4359   ffeinfoWhere where;
4360   ffebld e;
4361
4362   assert (t != NULL);
4363
4364   if (ffelex_token_type (t) == FFELEX_typeASTERISK)
4365     {
4366       ffebld_append_item (&ffestc_local_.dummy.list_bottom,
4367                           ffebld_new_star ());
4368       return;                   /* Don't bother with alternate returns! */
4369     }
4370
4371   s = ffesymbol_declare_local (t, FALSE);
4372   na = sa = ffesymbol_attrs (s);
4373   ss = ffesymbol_state (s);
4374   kind = ffesymbol_kind (s);
4375   where = ffesymbol_where (s);
4376
4377   if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
4378     {                           /* Seen this one twice in this list! */
4379       na = FFESYMBOL_attrsetNONE;
4380     }
4381
4382   /* Figure out what kind of object we've got based on previous declarations
4383      of or references to the object. */
4384
4385   ns = FFESYMBOL_stateUNDERSTOOD;       /* Assume we know it all know. */
4386
4387   switch (kind)
4388     {
4389     case FFEINFO_kindENTITY:
4390     case FFEINFO_kindFUNCTION:
4391     case FFEINFO_kindSUBROUTINE:
4392       break;                    /* These are fine, as far as we know. */
4393
4394     case FFEINFO_kindNONE:
4395       if (sa & FFESYMBOL_attrsDUMMY)
4396         ns = FFESYMBOL_stateUNCERTAIN;  /* Learned nothing new. */
4397       else if (sa & FFESYMBOL_attrsANYLEN)
4398         {
4399           kind = FFEINFO_kindENTITY;
4400           where = FFEINFO_whereDUMMY;
4401         }
4402       else if (sa & FFESYMBOL_attrsACTUALARG)
4403         na = FFESYMBOL_attrsetNONE;
4404       else
4405         {
4406           na = sa | FFESYMBOL_attrsDUMMY;
4407           ns = FFESYMBOL_stateUNCERTAIN;
4408         }
4409       break;
4410
4411     default:
4412       na = FFESYMBOL_attrsetNONE;       /* Error. */
4413       break;
4414     }
4415
4416   switch (where)
4417     {
4418     case FFEINFO_whereDUMMY:
4419       break;                    /* This is fine. */
4420
4421     case FFEINFO_whereNONE:
4422       where = FFEINFO_whereDUMMY;
4423       break;
4424
4425     default:
4426       na = FFESYMBOL_attrsetNONE;       /* Error. */
4427       break;
4428     }
4429
4430   /* Now see what we've got for a new object: NONE means a new error cropped
4431      up; ANY means an old error to be ignored; otherwise, everything's ok,
4432      update the object (symbol) and continue on. */
4433
4434   if (na == FFESYMBOL_attrsetNONE)
4435     ffesymbol_error (s, t);
4436   else if (!(na & FFESYMBOL_attrsANY))
4437     {
4438       ffesymbol_set_attrs (s, na);
4439       ffesymbol_set_state (s, ns);
4440       ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
4441       ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
4442       if ((ns == FFESYMBOL_stateUNDERSTOOD)
4443           && (kind != FFEINFO_kindSUBROUTINE)
4444           && !ffeimplic_establish_symbol (s))
4445         {
4446           ffesymbol_error (s, t);
4447           return;
4448         }
4449       ffesymbol_set_info (s,
4450                           ffeinfo_new (ffesymbol_basictype (s),
4451                                        ffesymbol_kindtype (s),
4452                                        ffesymbol_rank (s),
4453                                        kind,
4454                                        where,
4455                                        ffesymbol_size (s)));
4456       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
4457                              FFEINTRIN_impNONE);
4458       ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
4459       ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4460       s = ffecom_sym_learned (s);
4461       ffesymbol_signal_unreported (s);
4462     }
4463 }
4464
4465 /* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
4466
4467    ffestc_promote_sfdummy_(t);
4468
4469    Invoked for each token in dummy arg list of statement function.
4470
4471    22-Oct-91  JCB  1.1
4472       Reject arg if CHARACTER*(*).  */
4473
4474 static void
4475 ffestc_promote_sfdummy_ (ffelexToken t)
4476 {
4477   ffesymbol s;
4478   ffesymbol sp;                 /* Parent symbol. */
4479   ffesymbolAttrs sa;
4480   ffesymbolAttrs na;
4481   ffebld e;
4482
4483   assert (t != NULL);
4484
4485   s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
4486                                            also sets sfa_dummy_parent to
4487                                            parent symbol. */
4488   if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
4489     {
4490       ffesymbol_error (s, t);   /* Dummy already in list. */
4491       return;
4492     }
4493
4494   sp = ffesymbol_sfdummyparent (s);     /* Now flag dummy's parent as used
4495                                            for dummy. */
4496   sa = ffesymbol_attrs (sp);
4497
4498   /* Figure out what kind of object we've got based on previous declarations
4499      of or references to the object. */
4500
4501   if (!ffesymbol_is_specable (sp)
4502       && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
4503           || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
4504               && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
4505               && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
4506               && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
4507     na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
4508   else if (sa & FFESYMBOL_attrsANY)
4509     na = sa;
4510   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
4511                     | FFESYMBOL_attrsCOMMON
4512                     | FFESYMBOL_attrsDUMMY
4513                     | FFESYMBOL_attrsEQUIV
4514                     | FFESYMBOL_attrsINIT
4515                     | FFESYMBOL_attrsNAMELIST
4516                     | FFESYMBOL_attrsRESULT
4517                     | FFESYMBOL_attrsSAVE
4518                     | FFESYMBOL_attrsSFARG
4519                     | FFESYMBOL_attrsTYPE)))
4520     na = sa | FFESYMBOL_attrsSFARG;
4521   else
4522     na = FFESYMBOL_attrsetNONE;
4523
4524   /* Now see what we've got for a new object: NONE means a new error cropped
4525      up; ANY means an old error to be ignored; otherwise, everything's ok,
4526      update the object (symbol) and continue on. */
4527
4528   if (na == FFESYMBOL_attrsetNONE)
4529     {
4530       ffesymbol_error (sp, t);
4531       ffesymbol_set_info (s, ffeinfo_new_any ());
4532     }
4533   else if (!(na & FFESYMBOL_attrsANY))
4534     {
4535       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
4536       ffesymbol_set_attrs (sp, na);
4537       if (!ffeimplic_establish_symbol (sp)
4538           || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
4539               && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
4540         ffesymbol_error (sp, t);
4541       else
4542         ffesymbol_set_info (s,
4543                             ffeinfo_new (ffesymbol_basictype (sp),
4544                                          ffesymbol_kindtype (sp),
4545                                          0,
4546                                          FFEINFO_kindENTITY,
4547                                          FFEINFO_whereDUMMY,
4548                                          ffesymbol_size (sp)));
4549
4550       ffesymbol_signal_unreported (sp);
4551     }
4552
4553   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
4554   ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
4555   ffesymbol_signal_unreported (s);
4556   e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
4557                          FFEINTRIN_impNONE);
4558   ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
4559   ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
4560 }
4561
4562 /* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
4563
4564    ffestc_shriek_begin_program_();
4565
4566    Invoked only when a PROGRAM statement is NOT present at the beginning
4567    of a main program unit.  */
4568
4569 static void
4570 ffestc_shriek_begin_program_ ()
4571 {
4572   ffestw b;
4573   ffesymbol s;
4574
4575   ffestc_blocknum_ = 0;
4576   b = ffestw_update (ffestw_push (NULL));
4577   ffestw_set_top_do (b, NULL);
4578   ffestw_set_state (b, FFESTV_statePROGRAM0);
4579   ffestw_set_blocknum (b, ffestc_blocknum_++);
4580   ffestw_set_shriek (b, ffestc_shriek_end_program_);
4581   ffestw_set_name (b, NULL);
4582
4583   s = ffesymbol_declare_programunit (NULL,
4584                                  ffelex_token_where_line (ffesta_tokens[0]),
4585                               ffelex_token_where_column (ffesta_tokens[0]));
4586
4587   /* Special case: this is one symbol that won't go through
4588      ffestu_exec_transition_ when the first statement in a main program is
4589      executable, because the transition happens in ffest before ffestc is
4590      reached and triggers the implicit generation of a main program.  So we
4591      do the exec transition for the implicit main program right here, just
4592      for cleanliness' sake (at the very least). */
4593
4594   ffesymbol_set_info (s,
4595                       ffeinfo_new (FFEINFO_basictypeNONE,
4596                                    FFEINFO_kindtypeNONE,
4597                                    0,
4598                                    FFEINFO_kindPROGRAM,
4599                                    FFEINFO_whereLOCAL,
4600                                    FFETARGET_charactersizeNONE));
4601   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
4602
4603   ffesymbol_signal_unreported (s);
4604
4605   ffestd_R1102 (s, NULL);
4606 }
4607
4608 /* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements
4609
4610    ffestc_shriek_begin_uses_();
4611
4612    Invoked before handling the first USE statement in a block of one or
4613    more USE statements.  _end_uses_(bool ok) is invoked before handling
4614    the first statement after the block (there are no BEGIN USE and END USE
4615    statements, but the semantics of USE statements effectively requires
4616    handling them as a single block rather than one statement at a time).  */
4617
4618 #if FFESTR_F90
4619 static void
4620 ffestc_shriek_begin_uses_ ()
4621 {
4622   ffestw b;
4623
4624   b = ffestw_update (ffestw_push (NULL));
4625   ffestw_set_top_do (b, NULL);
4626   ffestw_set_state (b, FFESTV_stateUSE);
4627   ffestw_set_blocknum (b, 0);
4628   ffestw_set_shriek (b, ffestc_shriek_end_uses_);
4629
4630   ffestd_begin_uses ();
4631 }
4632
4633 #endif
4634 /* ffestc_shriek_blockdata_ -- End a BLOCK DATA
4635
4636    ffestc_shriek_blockdata_(TRUE);  */
4637
4638 static void
4639 ffestc_shriek_blockdata_ (bool ok)
4640 {
4641   if (!ffesta_seen_first_exec)
4642     {
4643       ffesta_seen_first_exec = TRUE;
4644       ffestd_exec_begin ();
4645     }
4646
4647   ffestd_R1112 (ok);
4648
4649   ffestd_exec_end ();
4650
4651   if (ffestw_name (ffestw_stack_top ()) != NULL)
4652     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4653   ffestw_kill (ffestw_pop ());
4654
4655   ffe_terminate_2 ();
4656   ffe_init_2 ();
4657 }
4658
4659 /* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
4660
4661    ffestc_shriek_do_(TRUE);
4662
4663    Also invoked by _labeldef_branch_end_ (or, in cases
4664    of errors, other _labeldef_ functions) when the label definition is
4665    for a DO-target (LOOPEND) label, once per matching/outstanding DO
4666    block on the stack.  These cases invoke this function with ok==TRUE, so
4667    only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE.  */
4668
4669 static void
4670 ffestc_shriek_do_ (bool ok)
4671 {
4672   ffelab l;
4673
4674   if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
4675       && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
4676     {                           /* DO target is label that is still
4677                                    undefined. */
4678       assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
4679               || (ffelab_type (l) == FFELAB_typeANY));
4680       if (ffelab_type (l) != FFELAB_typeANY)
4681         {
4682           ffelab_set_definition_line (l,
4683                                       ffewhere_line_use (ffelab_doref_line (l)));
4684           ffelab_set_definition_column (l,
4685                                         ffewhere_column_use (ffelab_doref_column (l)));
4686           ffestv_num_label_defines_++;
4687         }
4688       ffestd_labeldef_branch (l);
4689     }
4690
4691   ffestd_do (ok);
4692
4693   if (ffestw_name (ffestw_stack_top ()) != NULL)
4694     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4695   if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
4696     ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
4697   if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
4698     ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
4699   ffestw_kill (ffestw_pop ());
4700 }
4701
4702 /* ffestc_shriek_end_program_ -- End a PROGRAM
4703
4704    ffestc_shriek_end_program_();  */
4705
4706 static void
4707 ffestc_shriek_end_program_ (bool ok)
4708 {
4709   if (!ffesta_seen_first_exec)
4710     {
4711       ffesta_seen_first_exec = TRUE;
4712       ffestd_exec_begin ();
4713     }
4714
4715   ffestd_R1103 (ok);
4716
4717   ffestd_exec_end ();
4718
4719   if (ffestw_name (ffestw_stack_top ()) != NULL)
4720     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4721   ffestw_kill (ffestw_pop ());
4722
4723   ffe_terminate_2 ();
4724   ffe_init_2 ();
4725 }
4726
4727 /* ffestc_shriek_end_uses_ -- End a bunch of USE statements
4728
4729    ffestc_shriek_end_uses_(TRUE);
4730
4731    ok==TRUE means simply not popping due to ffestc_eof()
4732    being called, because there is no formal END USES statement in Fortran.  */
4733
4734 #if FFESTR_F90
4735 static void
4736 ffestc_shriek_end_uses_ (bool ok)
4737 {
4738   ffestd_end_uses (ok);
4739
4740   ffestw_kill (ffestw_pop ());
4741 }
4742
4743 #endif
4744 /* ffestc_shriek_function_ -- End a FUNCTION
4745
4746    ffestc_shriek_function_(TRUE);  */
4747
4748 static void
4749 ffestc_shriek_function_ (bool ok)
4750 {
4751   if (!ffesta_seen_first_exec)
4752     {
4753       ffesta_seen_first_exec = TRUE;
4754       ffestd_exec_begin ();
4755     }
4756
4757   ffestd_R1221 (ok);
4758
4759   ffestd_exec_end ();
4760
4761   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4762   ffestw_kill (ffestw_pop ());
4763   ffesta_is_entry_valid = FALSE;
4764
4765   switch (ffestw_state (ffestw_stack_top ()))
4766     {
4767     case FFESTV_stateNIL:
4768       ffe_terminate_2 ();
4769       ffe_init_2 ();
4770       break;
4771
4772     default:
4773       ffe_terminate_3 ();
4774       ffe_init_3 ();
4775       break;
4776
4777     case FFESTV_stateINTERFACE0:
4778       ffe_terminate_4 ();
4779       ffe_init_4 ();
4780       break;
4781     }
4782 }
4783
4784 /* ffestc_shriek_if_ -- End of statement following logical IF
4785
4786    ffestc_shriek_if_(TRUE);
4787
4788    Applies ONLY to logical IF, not to IF-THEN.  For example, does not
4789    ffelex_token_kill the construct name for an IF-THEN block (the name
4790    field is invalid for logical IF).  ok==TRUE iff statement following
4791    logical IF (substatement) is valid; else, statement is invalid or
4792    stack forcibly popped due to ffestc_eof().  */
4793
4794 static void
4795 ffestc_shriek_if_ (bool ok)
4796 {
4797   ffestd_end_R807 (ok);
4798
4799   ffestw_kill (ffestw_pop ());
4800   ffestc_shriek_after1_ = NULL;
4801
4802   ffestc_try_shriek_do_ ();
4803 }
4804
4805 /* ffestc_shriek_ifthen_ -- End an IF-THEN
4806
4807    ffestc_shriek_ifthen_(TRUE);  */
4808
4809 static void
4810 ffestc_shriek_ifthen_ (bool ok)
4811 {
4812   ffestd_R806 (ok);
4813
4814   if (ffestw_name (ffestw_stack_top ()) != NULL)
4815     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4816   ffestw_kill (ffestw_pop ());
4817
4818   ffestc_try_shriek_do_ ();
4819 }
4820
4821 /* ffestc_shriek_interface_ -- End an INTERFACE
4822
4823    ffestc_shriek_interface_(TRUE);  */
4824
4825 #if FFESTR_F90
4826 static void
4827 ffestc_shriek_interface_ (bool ok)
4828 {
4829   ffestd_R1203 (ok);
4830
4831   ffestw_kill (ffestw_pop ());
4832
4833   ffestc_try_shriek_do_ ();
4834 }
4835
4836 #endif
4837 /* ffestc_shriek_map_ -- End a MAP
4838
4839    ffestc_shriek_map_(TRUE);  */
4840
4841 #if FFESTR_VXT
4842 static void
4843 ffestc_shriek_map_ (bool ok)
4844 {
4845   ffestd_V013 (ok);
4846
4847   ffestw_kill (ffestw_pop ());
4848
4849   ffestc_try_shriek_do_ ();
4850 }
4851
4852 #endif
4853 /* ffestc_shriek_module_ -- End a MODULE
4854
4855    ffestc_shriek_module_(TRUE);  */
4856
4857 #if FFESTR_F90
4858 static void
4859 ffestc_shriek_module_ (bool ok)
4860 {
4861   if (!ffesta_seen_first_exec)
4862     {
4863       ffesta_seen_first_exec = TRUE;
4864       ffestd_exec_begin ();
4865     }
4866
4867   ffestd_R1106 (ok);
4868
4869   ffestd_exec_end ();
4870
4871   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4872   ffestw_kill (ffestw_pop ());
4873
4874   ffe_terminate_2 ();
4875   ffe_init_2 ();
4876 }
4877
4878 #endif
4879 /* ffestc_shriek_select_ -- End a SELECT
4880
4881    ffestc_shriek_select_(TRUE);  */
4882
4883 static void
4884 ffestc_shriek_select_ (bool ok)
4885 {
4886   ffestwSelect s;
4887   ffestwCase c;
4888
4889   ffestd_R811 (ok);
4890
4891   if (ffestw_name (ffestw_stack_top ()) != NULL)
4892     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4893   s = ffestw_select (ffestw_stack_top ());
4894   ffelex_token_kill (s->t);
4895   for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
4896     ffelex_token_kill (c->t);
4897   malloc_pool_kill (s->pool);
4898
4899   ffestw_kill (ffestw_pop ());
4900
4901   ffestc_try_shriek_do_ ();
4902 }
4903
4904 /* ffestc_shriek_structure_ -- End a STRUCTURE
4905
4906    ffestc_shriek_structure_(TRUE);  */
4907
4908 #if FFESTR_VXT
4909 static void
4910 ffestc_shriek_structure_ (bool ok)
4911 {
4912   ffestd_V004 (ok);
4913
4914   ffestw_kill (ffestw_pop ());
4915
4916   ffestc_try_shriek_do_ ();
4917 }
4918
4919 #endif
4920 /* ffestc_shriek_subroutine_ -- End a SUBROUTINE
4921
4922    ffestc_shriek_subroutine_(TRUE);  */
4923
4924 static void
4925 ffestc_shriek_subroutine_ (bool ok)
4926 {
4927   if (!ffesta_seen_first_exec)
4928     {
4929       ffesta_seen_first_exec = TRUE;
4930       ffestd_exec_begin ();
4931     }
4932
4933   ffestd_R1225 (ok);
4934
4935   ffestd_exec_end ();
4936
4937   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4938   ffestw_kill (ffestw_pop ());
4939   ffesta_is_entry_valid = FALSE;
4940
4941   switch (ffestw_state (ffestw_stack_top ()))
4942     {
4943     case FFESTV_stateNIL:
4944       ffe_terminate_2 ();
4945       ffe_init_2 ();
4946       break;
4947
4948     default:
4949       ffe_terminate_3 ();
4950       ffe_init_3 ();
4951       break;
4952
4953     case FFESTV_stateINTERFACE0:
4954       ffe_terminate_4 ();
4955       ffe_init_4 ();
4956       break;
4957     }
4958 }
4959
4960 /* ffestc_shriek_type_ -- End a TYPE
4961
4962    ffestc_shriek_type_(TRUE);  */
4963
4964 #if FFESTR_F90
4965 static void
4966 ffestc_shriek_type_ (bool ok)
4967 {
4968   ffestd_R425 (ok);
4969
4970   ffe_terminate_4 ();
4971
4972   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
4973   ffestw_kill (ffestw_pop ());
4974
4975   ffestc_try_shriek_do_ ();
4976 }
4977
4978 #endif
4979 /* ffestc_shriek_union_ -- End a UNION
4980
4981    ffestc_shriek_union_(TRUE);  */
4982
4983 #if FFESTR_VXT
4984 static void
4985 ffestc_shriek_union_ (bool ok)
4986 {
4987   ffestd_V010 (ok);
4988
4989   ffestw_kill (ffestw_pop ());
4990
4991   ffestc_try_shriek_do_ ();
4992 }
4993
4994 #endif
4995 /* ffestc_shriek_where_ -- Implicit END WHERE statement
4996
4997    ffestc_shriek_where_(TRUE);
4998
4999    Implement the end of the current WHERE "block".  ok==TRUE iff statement
5000    following WHERE (substatement) is valid; else, statement is invalid
5001    or stack forcibly popped due to ffestc_eof().  */
5002
5003 #if FFESTR_F90
5004 static void
5005 ffestc_shriek_where_ (bool ok)
5006 {
5007   ffestd_R745 (ok);
5008
5009   ffestw_kill (ffestw_pop ());
5010   ffestc_shriek_after1_ = NULL;
5011   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF)
5012     ffestc_shriek_if_ (TRUE);   /* "IF (x) WHERE (y) stmt" is only valid
5013                                    case. */
5014
5015   ffestc_try_shriek_do_ ();
5016 }
5017
5018 #endif
5019 /* ffestc_shriek_wherethen_ -- End a WHERE(-THEN)
5020
5021    ffestc_shriek_wherethen_(TRUE);  */
5022
5023 #if FFESTR_F90
5024 static void
5025 ffestc_shriek_wherethen_ (bool ok)
5026 {
5027   ffestd_end_R740 (ok);
5028
5029   ffestw_kill (ffestw_pop ());
5030
5031   ffestc_try_shriek_do_ ();
5032 }
5033
5034 #endif
5035 /* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
5036
5037    i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
5038
5039    search_list contains search_list_size char *'s, spec is checked to see
5040    if it is a char constant and, if so, is binary-searched against the list.
5041    0 is returned if not found, else the "classic" index (beginning with 1)
5042    is returned.  Before returning 0 where the search was performed but
5043    fruitless, if "etc" is a non-NULL char *, an error message is displayed
5044    using "etc" as the pick-one-of-these string.  */
5045
5046 static int
5047 ffestc_subr_binsrch_ (const char **list, int size, ffestpFile *spec, const char *whine)
5048 {
5049   int lowest_tested;
5050   int highest_tested;
5051   int halfway;
5052   int offset;
5053   int c;
5054   const char *str;
5055   int len;
5056
5057   if (size == 0)
5058     return 0;                   /* Nobody should pass size == 0, but for
5059                                    elegance.... */
5060
5061   lowest_tested = -1;
5062   highest_tested = size;
5063   halfway = size >> 1;
5064
5065   list += halfway;
5066
5067   c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
5068   if (c == 2)
5069     return 0;
5070   c = -c;                       /* Sigh.  */
5071
5072 next:                           /* :::::::::::::::::::: */
5073   switch (c)
5074     {
5075     case -1:
5076       offset = (halfway - lowest_tested) >> 1;
5077       if (offset == 0)
5078         goto nope;              /* :::::::::::::::::::: */
5079       highest_tested = halfway;
5080       list -= offset;
5081       halfway -= offset;
5082       c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
5083       goto next;                /* :::::::::::::::::::: */
5084
5085     case 0:
5086       return halfway + 1;
5087
5088     case 1:
5089       offset = (highest_tested - halfway) >> 1;
5090       if (offset == 0)
5091         goto nope;              /* :::::::::::::::::::: */
5092       lowest_tested = halfway;
5093       list += offset;
5094       halfway += offset;
5095       c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
5096       goto next;                /* :::::::::::::::::::: */
5097
5098     default:
5099       assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
5100       break;
5101     }
5102
5103 nope:                           /* :::::::::::::::::::: */
5104   ffebad_start (FFEBAD_SPEC_VALUE);
5105   ffebad_here (0, ffelex_token_where_line (spec->value),
5106                ffelex_token_where_column (spec->value));
5107   ffebad_string (whine);
5108   ffebad_finish ();
5109   return 0;
5110 }
5111
5112 /* ffestc_subr_format_ -- Return summary of format specifier
5113
5114    ffestc_subr_format_(&specifier);  */
5115
5116 static ffestvFormat
5117 ffestc_subr_format_ (ffestpFile *spec)
5118 {
5119   if (!spec->kw_or_val_present)
5120     return FFESTV_formatNONE;
5121   assert (spec->value_present);
5122   if (spec->value_is_label)
5123     return FFESTV_formatLABEL;  /* Ok if not a label. */
5124
5125   assert (spec->value != NULL);
5126   if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
5127     return FFESTV_formatASTERISK;
5128
5129   if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
5130     return FFESTV_formatNAMELIST;
5131
5132   if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
5133     return FFESTV_formatCHAREXPR;       /* F77 C5. */
5134
5135   switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
5136     {
5137     case FFEINFO_basictypeINTEGER:
5138       return FFESTV_formatINTEXPR;
5139
5140     case FFEINFO_basictypeCHARACTER:
5141       return FFESTV_formatCHAREXPR;
5142
5143     case FFEINFO_basictypeANY:
5144       return FFESTV_formatASTERISK;
5145
5146     default:
5147       assert ("bad basictype" == NULL);
5148       return FFESTV_formatINTEXPR;
5149     }
5150 }
5151
5152 /* ffestc_subr_is_branch_ -- Handle specifier as branch target label
5153
5154    ffestc_subr_is_branch_(&specifier);  */
5155
5156 static bool
5157 ffestc_subr_is_branch_ (ffestpFile *spec)
5158 {
5159   if (!spec->kw_or_val_present)
5160     return TRUE;
5161   assert (spec->value_present);
5162   assert (spec->value_is_label);
5163   spec->value_is_label++;       /* For checking purposes only; 1=>2. */
5164   return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
5165 }
5166
5167 /* ffestc_subr_is_format_ -- Handle specifier as format target label
5168
5169    ffestc_subr_is_format_(&specifier);  */
5170
5171 static bool
5172 ffestc_subr_is_format_ (ffestpFile *spec)
5173 {
5174   if (!spec->kw_or_val_present)
5175     return TRUE;
5176   assert (spec->value_present);
5177   if (!spec->value_is_label)
5178     return TRUE;                /* Ok if not a label. */
5179
5180   spec->value_is_label++;       /* For checking purposes only; 1=>2. */
5181   return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
5182 }
5183
5184 /* ffestc_subr_is_present_ -- Ensure specifier is present, else error
5185
5186    ffestc_subr_is_present_("SPECIFIER",&specifier);  */
5187
5188 static bool
5189 ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
5190 {
5191   if (spec->kw_or_val_present)
5192     {
5193       assert (spec->value_present);
5194       return TRUE;
5195     }
5196
5197   ffebad_start (FFEBAD_MISSING_SPECIFIER);
5198   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5199                ffelex_token_where_column (ffesta_tokens[0]));
5200   ffebad_string (name);
5201   ffebad_finish ();
5202   return FALSE;
5203 }
5204
5205 /* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
5206
5207    if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
5208        // specifier value is present and is a char constant "CONSTANT"
5209
5210    Like strcmp, except the return values are defined as: -1 returned in place
5211    of strcmp's generic negative value, 1 in place of it's generic positive
5212    value, and 2 when there is no character constant string to compare.  Also,
5213    a case-insensitive comparison is performed, where string is assumed to
5214    already be in InitialCaps form.
5215
5216    If a non-NULL pointer is provided as the char **target, then *target is
5217    written with NULL if 2 is returned, a pointer to the constant string
5218    value of the specifier otherwise.  Similarly, length is written with
5219    0 if 2 is returned, the length of the constant string value otherwise.  */
5220
5221 static int
5222 ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
5223                       int *length)
5224 {
5225   ffebldConstant c;
5226   int i;
5227
5228   if (!spec->kw_or_val_present || !spec->value_present
5229       || (spec->u.expr == NULL)
5230       || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
5231     {
5232       if (target != NULL)
5233         *target = NULL;
5234       if (length != NULL)
5235         *length = 0;
5236       return 2;
5237     }
5238
5239   if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
5240       != FFEBLD_constCHARACTERDEFAULT)
5241     {
5242       if (target != NULL)
5243         *target = NULL;
5244       if (length != NULL)
5245         *length = 0;
5246       return 2;
5247     }
5248
5249   if (target != NULL)
5250     *target = ffebld_constant_characterdefault (c).text;
5251   if (length != NULL)
5252     *length = ffebld_constant_characterdefault (c).length;
5253
5254   i = ffesrc_strcmp_1ns2i (ffe_case_match (),
5255                            ffebld_constant_characterdefault (c).text,
5256                            ffebld_constant_characterdefault (c).length,
5257                            string);
5258   if (i == 0)
5259     return 0;
5260   if (i > 0)
5261     return -1;                  /* Yes indeed, we reverse the strings to
5262                                    _strcmpin_.   */
5263   return 1;
5264 }
5265
5266 /* ffestc_subr_unit_ -- Return summary of unit specifier
5267
5268    ffestc_subr_unit_(&specifier);  */
5269
5270 static ffestvUnit
5271 ffestc_subr_unit_ (ffestpFile *spec)
5272 {
5273   if (!spec->kw_or_val_present)
5274     return FFESTV_unitNONE;
5275   assert (spec->value_present);
5276   assert (spec->value != NULL);
5277
5278   if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
5279     return FFESTV_unitASTERISK;
5280
5281   switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
5282     {
5283     case FFEINFO_basictypeINTEGER:
5284       return FFESTV_unitINTEXPR;
5285
5286     case FFEINFO_basictypeCHARACTER:
5287       return FFESTV_unitCHAREXPR;
5288
5289     case FFEINFO_basictypeANY:
5290       return FFESTV_unitASTERISK;
5291
5292     default:
5293       assert ("bad basictype" == NULL);
5294       return FFESTV_unitINTEXPR;
5295     }
5296 }
5297
5298 /* Call this function whenever it's possible that one or more top
5299    stack items are label-targeting DO blocks that have had their
5300    labels defined, but at a time when they weren't at the top of the
5301    stack.  This prevents uninformative diagnostics for programs
5302    like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END".  */
5303
5304 static void
5305 ffestc_try_shriek_do_ ()
5306 {
5307   ffelab lab;
5308   ffelabType ty;
5309
5310   while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
5311          && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
5312          && (((ty = (ffelab_type (lab)))
5313               == FFELAB_typeANY)
5314              || (ty == FFELAB_typeUSELESS)
5315              || (ty == FFELAB_typeFORMAT)
5316              || (ty == FFELAB_typeNOTLOOP)
5317              || (ty == FFELAB_typeENDIF)))
5318     ffestc_shriek_do_ (FALSE);
5319 }
5320
5321 /* ffestc_decl_start -- R426 or R501
5322
5323    ffestc_decl_start(...);
5324
5325    Verify that R426 component-def-stmt or R501 type-declaration-stmt are
5326    valid here, figure out which one, and implement.  */
5327
5328 void
5329 ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
5330                    ffelexToken kindt, ffebld len, ffelexToken lent)
5331 {
5332   switch (ffestw_state (ffestw_stack_top ()))
5333     {
5334     case FFESTV_stateNIL:
5335     case FFESTV_statePROGRAM0:
5336     case FFESTV_stateSUBROUTINE0:
5337     case FFESTV_stateFUNCTION0:
5338     case FFESTV_stateMODULE0:
5339     case FFESTV_stateBLOCKDATA0:
5340     case FFESTV_statePROGRAM1:
5341     case FFESTV_stateSUBROUTINE1:
5342     case FFESTV_stateFUNCTION1:
5343     case FFESTV_stateMODULE1:
5344     case FFESTV_stateBLOCKDATA1:
5345     case FFESTV_statePROGRAM2:
5346     case FFESTV_stateSUBROUTINE2:
5347     case FFESTV_stateFUNCTION2:
5348     case FFESTV_stateMODULE2:
5349     case FFESTV_stateBLOCKDATA2:
5350     case FFESTV_statePROGRAM3:
5351     case FFESTV_stateSUBROUTINE3:
5352     case FFESTV_stateFUNCTION3:
5353     case FFESTV_stateMODULE3:
5354     case FFESTV_stateBLOCKDATA3:
5355     case FFESTV_stateUSE:
5356       ffestc_local_.decl.is_R426 = 2;
5357       break;
5358
5359     case FFESTV_stateTYPE:
5360     case FFESTV_stateSTRUCTURE:
5361     case FFESTV_stateMAP:
5362       ffestc_local_.decl.is_R426 = 1;
5363       break;
5364
5365     default:
5366       ffestc_order_bad_ ();
5367       ffestc_labeldef_useless_ ();
5368       ffestc_local_.decl.is_R426 = 0;
5369       return;
5370     }
5371
5372   switch (ffestc_local_.decl.is_R426)
5373     {
5374 #if FFESTR_F90
5375     case 1:
5376       ffestc_R426_start (type, typet, kind, kindt, len, lent);
5377       break;
5378 #endif
5379
5380     case 2:
5381       ffestc_R501_start (type, typet, kind, kindt, len, lent);
5382       break;
5383
5384     default:
5385       ffestc_labeldef_useless_ ();
5386       break;
5387     }
5388 }
5389
5390 /* ffestc_decl_attrib -- R426 or R501 type attribute
5391
5392    ffestc_decl_attrib(...);
5393
5394    Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
5395    is valid here and implement.  */
5396
5397 void
5398 ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
5399                     ffelexToken attribt UNUSED,
5400                     ffestrOther intent_kw UNUSED,
5401                     ffesttDimList dims UNUSED)
5402 {
5403 #if FFESTR_F90
5404   switch (ffestc_local_.decl.is_R426)
5405     {
5406     case 1:
5407       ffestc_R426_attrib (attrib, attribt, intent_kw, dims);
5408       break;
5409
5410     case 2:
5411       ffestc_R501_attrib (attrib, attribt, intent_kw, dims);
5412       break;
5413
5414     default:
5415       break;
5416     }
5417 #else
5418   ffebad_start (FFEBAD_F90);
5419   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5420                ffelex_token_where_column (ffesta_tokens[0]));
5421   ffebad_finish ();
5422   return;
5423 #endif
5424 }
5425
5426 /* ffestc_decl_item -- R426 or R501
5427
5428    ffestc_decl_item(...);
5429
5430    Establish type for a particular object.  */
5431
5432 void
5433 ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
5434               ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
5435                   ffelexToken initt, bool clist)
5436 {
5437   switch (ffestc_local_.decl.is_R426)
5438     {
5439 #if FFESTR_F90
5440     case 1:
5441       ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt,
5442                         clist);
5443       break;
5444 #endif
5445
5446     case 2:
5447       ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
5448                         clist);
5449       break;
5450
5451     default:
5452       break;
5453     }
5454 }
5455
5456 /* ffestc_decl_itemstartvals -- R426 or R501 start list of values
5457
5458    ffestc_decl_itemstartvals();
5459
5460    Gonna specify values for the object now.  */
5461
5462 void
5463 ffestc_decl_itemstartvals ()
5464 {
5465   switch (ffestc_local_.decl.is_R426)
5466     {
5467 #if FFESTR_F90
5468     case 1:
5469       ffestc_R426_itemstartvals ();
5470       break;
5471 #endif
5472
5473     case 2:
5474       ffestc_R501_itemstartvals ();
5475       break;
5476
5477     default:
5478       break;
5479     }
5480 }
5481
5482 /* ffestc_decl_itemvalue -- R426 or R501 source value
5483
5484    ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
5485
5486    Make sure repeat and value are valid for the object being initialized.  */
5487
5488 void
5489 ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
5490                        ffebld value, ffelexToken value_token)
5491 {
5492   switch (ffestc_local_.decl.is_R426)
5493     {
5494 #if FFESTR_F90
5495     case 1:
5496       ffestc_R426_itemvalue (repeat, repeat_token, value, value_token);
5497       break;
5498 #endif
5499
5500     case 2:
5501       ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
5502       break;
5503
5504     default:
5505       break;
5506     }
5507 }
5508
5509 /* ffestc_decl_itemendvals -- R426 or R501 end list of values
5510
5511    ffelexToken t;  // the SLASH token that ends the list.
5512    ffestc_decl_itemendvals(t);
5513
5514    No more values, might specify more objects now.  */
5515
5516 void
5517 ffestc_decl_itemendvals (ffelexToken t)
5518 {
5519   switch (ffestc_local_.decl.is_R426)
5520     {
5521 #if FFESTR_F90
5522     case 1:
5523       ffestc_R426_itemendvals (t);
5524       break;
5525 #endif
5526
5527     case 2:
5528       ffestc_R501_itemendvals (t);
5529       break;
5530
5531     default:
5532       break;
5533     }
5534 }
5535
5536 /* ffestc_decl_finish -- R426 or R501
5537
5538    ffestc_decl_finish();
5539
5540    Just wrap up any local activities.  */
5541
5542 void
5543 ffestc_decl_finish ()
5544 {
5545   switch (ffestc_local_.decl.is_R426)
5546     {
5547 #if FFESTR_F90
5548     case 1:
5549       ffestc_R426_finish ();
5550       break;
5551 #endif
5552
5553     case 2:
5554       ffestc_R501_finish ();
5555       break;
5556
5557     default:
5558       break;
5559     }
5560 }
5561
5562 /* ffestc_elsewhere -- Generic ELSE WHERE statement
5563
5564    ffestc_end();
5565
5566    Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant.  */
5567
5568 void
5569 ffestc_elsewhere (ffelexToken where)
5570 {
5571   switch (ffestw_state (ffestw_stack_top ()))
5572     {
5573     case FFESTV_stateIFTHEN:
5574       ffestc_R805 (where);
5575       break;
5576
5577     default:
5578 #if FFESTR_F90
5579       ffestc_R744 ();
5580 #endif
5581       break;
5582     }
5583 }
5584
5585 /* ffestc_end -- Generic END statement
5586
5587    ffestc_end();
5588
5589    Make sure a generic END is valid in the current context, and implement
5590    it.  */
5591
5592 void
5593 ffestc_end ()
5594 {
5595   ffestw b;
5596
5597   b = ffestw_stack_top ();
5598
5599 recurse:
5600
5601   switch (ffestw_state (b))
5602     {
5603     case FFESTV_stateBLOCKDATA0:
5604     case FFESTV_stateBLOCKDATA1:
5605     case FFESTV_stateBLOCKDATA2:
5606     case FFESTV_stateBLOCKDATA3:
5607     case FFESTV_stateBLOCKDATA4:
5608     case FFESTV_stateBLOCKDATA5:
5609       ffestc_R1112 (NULL);
5610       break;
5611
5612     case FFESTV_stateFUNCTION0:
5613     case FFESTV_stateFUNCTION1:
5614     case FFESTV_stateFUNCTION2:
5615     case FFESTV_stateFUNCTION3:
5616     case FFESTV_stateFUNCTION4:
5617     case FFESTV_stateFUNCTION5:
5618       if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
5619           && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
5620         {
5621           ffebad_start (FFEBAD_END_WO);
5622           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5623                        ffelex_token_where_column (ffesta_tokens[0]));
5624           ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
5625           ffebad_string ("FUNCTION");
5626           ffebad_finish ();
5627         }
5628       ffestc_R1221 (NULL);
5629       break;
5630
5631     case FFESTV_stateMODULE0:
5632     case FFESTV_stateMODULE1:
5633     case FFESTV_stateMODULE2:
5634     case FFESTV_stateMODULE3:
5635     case FFESTV_stateMODULE4:
5636     case FFESTV_stateMODULE5:
5637 #if FFESTR_F90
5638       ffestc_R1106 (NULL);
5639 #endif
5640       break;
5641
5642     case FFESTV_stateSUBROUTINE0:
5643     case FFESTV_stateSUBROUTINE1:
5644     case FFESTV_stateSUBROUTINE2:
5645     case FFESTV_stateSUBROUTINE3:
5646     case FFESTV_stateSUBROUTINE4:
5647     case FFESTV_stateSUBROUTINE5:
5648       if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
5649           && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
5650         {
5651           ffebad_start (FFEBAD_END_WO);
5652           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5653                        ffelex_token_where_column (ffesta_tokens[0]));
5654           ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
5655           ffebad_string ("SUBROUTINE");
5656           ffebad_finish ();
5657         }
5658       ffestc_R1225 (NULL);
5659       break;
5660
5661     case FFESTV_stateUSE:
5662       b = ffestw_previous (ffestw_stack_top ());
5663       goto recurse;             /* :::::::::::::::::::: */
5664
5665     default:
5666       ffestc_R1103 (NULL);
5667       break;
5668     }
5669 }
5670
5671 /* ffestc_eof -- Generic EOF
5672
5673    ffestc_eof();
5674
5675    Make sure we're at state NIL, or issue an error message and use each
5676    block's shriek function to clean up to state NIL.  */
5677
5678 void
5679 ffestc_eof ()
5680 {
5681   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
5682     {
5683       ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
5684       ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
5685       ffebad_finish ();
5686       do
5687         (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
5688       while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
5689     }
5690 }
5691
5692 /* ffestc_exec_transition -- Check if ok and move stmt state to executable
5693
5694    if (ffestc_exec_transition())
5695        // Transition successful (kind of like a CONTINUE stmt was seen).
5696
5697    If the current statement state is a non-nested specification state in
5698    which, say, a CONTINUE statement would be valid, then enter the state
5699    we'd be in after seeing CONTINUE (without, of course, generating any
5700    CONTINUE code), call ffestd_exec_begin, and return TRUE.  Otherwise
5701    return FALSE.
5702
5703    This function cannot be invoked once the first executable statement
5704    is seen.  This function may choose to always return TRUE by shrieking
5705    away any interceding state stack entries to reach the base level of
5706    specification state, but right now it doesn't, and it is (or should
5707    be) purely an issue of how one wishes errors to be handled (for example,
5708    an unrecognized statement in the middle of a STRUCTURE construct: after
5709    the error message, should subsequent statements still be interpreted as
5710    being within the construct, or should the construct be terminated upon
5711    seeing the unrecognized statement?  we do the former at the moment).  */
5712
5713 bool
5714 ffestc_exec_transition ()
5715 {
5716   bool update;
5717
5718 recurse:
5719
5720   switch (ffestw_state (ffestw_stack_top ()))
5721     {
5722     case FFESTV_stateNIL:
5723       ffestc_shriek_begin_program_ ();
5724       goto recurse;             /* :::::::::::::::::::: */
5725
5726     case FFESTV_statePROGRAM0:
5727     case FFESTV_stateSUBROUTINE0:
5728     case FFESTV_stateFUNCTION0:
5729     case FFESTV_stateBLOCKDATA0:
5730       ffestw_state (ffestw_stack_top ()) += 4;  /* To state UNIT4. */
5731       update = TRUE;
5732       break;
5733
5734     case FFESTV_statePROGRAM1:
5735     case FFESTV_stateSUBROUTINE1:
5736     case FFESTV_stateFUNCTION1:
5737     case FFESTV_stateBLOCKDATA1:
5738       ffestw_state (ffestw_stack_top ()) += 3;  /* To state UNIT4. */
5739       update = TRUE;
5740       break;
5741
5742     case FFESTV_statePROGRAM2:
5743     case FFESTV_stateSUBROUTINE2:
5744     case FFESTV_stateFUNCTION2:
5745     case FFESTV_stateBLOCKDATA2:
5746       ffestw_state (ffestw_stack_top ()) += 2;  /* To state UNIT4. */
5747       update = TRUE;
5748       break;
5749
5750     case FFESTV_statePROGRAM3:
5751     case FFESTV_stateSUBROUTINE3:
5752     case FFESTV_stateFUNCTION3:
5753     case FFESTV_stateBLOCKDATA3:
5754       ffestw_state (ffestw_stack_top ()) += 1;  /* To state UNIT4. */
5755       update = TRUE;
5756       break;
5757
5758     case FFESTV_stateUSE:
5759 #if FFESTR_F90
5760       ffestc_shriek_end_uses_ (TRUE);
5761 #endif
5762       goto recurse;             /* :::::::::::::::::::: */
5763
5764     default:
5765       return FALSE;
5766     }
5767
5768   if (update)
5769     ffestw_update (NULL);       /* Update state line/col info. */
5770
5771   ffesta_seen_first_exec = TRUE;
5772   ffestd_exec_begin ();
5773
5774   return TRUE;
5775 }
5776
5777 /* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
5778
5779    ffesymbol s;
5780    // call ffebad_start first, of course.
5781    ffestc_ffebad_here_doiter(0,s);
5782    // call ffebad_finish afterwards, naturally.
5783
5784    Searches the stack of blocks backwards for a DO loop that has s
5785    as its iteration variable, then calls ffebad_here with pointers to
5786    that particular reference to the variable.  Crashes if the DO loop
5787    can't be found.  */
5788
5789 void
5790 ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
5791 {
5792   ffestw block;
5793
5794   for (block = ffestw_top_do (ffestw_stack_top ());
5795        (block != NULL) && (ffestw_blocknum (block) != 0);
5796        block = ffestw_top_do (ffestw_previous (block)))
5797     {
5798       if (ffestw_do_iter_var (block) == s)
5799         {
5800           ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
5801                   ffelex_token_where_column (ffestw_do_iter_var_t (block)));
5802           return;
5803         }
5804     }
5805   assert ("no do block found" == NULL);
5806 }
5807
5808 /* ffestc_is_decl_not_R1219 -- Context information for FFESTB
5809
5810    if (ffestc_is_decl_not_R1219()) ...
5811
5812    When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
5813    is seen, call this function.  It returns TRUE if the statement's context
5814    is such that it is a declaration of an object named
5815    "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
5816    if the statement's context is such that it begins the definition of a
5817    function named "name" havin the dummy argument list "name-list" (this
5818    is the R1219 function-stmt case).  */
5819
5820 bool
5821 ffestc_is_decl_not_R1219 ()
5822 {
5823   switch (ffestw_state (ffestw_stack_top ()))
5824     {
5825     case FFESTV_stateNIL:
5826     case FFESTV_statePROGRAM5:
5827     case FFESTV_stateSUBROUTINE5:
5828     case FFESTV_stateFUNCTION5:
5829     case FFESTV_stateMODULE5:
5830     case FFESTV_stateINTERFACE0:
5831       return FALSE;
5832
5833     default:
5834       return TRUE;
5835     }
5836 }
5837
5838 /* ffestc_is_entry_in_subr -- Context information for FFESTB
5839
5840    if (ffestc_is_entry_in_subr()) ...
5841
5842    When a statement with the form "ENTRY name(name-list)"
5843    is seen, call this function.  It returns TRUE if the statement's context
5844    is such that it may have "*", meaning alternate return, in place of
5845    names in the name list (i.e. if the ENTRY is in a subroutine context).
5846    It also returns TRUE if the ENTRY is not in a function context (invalid
5847    but prevents extra complaints about "*", if present).  It returns FALSE
5848    if the ENTRY is in a function context.  */
5849
5850 bool
5851 ffestc_is_entry_in_subr ()
5852 {
5853   ffestvState s;
5854
5855   s = ffestw_state (ffestw_stack_top ());
5856
5857 recurse:
5858
5859   switch (s)
5860     {
5861     case FFESTV_stateFUNCTION0:
5862     case FFESTV_stateFUNCTION1:
5863     case FFESTV_stateFUNCTION2:
5864     case FFESTV_stateFUNCTION3:
5865     case FFESTV_stateFUNCTION4:
5866       return FALSE;
5867
5868     case FFESTV_stateUSE:
5869       s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
5870       goto recurse;             /* :::::::::::::::::::: */
5871
5872     default:
5873       return TRUE;
5874     }
5875 }
5876
5877 /* ffestc_is_let_not_V027 -- Context information for FFESTB
5878
5879    if (ffestc_is_let_not_V027()) ...
5880
5881    When a statement with the form "PARAMETERname=expr"
5882    is seen, call this function.  It returns TRUE if the statement's context
5883    is such that it is an assignment to an object named "PARAMETERname", FALSE
5884    if the statement's context is such that it is a V-extension PARAMETER
5885    statement that is like a PARAMETER(name=expr) statement except that the
5886    type of name is determined by the type of expr, not the implicit or
5887    explicit typing of name.  */
5888
5889 bool
5890 ffestc_is_let_not_V027 ()
5891 {
5892   switch (ffestw_state (ffestw_stack_top ()))
5893     {
5894     case FFESTV_statePROGRAM4:
5895     case FFESTV_stateSUBROUTINE4:
5896     case FFESTV_stateFUNCTION4:
5897     case FFESTV_stateWHERETHEN:
5898     case FFESTV_stateIFTHEN:
5899     case FFESTV_stateDO:
5900     case FFESTV_stateSELECT0:
5901     case FFESTV_stateSELECT1:
5902     case FFESTV_stateWHERE:
5903     case FFESTV_stateIF:
5904       return TRUE;
5905
5906     default:
5907       return FALSE;
5908     }
5909 }
5910
5911 /* ffestc_module -- MODULE or MODULE PROCEDURE statement
5912
5913    ffestc_module(module_name_token,procedure_name_token);
5914
5915    Decide which is intended, and implement it by calling _R1105_ or
5916    _R1205_.  */
5917
5918 #if FFESTR_F90
5919 void
5920 ffestc_module (ffelexToken module, ffelexToken procedure)
5921 {
5922   switch (ffestw_state (ffestw_stack_top ()))
5923     {
5924     case FFESTV_stateINTERFACE0:
5925     case FFESTV_stateINTERFACE1:
5926       ffestc_R1205_start ();
5927       ffestc_R1205_item (procedure);
5928       ffestc_R1205_finish ();
5929       break;
5930
5931     default:
5932       ffestc_R1105 (module);
5933       break;
5934     }
5935 }
5936
5937 #endif
5938 /* ffestc_private -- Generic PRIVATE statement
5939
5940    ffestc_end();
5941
5942    This is either a PRIVATE within R422 derived-type statement or an
5943    R521 PRIVATE statement.  Figure it out based on context and implement
5944    it, or produce an error.  */
5945
5946 #if FFESTR_F90
5947 void
5948 ffestc_private ()
5949 {
5950   switch (ffestw_state (ffestw_stack_top ()))
5951     {
5952     case FFESTV_stateTYPE:
5953       ffestc_R423A ();
5954       break;
5955
5956     default:
5957       ffestc_R521B ();
5958       break;
5959     }
5960 }
5961
5962 #endif
5963 /* ffestc_terminate_4 -- Terminate ffestc after scoping unit
5964
5965    ffestc_terminate_4();
5966
5967    For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
5968    defs, and statement function defs.  */
5969
5970 void
5971 ffestc_terminate_4 ()
5972 {
5973   ffestc_entry_num_ = ffestc_saved_entry_num_;
5974 }
5975
5976 /* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement)
5977
5978    ffestc_R423A();  */
5979
5980 #if FFESTR_F90
5981 void
5982 ffestc_R423A ()
5983 {
5984   ffestc_check_simple_ ();
5985   if (ffestc_order_type_ () != FFESTC_orderOK_)
5986     return;
5987   ffestc_labeldef_useless_ ();
5988
5989   if (ffestw_substate (ffestw_stack_top ()) != 0)
5990     {
5991       ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
5992       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
5993                    ffelex_token_where_column (ffesta_tokens[0]));
5994       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
5995       ffebad_finish ();
5996       return;
5997     }
5998
5999   if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3)
6000     {
6001       ffebad_start (FFEBAD_DERIVTYP_ACCESS);
6002       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6003                    ffelex_token_where_column (ffesta_tokens[0]));
6004       ffebad_finish ();
6005       return;
6006     }
6007
6008   ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
6009                                                    private-sequence-stmt. */
6010
6011   ffestd_R423A ();
6012 }
6013
6014 /* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
6015
6016    ffestc_R423B();  */
6017
6018 void
6019 ffestc_R423B ()
6020 {
6021   ffestc_check_simple_ ();
6022   if (ffestc_order_type_ () != FFESTC_orderOK_)
6023     return;
6024   ffestc_labeldef_useless_ ();
6025
6026   if (ffestw_substate (ffestw_stack_top ()) != 0)
6027     {
6028       ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
6029       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6030                    ffelex_token_where_column (ffesta_tokens[0]));
6031       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6032       ffebad_finish ();
6033       return;
6034     }
6035
6036   ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
6037                                                    private-sequence-stmt. */
6038
6039   ffestd_R423B ();
6040 }
6041
6042 /* ffestc_R424 -- derived-TYPE-def statement
6043
6044    ffestc_R424(access_token,access_kw,name_token);
6045
6046    Handle a derived-type definition.  */
6047
6048 void
6049 ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
6050 {
6051   ffestw b;
6052
6053   assert (name != NULL);
6054
6055   ffestc_check_simple_ ();
6056   if (ffestc_order_derivedtype_ () != FFESTC_orderOK_)
6057     return;
6058   ffestc_labeldef_useless_ ();
6059
6060   if ((access != NULL)
6061       && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3))
6062     {
6063       ffebad_start (FFEBAD_DERIVTYP_ACCESS);
6064       ffebad_here (0, ffelex_token_where_line (access),
6065                    ffelex_token_where_column (access));
6066       ffebad_finish ();
6067       access = NULL;
6068     }
6069
6070   b = ffestw_update (ffestw_push (NULL));
6071   ffestw_set_top_do (b, NULL);
6072   ffestw_set_state (b, FFESTV_stateTYPE);
6073   ffestw_set_blocknum (b, 0);
6074   ffestw_set_shriek (b, ffestc_shriek_type_);
6075   ffestw_set_name (b, ffelex_token_use (name));
6076   ffestw_set_substate (b, 0);   /* Awaiting private-sequence-stmt and one
6077                                    component-def-stmt. */
6078
6079   ffestd_R424 (access, access_kw, name);
6080
6081   ffe_init_4 ();
6082 }
6083
6084 /* ffestc_R425 -- END TYPE statement
6085
6086    ffestc_R425(name_token);
6087
6088    Make sure ffestc_kind_ identifies a TYPE definition.  If not
6089    NULL, make sure name_token gives the correct name.  Implement the end
6090    of the type definition.  */
6091
6092 void
6093 ffestc_R425 (ffelexToken name)
6094 {
6095   ffestc_check_simple_ ();
6096   if (ffestc_order_type_ () != FFESTC_orderOK_)
6097     return;
6098   ffestc_labeldef_useless_ ();
6099
6100   if (ffestw_substate (ffestw_stack_top ()) != 2)
6101     {
6102       ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS);
6103       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
6104                    ffelex_token_where_column (ffesta_tokens[0]));
6105       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
6106       ffebad_finish ();
6107     }
6108
6109   if ((name != NULL)
6110     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
6111     {
6112       ffebad_start (FFEBAD_TYPE_WRONG_NAME);
6113       ffebad_here (0, ffelex_token_where_line (name),
6114                    ffelex_token_where_column (name));
6115       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
6116              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
6117       ffebad_finish ();
6118     }
6119
6120   ffestc_shriek_type_ (TRUE);
6121 }
6122
6123 /* ffestc_R426_start -- component-declaration-stmt
6124
6125    ffestc_R426_start(...);
6126
6127    Verify that R426 component-declaration-stmt is
6128    valid here and implement.  */
6129
6130 void
6131 ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind,
6132                    ffelexToken kindt, ffebld len, ffelexToken lent)
6133 {
6134   ffestc_check_start_ ();
6135   if (ffestc_order_component_ () != FFESTC_orderOK_)
6136     {
6137       ffestc_local_.decl.is_R426 = 0;
6138       return;
6139     }
6140   ffestc_labeldef_useless_ ();
6141
6142   switch (ffestw_state (ffestw_stack_top ()))
6143     {
6144     case FFESTV_stateSTRUCTURE:
6145     case FFESTV_stateMAP:
6146       ffestw_set_substate (ffestw_stack_top (), 1);     /* Seen at least one
6147                                                            member. */
6148       break;
6149
6150     case FFESTV_stateTYPE:
6151       ffestw_set_substate (ffestw_stack_top (), 2);
6152       break;
6153
6154     default:
6155       assert ("Component parent state invalid" == NULL);
6156       break;
6157     }
6158 }
6159
6160 /* ffestc_R426_attrib -- type attribute
6161
6162    ffestc_R426_attrib(...);
6163
6164    Verify that R426 component-declaration-stmt attribute
6165    is valid here and implement.  */
6166
6167 void
6168 ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt,
6169                     ffestrOther intent_kw, ffesttDimList dims)
6170 {
6171   ffestc_check_attrib_ ();
6172 }
6173
6174 /* ffestc_R426_item -- declared object
6175
6176    ffestc_R426_item(...);
6177
6178    Establish type for a particular object.  */
6179
6180 void
6181 ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt,
6182               ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
6183                   ffelexToken initt, bool clist)
6184 {
6185   ffestc_check_item_ ();
6186   assert (name != NULL);
6187   assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
6188   assert (kind == NULL);        /* No way an expression should get here. */
6189
6190   if ((dims != NULL) || (init != NULL) || clist)
6191     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6192 }
6193
6194 /* ffestc_R426_itemstartvals -- Start list of values
6195
6196    ffestc_R426_itemstartvals();
6197
6198    Gonna specify values for the object now.  */
6199
6200 void
6201 ffestc_R426_itemstartvals ()
6202 {
6203   ffestc_check_item_startvals_ ();
6204 }
6205
6206 /* ffestc_R426_itemvalue -- Source value
6207
6208    ffestc_R426_itemvalue(repeat,repeat_token,value,value_token);
6209
6210    Make sure repeat and value are valid for the object being initialized.  */
6211
6212 void
6213 ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token,
6214                        ffebld value, ffelexToken value_token)
6215 {
6216   ffestc_check_item_value_ ();
6217 }
6218
6219 /* ffestc_R426_itemendvals -- End list of values
6220
6221    ffelexToken t;  // the SLASH token that ends the list.
6222    ffestc_R426_itemendvals(t);
6223
6224    No more values, might specify more objects now.  */
6225
6226 void
6227 ffestc_R426_itemendvals (ffelexToken t)
6228 {
6229   ffestc_check_item_endvals_ ();
6230 }
6231
6232 /* ffestc_R426_finish -- Done
6233
6234    ffestc_R426_finish();
6235
6236    Just wrap up any local activities.  */
6237
6238 void
6239 ffestc_R426_finish ()
6240 {
6241   ffestc_check_finish_ ();
6242 }
6243
6244 #endif
6245 /* ffestc_R501_start -- type-declaration-stmt
6246
6247    ffestc_R501_start(...);
6248
6249    Verify that R501 type-declaration-stmt is
6250    valid here and implement.  */
6251
6252 void
6253 ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
6254                    ffelexToken kindt, ffebld len, ffelexToken lent)
6255 {
6256   ffestc_check_start_ ();
6257   if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
6258     {
6259       ffestc_local_.decl.is_R426 = 0;
6260       return;
6261     }
6262   ffestc_labeldef_useless_ ();
6263
6264   ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
6265 }
6266
6267 /* ffestc_R501_attrib -- type attribute
6268
6269    ffestc_R501_attrib(...);
6270
6271    Verify that R501 type-declaration-stmt attribute
6272    is valid here and implement.  */
6273
6274 void
6275 ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
6276                     ffestrOther intent_kw UNUSED,
6277                     ffesttDimList dims UNUSED)
6278 {
6279   ffestc_check_attrib_ ();
6280
6281   switch (attrib)
6282     {
6283 #if FFESTR_F90
6284     case FFESTP_attribALLOCATABLE:
6285       break;
6286 #endif
6287
6288     case FFESTP_attribDIMENSION:
6289       ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6290       break;
6291
6292     case FFESTP_attribEXTERNAL:
6293       break;
6294
6295 #if FFESTR_F90
6296     case FFESTP_attribINTENT:
6297       break;
6298 #endif
6299
6300     case FFESTP_attribINTRINSIC:
6301       break;
6302
6303 #if FFESTR_F90
6304     case FFESTP_attribOPTIONAL:
6305       break;
6306 #endif
6307
6308     case FFESTP_attribPARAMETER:
6309       break;
6310
6311 #if FFESTR_F90
6312     case FFESTP_attribPOINTER:
6313       break;
6314 #endif
6315
6316 #if FFESTR_F90
6317     case FFESTP_attribPRIVATE:
6318       break;
6319
6320     case FFESTP_attribPUBLIC:
6321       break;
6322 #endif
6323
6324     case FFESTP_attribSAVE:
6325       switch (ffestv_save_state_)
6326         {
6327         case FFESTV_savestateNONE:
6328           ffestv_save_state_ = FFESTV_savestateSPECIFIC;
6329           ffestv_save_line_
6330             = ffewhere_line_use (ffelex_token_where_line (attribt));
6331           ffestv_save_col_
6332             = ffewhere_column_use (ffelex_token_where_column (attribt));
6333           break;
6334
6335         case FFESTV_savestateSPECIFIC:
6336         case FFESTV_savestateANY:
6337           break;
6338
6339         case FFESTV_savestateALL:
6340           if (ffe_is_pedantic ())
6341             {
6342               ffebad_start (FFEBAD_CONFLICTING_SAVES);
6343               ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
6344               ffebad_here (1, ffelex_token_where_line (attribt),
6345                            ffelex_token_where_column (attribt));
6346               ffebad_finish ();
6347             }
6348           ffestv_save_state_ = FFESTV_savestateANY;
6349           break;
6350
6351         default:
6352           assert ("unexpected save state" == NULL);
6353           break;
6354         }
6355       break;
6356
6357 #if FFESTR_F90
6358     case FFESTP_attribTARGET:
6359       break;
6360 #endif
6361
6362     default:
6363       assert ("unexpected attribute" == NULL);
6364       break;
6365     }
6366 }
6367
6368 /* ffestc_R501_item -- declared object
6369
6370    ffestc_R501_item(...);
6371
6372    Establish type for a particular object.  */
6373
6374 void
6375 ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
6376                   ffesttDimList dims, ffebld len, ffelexToken lent,
6377                   ffebld init, ffelexToken initt, bool clist)
6378 {
6379   ffesymbol s;
6380   ffesymbol sfn;                /* FUNCTION symbol. */
6381   ffebld array_size;
6382   ffebld extents;
6383   ffesymbolAttrs sa;
6384   ffesymbolAttrs na;
6385   ffestpDimtype nd;
6386   bool is_init = (init != NULL) || clist;
6387   bool is_assumed;
6388   bool is_ugly_assumed;
6389   ffeinfoRank rank;
6390
6391   ffestc_check_item_ ();
6392   assert (name != NULL);
6393   assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
6394   assert (kind == NULL);        /* No way an expression should get here. */
6395
6396   ffestc_establish_declinfo_ (kind, kindt, len, lent);
6397
6398   is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
6399     && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
6400
6401   if ((dims != NULL) || is_init)
6402     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6403
6404   s = ffesymbol_declare_local (name, TRUE);
6405   sa = ffesymbol_attrs (s);
6406
6407   /* First figure out what kind of object this is based solely on the current
6408      object situation (type params, dimension list, and initialization). */
6409
6410   na = FFESYMBOL_attrsTYPE;
6411
6412   if (is_assumed)
6413     na |= FFESYMBOL_attrsANYLEN;
6414
6415   is_ugly_assumed = (ffe_is_ugly_assumed ()
6416                      && ((sa & FFESYMBOL_attrsDUMMY)
6417                          || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
6418
6419   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
6420   switch (nd)
6421     {
6422     case FFESTP_dimtypeNONE:
6423       break;
6424
6425     case FFESTP_dimtypeKNOWN:
6426       na |= FFESYMBOL_attrsARRAY;
6427       break;
6428
6429     case FFESTP_dimtypeADJUSTABLE:
6430       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
6431       break;
6432
6433     case FFESTP_dimtypeASSUMED:
6434       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
6435       break;
6436
6437     case FFESTP_dimtypeADJUSTABLEASSUMED:
6438       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
6439         | FFESYMBOL_attrsANYSIZE;
6440       break;
6441
6442     default:
6443       assert ("unexpected dimtype" == NULL);
6444       na = FFESYMBOL_attrsetNONE;
6445       break;
6446     }
6447
6448   if (!ffesta_is_entry_valid
6449       && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
6450            == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
6451     na = FFESYMBOL_attrsetNONE;
6452
6453   if (is_init)
6454     {
6455       if (na == FFESYMBOL_attrsetNONE)
6456         ;
6457       else if (na & (FFESYMBOL_attrsANYLEN
6458                      | FFESYMBOL_attrsADJUSTABLE
6459                      | FFESYMBOL_attrsANYSIZE))
6460         na = FFESYMBOL_attrsetNONE;
6461       else
6462         na |= FFESYMBOL_attrsINIT;
6463     }
6464
6465   /* Now figure out what kind of object we've got based on previous
6466      declarations of or references to the object. */
6467
6468   if (na == FFESYMBOL_attrsetNONE)
6469     ;
6470   else if (!ffesymbol_is_specable (s)
6471            && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
6472                 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
6473                || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
6474     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
6475                                    dimension/init UNDERSTOODs. */
6476   else if (sa & FFESYMBOL_attrsANY)
6477     na = sa;
6478   else if ((sa & na)
6479            || ((sa & (FFESYMBOL_attrsSFARG
6480                       | FFESYMBOL_attrsADJUSTS))
6481                && (na & (FFESYMBOL_attrsARRAY
6482                          | FFESYMBOL_attrsANYLEN)))
6483            || ((sa & FFESYMBOL_attrsRESULT)
6484                && (na & (FFESYMBOL_attrsARRAY
6485                          | FFESYMBOL_attrsINIT)))
6486            || ((sa & (FFESYMBOL_attrsSFUNC
6487                       | FFESYMBOL_attrsEXTERNAL
6488                       | FFESYMBOL_attrsINTRINSIC
6489                       | FFESYMBOL_attrsINIT))
6490                && (na & (FFESYMBOL_attrsARRAY
6491                          | FFESYMBOL_attrsANYLEN
6492                          | FFESYMBOL_attrsINIT)))
6493            || ((sa & FFESYMBOL_attrsARRAY)
6494                && !ffesta_is_entry_valid
6495                && (na & FFESYMBOL_attrsANYLEN))
6496            || ((sa & (FFESYMBOL_attrsADJUSTABLE
6497                       | FFESYMBOL_attrsANYLEN
6498                       | FFESYMBOL_attrsANYSIZE
6499                       | FFESYMBOL_attrsDUMMY))
6500                && (na & FFESYMBOL_attrsINIT))
6501            || ((sa & (FFESYMBOL_attrsSAVE
6502                       | FFESYMBOL_attrsNAMELIST
6503                       | FFESYMBOL_attrsCOMMON
6504                       | FFESYMBOL_attrsEQUIV))
6505                && (na & (FFESYMBOL_attrsADJUSTABLE
6506                          | FFESYMBOL_attrsANYLEN
6507                          | FFESYMBOL_attrsANYSIZE))))
6508     na = FFESYMBOL_attrsetNONE;
6509   else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
6510            && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
6511            && (na & FFESYMBOL_attrsANYLEN))
6512     {                           /* If CHARACTER*(*) FOO after PARAMETER FOO. */
6513       na |= FFESYMBOL_attrsTYPE;
6514       ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
6515     }
6516   else
6517     na |= sa;
6518
6519   /* Now see what we've got for a new object: NONE means a new error cropped
6520      up; ANY means an old error to be ignored; otherwise, everything's ok,
6521      update the object (symbol) and continue on. */
6522
6523   if (na == FFESYMBOL_attrsetNONE)
6524     {
6525       ffesymbol_error (s, name);
6526       ffestc_parent_ok_ = FALSE;
6527     }
6528   else if (na & FFESYMBOL_attrsANY)
6529     ffestc_parent_ok_ = FALSE;
6530   else
6531     {
6532       ffesymbol_set_attrs (s, na);
6533       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
6534         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
6535       rank = ffesymbol_rank (s);
6536       if (dims != NULL)
6537         {
6538           ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
6539                                                          &array_size,
6540                                                          &extents,
6541                                                          is_ugly_assumed));
6542           ffesymbol_set_arraysize (s, array_size);
6543           ffesymbol_set_extents (s, extents);
6544           if (!(0 && ffe_is_90 ())
6545               && (ffebld_op (array_size) == FFEBLD_opCONTER)
6546               && (ffebld_constant_integerdefault (ffebld_conter (array_size))
6547                   == 0))
6548             {
6549               ffebad_start (FFEBAD_ZERO_ARRAY);
6550               ffebad_here (0, ffelex_token_where_line (name),
6551                            ffelex_token_where_column (name));
6552               ffebad_finish ();
6553             }
6554         }
6555       if (init != NULL)
6556         {
6557           ffesymbol_set_init (s,
6558                               ffeexpr_convert (init, initt, name,
6559                                                ffestc_local_.decl.basic_type,
6560                                                ffestc_local_.decl.kind_type,
6561                                                rank,
6562                                                ffestc_local_.decl.size,
6563                                                FFEEXPR_contextDATA));
6564           ffecom_notify_init_symbol (s);
6565           ffesymbol_update_init (s);
6566 #if FFEGLOBAL_ENABLED
6567           if (ffesymbol_common (s) != NULL)
6568             ffeglobal_init_common (ffesymbol_common (s), initt);
6569 #endif
6570         }
6571       else if (clist)
6572         {
6573           ffebld symter;
6574
6575           symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
6576                                       FFEINTRIN_specNONE,
6577                                       FFEINTRIN_impNONE);
6578
6579           ffebld_set_info (symter,
6580                            ffeinfo_new (ffestc_local_.decl.basic_type,
6581                                         ffestc_local_.decl.kind_type,
6582                                         rank,
6583                                         FFEINFO_kindNONE,
6584                                         FFEINFO_whereNONE,
6585                                         ffestc_local_.decl.size));
6586           ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
6587         }
6588       if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
6589         {
6590           ffesymbol_set_info (s,
6591                               ffeinfo_new (ffestc_local_.decl.basic_type,
6592                                            ffestc_local_.decl.kind_type,
6593                                            rank,
6594                                            ffesymbol_kind (s),
6595                                            ffesymbol_where (s),
6596                                            ffestc_local_.decl.size));
6597           if ((na & FFESYMBOL_attrsRESULT)
6598               && ((sfn = ffesymbol_funcresult (s)) != NULL))
6599             {
6600               ffesymbol_set_info (sfn,
6601                                   ffeinfo_new (ffestc_local_.decl.basic_type,
6602                                                ffestc_local_.decl.kind_type,
6603                                                rank,
6604                                                ffesymbol_kind (sfn),
6605                                                ffesymbol_where (sfn),
6606                                                ffestc_local_.decl.size));
6607               ffesymbol_signal_unreported (sfn);
6608             }
6609         }
6610       else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
6611                || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
6612                || ((ffestc_local_.decl.basic_type
6613                     == FFEINFO_basictypeCHARACTER)
6614                    && (ffestc_local_.decl.size != ffesymbol_size (s))))
6615         {                       /* Explicit type disagrees with established
6616                                    implicit type. */
6617           ffesymbol_error (s, name);
6618         }
6619
6620       if ((na & FFESYMBOL_attrsADJUSTS)
6621           && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
6622               || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
6623         ffesymbol_error (s, name);
6624
6625       ffesymbol_signal_unreported (s);
6626       ffestc_parent_ok_ = TRUE;
6627     }
6628 }
6629
6630 /* ffestc_R501_itemstartvals -- Start list of values
6631
6632    ffestc_R501_itemstartvals();
6633
6634    Gonna specify values for the object now.  */
6635
6636 void
6637 ffestc_R501_itemstartvals ()
6638 {
6639   ffestc_check_item_startvals_ ();
6640
6641   if (ffestc_parent_ok_)
6642     ffedata_begin (ffestc_local_.decl.initlist);
6643 }
6644
6645 /* ffestc_R501_itemvalue -- Source value
6646
6647    ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
6648
6649    Make sure repeat and value are valid for the object being initialized.  */
6650
6651 void
6652 ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
6653                        ffebld value, ffelexToken value_token)
6654 {
6655   ffetargetIntegerDefault rpt;
6656
6657   ffestc_check_item_value_ ();
6658
6659   if (!ffestc_parent_ok_)
6660     return;
6661
6662   if (repeat == NULL)
6663     rpt = 1;
6664   else if (ffebld_op (repeat) == FFEBLD_opCONTER)
6665     rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
6666   else
6667     {
6668       ffestc_parent_ok_ = FALSE;
6669       ffedata_end (TRUE, NULL);
6670       return;
6671     }
6672
6673   if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
6674                       (repeat_token == NULL) ? value_token : repeat_token)))
6675     ffedata_end (TRUE, NULL);
6676 }
6677
6678 /* ffestc_R501_itemendvals -- End list of values
6679
6680    ffelexToken t;  // the SLASH token that ends the list.
6681    ffestc_R501_itemendvals(t);
6682
6683    No more values, might specify more objects now.  */
6684
6685 void
6686 ffestc_R501_itemendvals (ffelexToken t)
6687 {
6688   ffestc_check_item_endvals_ ();
6689
6690   if (ffestc_parent_ok_)
6691     ffestc_parent_ok_ = ffedata_end (FALSE, t);
6692
6693   if (ffestc_parent_ok_)
6694     ffesymbol_signal_unreported (ffebld_symter (ffebld_head
6695                                              (ffestc_local_.decl.initlist)));
6696 }
6697
6698 /* ffestc_R501_finish -- Done
6699
6700    ffestc_R501_finish();
6701
6702    Just wrap up any local activities.  */
6703
6704 void
6705 ffestc_R501_finish ()
6706 {
6707   ffestc_check_finish_ ();
6708 }
6709
6710 /* ffestc_R519_start -- INTENT statement list begin
6711
6712    ffestc_R519_start();
6713
6714    Verify that INTENT is valid here, and begin accepting items in the list.  */
6715
6716 #if FFESTR_F90
6717 void
6718 ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw)
6719 {
6720   ffestc_check_start_ ();
6721   if (ffestc_order_spec_ () != FFESTC_orderOK_)
6722     {
6723       ffestc_ok_ = FALSE;
6724       return;
6725     }
6726   ffestc_labeldef_useless_ ();
6727
6728   ffestd_R519_start (intent_kw);
6729
6730   ffestc_ok_ = TRUE;
6731 }
6732
6733 /* ffestc_R519_item -- INTENT statement for name
6734
6735    ffestc_R519_item(name_token);
6736
6737    Make sure name_token identifies a valid object to be INTENTed.  */
6738
6739 void
6740 ffestc_R519_item (ffelexToken name)
6741 {
6742   ffestc_check_item_ ();
6743   assert (name != NULL);
6744   if (!ffestc_ok_)
6745     return;
6746
6747   ffestd_R519_item (name);
6748 }
6749
6750 /* ffestc_R519_finish -- INTENT statement list complete
6751
6752    ffestc_R519_finish();
6753
6754    Just wrap up any local activities.  */
6755
6756 void
6757 ffestc_R519_finish ()
6758 {
6759   ffestc_check_finish_ ();
6760   if (!ffestc_ok_)
6761     return;
6762
6763   ffestd_R519_finish ();
6764 }
6765
6766 /* ffestc_R520_start -- OPTIONAL statement list begin
6767
6768    ffestc_R520_start();
6769
6770    Verify that OPTIONAL is valid here, and begin accepting items in the list.  */
6771
6772 void
6773 ffestc_R520_start ()
6774 {
6775   ffestc_check_start_ ();
6776   if (ffestc_order_spec_ () != FFESTC_orderOK_)
6777     {
6778       ffestc_ok_ = FALSE;
6779       return;
6780     }
6781   ffestc_labeldef_useless_ ();
6782
6783   ffestd_R520_start ();
6784
6785   ffestc_ok_ = TRUE;
6786 }
6787
6788 /* ffestc_R520_item -- OPTIONAL statement for name
6789
6790    ffestc_R520_item(name_token);
6791
6792    Make sure name_token identifies a valid object to be OPTIONALed.  */
6793
6794 void
6795 ffestc_R520_item (ffelexToken name)
6796 {
6797   ffestc_check_item_ ();
6798   assert (name != NULL);
6799   if (!ffestc_ok_)
6800     return;
6801
6802   ffestd_R520_item (name);
6803 }
6804
6805 /* ffestc_R520_finish -- OPTIONAL statement list complete
6806
6807    ffestc_R520_finish();
6808
6809    Just wrap up any local activities.  */
6810
6811 void
6812 ffestc_R520_finish ()
6813 {
6814   ffestc_check_finish_ ();
6815   if (!ffestc_ok_)
6816     return;
6817
6818   ffestd_R520_finish ();
6819 }
6820
6821 /* ffestc_R521A -- PUBLIC statement
6822
6823    ffestc_R521A();
6824
6825    Verify that PUBLIC is valid here.  */
6826
6827 void
6828 ffestc_R521A ()
6829 {
6830   ffestc_check_simple_ ();
6831   if (ffestc_order_access_ () != FFESTC_orderOK_)
6832     return;
6833   ffestc_labeldef_useless_ ();
6834
6835   switch (ffestv_access_state_)
6836     {
6837     case FFESTV_accessstateNONE:
6838       ffestv_access_state_ = FFESTV_accessstatePUBLIC;
6839       ffestv_access_line_
6840         = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
6841       ffestv_access_col_
6842         = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
6843       break;
6844
6845     case FFESTV_accessstateANY:
6846       break;
6847
6848     case FFESTV_accessstatePUBLIC:
6849     case FFESTV_accessstatePRIVATE:
6850       ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
6851       ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
6852       ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
6853                    ffelex_token_where_column (ffesta_tokens[0]));
6854       ffebad_finish ();
6855       ffestv_access_state_ = FFESTV_accessstateANY;
6856       break;
6857
6858     default:
6859       assert ("unexpected access state" == NULL);
6860       break;
6861     }
6862
6863   ffestd_R521A ();
6864 }
6865
6866 /* ffestc_R521Astart -- PUBLIC statement list begin
6867
6868    ffestc_R521Astart();
6869
6870    Verify that PUBLIC is valid here, and begin accepting items in the list.  */
6871
6872 void
6873 ffestc_R521Astart ()
6874 {
6875   ffestc_check_start_ ();
6876   if (ffestc_order_access_ () != FFESTC_orderOK_)
6877     {
6878       ffestc_ok_ = FALSE;
6879       return;
6880     }
6881   ffestc_labeldef_useless_ ();
6882
6883   ffestd_R521Astart ();
6884
6885   ffestc_ok_ = TRUE;
6886 }
6887
6888 /* ffestc_R521Aitem -- PUBLIC statement for name
6889
6890    ffestc_R521Aitem(name_token);
6891
6892    Make sure name_token identifies a valid object to be PUBLICed.  */
6893
6894 void
6895 ffestc_R521Aitem (ffelexToken name)
6896 {
6897   ffestc_check_item_ ();
6898   assert (name != NULL);
6899   if (!ffestc_ok_)
6900     return;
6901
6902   ffestd_R521Aitem (name);
6903 }
6904
6905 /* ffestc_R521Afinish -- PUBLIC statement list complete
6906
6907    ffestc_R521Afinish();
6908
6909    Just wrap up any local activities.  */
6910
6911 void
6912 ffestc_R521Afinish ()
6913 {
6914   ffestc_check_finish_ ();
6915   if (!ffestc_ok_)
6916     return;
6917
6918   ffestd_R521Afinish ();
6919 }
6920
6921 /* ffestc_R521B -- PRIVATE statement
6922
6923    ffestc_R521B();
6924
6925    Verify that PRIVATE is valid here (outside a derived-type statement).  */
6926
6927 void
6928 ffestc_R521B ()
6929 {
6930   ffestc_check_simple_ ();
6931   if (ffestc_order_access_ () != FFESTC_orderOK_)
6932     return;
6933   ffestc_labeldef_useless_ ();
6934
6935   switch (ffestv_access_state_)
6936     {
6937     case FFESTV_accessstateNONE:
6938       ffestv_access_state_ = FFESTV_accessstatePRIVATE;
6939       ffestv_access_line_
6940         = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
6941       ffestv_access_col_
6942         = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
6943       break;
6944
6945     case FFESTV_accessstateANY:
6946       break;
6947
6948     case FFESTV_accessstatePUBLIC:
6949     case FFESTV_accessstatePRIVATE:
6950       ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
6951       ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
6952       ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
6953                    ffelex_token_where_column (ffesta_tokens[0]));
6954       ffebad_finish ();
6955       ffestv_access_state_ = FFESTV_accessstateANY;
6956       break;
6957
6958     default:
6959       assert ("unexpected access state" == NULL);
6960       break;
6961     }
6962
6963   ffestd_R521B ();
6964 }
6965
6966 /* ffestc_R521Bstart -- PRIVATE statement list begin
6967
6968    ffestc_R521Bstart();
6969
6970    Verify that PRIVATE is valid here, and begin accepting items in the list.  */
6971
6972 void
6973 ffestc_R521Bstart ()
6974 {
6975   ffestc_check_start_ ();
6976   if (ffestc_order_access_ () != FFESTC_orderOK_)
6977     {
6978       ffestc_ok_ = FALSE;
6979       return;
6980     }
6981   ffestc_labeldef_useless_ ();
6982
6983   ffestd_R521Bstart ();
6984
6985   ffestc_ok_ = TRUE;
6986 }
6987
6988 /* ffestc_R521Bitem -- PRIVATE statement for name
6989
6990    ffestc_R521Bitem(name_token);
6991
6992    Make sure name_token identifies a valid object to be PRIVATEed.  */
6993
6994 void
6995 ffestc_R521Bitem (ffelexToken name)
6996 {
6997   ffestc_check_item_ ();
6998   assert (name != NULL);
6999   if (!ffestc_ok_)
7000     return;
7001
7002   ffestd_R521Bitem (name);
7003 }
7004
7005 /* ffestc_R521Bfinish -- PRIVATE statement list complete
7006
7007    ffestc_R521Bfinish();
7008
7009    Just wrap up any local activities.  */
7010
7011 void
7012 ffestc_R521Bfinish ()
7013 {
7014   ffestc_check_finish_ ();
7015   if (!ffestc_ok_)
7016     return;
7017
7018   ffestd_R521Bfinish ();
7019 }
7020
7021 #endif
7022 /* ffestc_R522 -- SAVE statement with no list
7023
7024    ffestc_R522();
7025
7026    Verify that SAVE is valid here, and flag everything as SAVEd.  */
7027
7028 void
7029 ffestc_R522 ()
7030 {
7031   ffestc_check_simple_ ();
7032   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7033     return;
7034   ffestc_labeldef_useless_ ();
7035
7036   switch (ffestv_save_state_)
7037     {
7038     case FFESTV_savestateNONE:
7039       ffestv_save_state_ = FFESTV_savestateALL;
7040       ffestv_save_line_
7041         = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
7042       ffestv_save_col_
7043         = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
7044       break;
7045
7046     case FFESTV_savestateANY:
7047       break;
7048
7049     case FFESTV_savestateSPECIFIC:
7050     case FFESTV_savestateALL:
7051       if (ffe_is_pedantic ())
7052         {
7053           ffebad_start (FFEBAD_CONFLICTING_SAVES);
7054           ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
7055           ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
7056                        ffelex_token_where_column (ffesta_tokens[0]));
7057           ffebad_finish ();
7058         }
7059       ffestv_save_state_ = FFESTV_savestateALL;
7060       break;
7061
7062     default:
7063       assert ("unexpected save state" == NULL);
7064       break;
7065     }
7066
7067   ffe_set_is_saveall (TRUE);
7068
7069   ffestd_R522 ();
7070 }
7071
7072 /* ffestc_R522start -- SAVE statement list begin
7073
7074    ffestc_R522start();
7075
7076    Verify that SAVE is valid here, and begin accepting items in the list.  */
7077
7078 void
7079 ffestc_R522start ()
7080 {
7081   ffestc_check_start_ ();
7082   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7083     {
7084       ffestc_ok_ = FALSE;
7085       return;
7086     }
7087   ffestc_labeldef_useless_ ();
7088
7089   switch (ffestv_save_state_)
7090     {
7091     case FFESTV_savestateNONE:
7092       ffestv_save_state_ = FFESTV_savestateSPECIFIC;
7093       ffestv_save_line_
7094         = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
7095       ffestv_save_col_
7096         = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
7097       break;
7098
7099     case FFESTV_savestateSPECIFIC:
7100     case FFESTV_savestateANY:
7101       break;
7102
7103     case FFESTV_savestateALL:
7104       if (ffe_is_pedantic ())
7105         {
7106           ffebad_start (FFEBAD_CONFLICTING_SAVES);
7107           ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
7108           ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
7109                        ffelex_token_where_column (ffesta_tokens[0]));
7110           ffebad_finish ();
7111         }
7112       ffestv_save_state_ = FFESTV_savestateANY;
7113       break;
7114
7115     default:
7116       assert ("unexpected save state" == NULL);
7117       break;
7118     }
7119
7120   ffestd_R522start ();
7121
7122   ffestc_ok_ = TRUE;
7123 }
7124
7125 /* ffestc_R522item_object -- SAVE statement for object-name
7126
7127    ffestc_R522item_object(name_token);
7128
7129    Make sure name_token identifies a valid object to be SAVEd.  */
7130
7131 void
7132 ffestc_R522item_object (ffelexToken name)
7133 {
7134   ffesymbol s;
7135   ffesymbolAttrs sa;
7136   ffesymbolAttrs na;
7137
7138   ffestc_check_item_ ();
7139   assert (name != NULL);
7140   if (!ffestc_ok_)
7141     return;
7142
7143   s = ffesymbol_declare_local (name, FALSE);
7144   sa = ffesymbol_attrs (s);
7145
7146   /* Figure out what kind of object we've got based on previous declarations
7147      of or references to the object. */
7148
7149   if (!ffesymbol_is_specable (s)
7150       && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
7151           || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
7152     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
7153   else if (sa & FFESYMBOL_attrsANY)
7154     na = sa;
7155   else if (!(sa & ~(FFESYMBOL_attrsARRAY
7156                     | FFESYMBOL_attrsEQUIV
7157                     | FFESYMBOL_attrsINIT
7158                     | FFESYMBOL_attrsNAMELIST
7159                     | FFESYMBOL_attrsSFARG
7160                     | FFESYMBOL_attrsTYPE)))
7161     na = sa | FFESYMBOL_attrsSAVE;
7162   else
7163     na = FFESYMBOL_attrsetNONE;
7164
7165   /* Now see what we've got for a new object: NONE means a new error cropped
7166      up; ANY means an old error to be ignored; otherwise, everything's ok,
7167      update the object (symbol) and continue on. */
7168
7169   if (na == FFESYMBOL_attrsetNONE)
7170     ffesymbol_error (s, name);
7171   else if (!(na & FFESYMBOL_attrsANY))
7172     {
7173       ffesymbol_set_attrs (s, na);
7174       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
7175         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7176       ffesymbol_update_save (s);
7177       ffesymbol_signal_unreported (s);
7178     }
7179
7180   ffestd_R522item_object (name);
7181 }
7182
7183 /* ffestc_R522item_cblock -- SAVE statement for common-block-name
7184
7185    ffestc_R522item_cblock(name_token);
7186
7187    Make sure name_token identifies a valid common block to be SAVEd.  */
7188
7189 void
7190 ffestc_R522item_cblock (ffelexToken name)
7191 {
7192   ffesymbol s;
7193   ffesymbolAttrs sa;
7194   ffesymbolAttrs na;
7195
7196   ffestc_check_item_ ();
7197   assert (name != NULL);
7198   if (!ffestc_ok_)
7199     return;
7200
7201   s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
7202                               ffelex_token_where_column (ffesta_tokens[0]));
7203   sa = ffesymbol_attrs (s);
7204
7205   /* Figure out what kind of object we've got based on previous declarations
7206      of or references to the object. */
7207
7208   if (!ffesymbol_is_specable (s))
7209     na = FFESYMBOL_attrsetNONE;
7210   else if (sa & FFESYMBOL_attrsANY)
7211     na = sa;                    /* Already have an error here, say nothing. */
7212   else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
7213     na = sa | FFESYMBOL_attrsSAVECBLOCK;
7214   else
7215     na = FFESYMBOL_attrsetNONE;
7216
7217   /* Now see what we've got for a new object: NONE means a new error cropped
7218      up; ANY means an old error to be ignored; otherwise, everything's ok,
7219      update the object (symbol) and continue on. */
7220
7221   if (na == FFESYMBOL_attrsetNONE)
7222     ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
7223   else if (!(na & FFESYMBOL_attrsANY))
7224     {
7225       ffesymbol_set_attrs (s, na);
7226       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7227       ffesymbol_update_save (s);
7228       ffesymbol_signal_unreported (s);
7229     }
7230
7231   ffestd_R522item_cblock (name);
7232 }
7233
7234 /* ffestc_R522finish -- SAVE statement list complete
7235
7236    ffestc_R522finish();
7237
7238    Just wrap up any local activities.  */
7239
7240 void
7241 ffestc_R522finish ()
7242 {
7243   ffestc_check_finish_ ();
7244   if (!ffestc_ok_)
7245     return;
7246
7247   ffestd_R522finish ();
7248 }
7249
7250 /* ffestc_R524_start -- DIMENSION statement list begin
7251
7252    ffestc_R524_start(bool virtual);
7253
7254    Verify that DIMENSION is valid here, and begin accepting items in the
7255    list.  */
7256
7257 void
7258 ffestc_R524_start (bool virtual)
7259 {
7260   ffestc_check_start_ ();
7261   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
7262     {
7263       ffestc_ok_ = FALSE;
7264       return;
7265     }
7266   ffestc_labeldef_useless_ ();
7267
7268   ffestd_R524_start (virtual);
7269
7270   ffestc_ok_ = TRUE;
7271 }
7272
7273 /* ffestc_R524_item -- DIMENSION statement for object-name
7274
7275    ffestc_R524_item(name_token,dim_list);
7276
7277    Make sure name_token identifies a valid object to be DIMENSIONd.  */
7278
7279 void
7280 ffestc_R524_item (ffelexToken name, ffesttDimList dims)
7281 {
7282   ffesymbol s;
7283   ffebld array_size;
7284   ffebld extents;
7285   ffesymbolAttrs sa;
7286   ffesymbolAttrs na;
7287   ffestpDimtype nd;
7288   ffeinfoRank rank;
7289   bool is_ugly_assumed;
7290
7291   ffestc_check_item_ ();
7292   assert (name != NULL);
7293   assert (dims != NULL);
7294   if (!ffestc_ok_)
7295     return;
7296
7297   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7298
7299   s = ffesymbol_declare_local (name, FALSE);
7300   sa = ffesymbol_attrs (s);
7301
7302   /* First figure out what kind of object this is based solely on the current
7303      object situation (dimension list). */
7304
7305   is_ugly_assumed = (ffe_is_ugly_assumed ()
7306                      && ((sa & FFESYMBOL_attrsDUMMY)
7307                          || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
7308
7309   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
7310   switch (nd)
7311     {
7312     case FFESTP_dimtypeKNOWN:
7313       na = FFESYMBOL_attrsARRAY;
7314       break;
7315
7316     case FFESTP_dimtypeADJUSTABLE:
7317       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
7318       break;
7319
7320     case FFESTP_dimtypeASSUMED:
7321       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
7322       break;
7323
7324     case FFESTP_dimtypeADJUSTABLEASSUMED:
7325       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
7326         | FFESYMBOL_attrsANYSIZE;
7327       break;
7328
7329     default:
7330       assert ("Unexpected dims type" == NULL);
7331       na = FFESYMBOL_attrsetNONE;
7332       break;
7333     }
7334
7335   /* Now figure out what kind of object we've got based on previous
7336      declarations of or references to the object. */
7337
7338   if (!ffesymbol_is_specable (s))
7339     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
7340   else if (sa & FFESYMBOL_attrsANY)
7341     na = FFESYMBOL_attrsANY;
7342   else if (!ffesta_is_entry_valid
7343            && (sa & FFESYMBOL_attrsANYLEN))
7344     na = FFESYMBOL_attrsetNONE;
7345   else if ((sa & FFESYMBOL_attrsARRAY)
7346            || ((sa & (FFESYMBOL_attrsCOMMON
7347                       | FFESYMBOL_attrsEQUIV
7348                       | FFESYMBOL_attrsNAMELIST
7349                       | FFESYMBOL_attrsSAVE))
7350                && (na & (FFESYMBOL_attrsADJUSTABLE
7351                          | FFESYMBOL_attrsANYSIZE))))
7352     na = FFESYMBOL_attrsetNONE;
7353   else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
7354                     | FFESYMBOL_attrsANYLEN
7355                     | FFESYMBOL_attrsANYSIZE
7356                     | FFESYMBOL_attrsCOMMON
7357                     | FFESYMBOL_attrsDUMMY
7358                     | FFESYMBOL_attrsEQUIV
7359                     | FFESYMBOL_attrsNAMELIST
7360                     | FFESYMBOL_attrsSAVE
7361                     | FFESYMBOL_attrsTYPE)))
7362     na |= sa;
7363   else
7364     na = FFESYMBOL_attrsetNONE;
7365
7366   /* Now see what we've got for a new object: NONE means a new error cropped
7367      up; ANY means an old error to be ignored; otherwise, everything's ok,
7368      update the object (symbol) and continue on. */
7369
7370   if (na == FFESYMBOL_attrsetNONE)
7371     ffesymbol_error (s, name);
7372   else if (!(na & FFESYMBOL_attrsANY))
7373     {
7374       ffesymbol_set_attrs (s, na);
7375       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
7376       ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
7377                                                      &array_size,
7378                                                      &extents,
7379                                                      is_ugly_assumed));
7380       ffesymbol_set_arraysize (s, array_size);
7381       ffesymbol_set_extents (s, extents);
7382       if (!(0 && ffe_is_90 ())
7383           && (ffebld_op (array_size) == FFEBLD_opCONTER)
7384           && (ffebld_constant_integerdefault (ffebld_conter (array_size))
7385               == 0))
7386         {
7387           ffebad_start (FFEBAD_ZERO_ARRAY);
7388           ffebad_here (0, ffelex_token_where_line (name),
7389                        ffelex_token_where_column (name));
7390           ffebad_finish ();
7391         }
7392       ffesymbol_set_info (s,
7393                           ffeinfo_new (ffesymbol_basictype (s),
7394                                        ffesymbol_kindtype (s),
7395                                        rank,
7396                                        ffesymbol_kind (s),
7397                                        ffesymbol_where (s),
7398                                        ffesymbol_size (s)));
7399     }
7400
7401   ffesymbol_signal_unreported (s);
7402
7403   ffestd_R524_item (name, dims);
7404 }
7405
7406 /* ffestc_R524_finish -- DIMENSION statement list complete
7407
7408    ffestc_R524_finish();
7409
7410    Just wrap up any local activities.  */
7411
7412 void
7413 ffestc_R524_finish ()
7414 {
7415   ffestc_check_finish_ ();
7416   if (!ffestc_ok_)
7417     return;
7418
7419   ffestd_R524_finish ();
7420 }
7421
7422 /* ffestc_R525_start -- ALLOCATABLE statement list begin
7423
7424    ffestc_R525_start();
7425
7426    Verify that ALLOCATABLE is valid here, and begin accepting items in the
7427    list.  */
7428
7429 #if FFESTR_F90
7430 void
7431 ffestc_R525_start ()
7432 {
7433   ffestc_check_start_ ();
7434   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7435     {
7436       ffestc_ok_ = FALSE;
7437       return;
7438     }
7439   ffestc_labeldef_useless_ ();
7440
7441   ffestd_R525_start ();
7442
7443   ffestc_ok_ = TRUE;
7444 }
7445
7446 /* ffestc_R525_item -- ALLOCATABLE statement for object-name
7447
7448    ffestc_R525_item(name_token,dim_list);
7449
7450    Make sure name_token identifies a valid object to be ALLOCATABLEd.  */
7451
7452 void
7453 ffestc_R525_item (ffelexToken name, ffesttDimList dims)
7454 {
7455   ffestc_check_item_ ();
7456   assert (name != NULL);
7457   if (!ffestc_ok_)
7458     return;
7459
7460   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7461
7462   ffestd_R525_item (name, dims);
7463 }
7464
7465 /* ffestc_R525_finish -- ALLOCATABLE statement list complete
7466
7467    ffestc_R525_finish();
7468
7469    Just wrap up any local activities.  */
7470
7471 void
7472 ffestc_R525_finish ()
7473 {
7474   ffestc_check_finish_ ();
7475   if (!ffestc_ok_)
7476     return;
7477
7478   ffestd_R525_finish ();
7479 }
7480
7481 /* ffestc_R526_start -- POINTER statement list begin
7482
7483    ffestc_R526_start();
7484
7485    Verify that POINTER is valid here, and begin accepting items in the
7486    list.  */
7487
7488 void
7489 ffestc_R526_start ()
7490 {
7491   ffestc_check_start_ ();
7492   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7493     {
7494       ffestc_ok_ = FALSE;
7495       return;
7496     }
7497   ffestc_labeldef_useless_ ();
7498
7499   ffestd_R526_start ();
7500
7501   ffestc_ok_ = TRUE;
7502 }
7503
7504 /* ffestc_R526_item -- POINTER statement for object-name
7505
7506    ffestc_R526_item(name_token,dim_list);
7507
7508    Make sure name_token identifies a valid object to be POINTERd.  */
7509
7510 void
7511 ffestc_R526_item (ffelexToken name, ffesttDimList dims)
7512 {
7513   ffestc_check_item_ ();
7514   assert (name != NULL);
7515   if (!ffestc_ok_)
7516     return;
7517
7518   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7519
7520   ffestd_R526_item (name, dims);
7521 }
7522
7523 /* ffestc_R526_finish -- POINTER statement list complete
7524
7525    ffestc_R526_finish();
7526
7527    Just wrap up any local activities.  */
7528
7529 void
7530 ffestc_R526_finish ()
7531 {
7532   ffestc_check_finish_ ();
7533   if (!ffestc_ok_)
7534     return;
7535
7536   ffestd_R526_finish ();
7537 }
7538
7539 /* ffestc_R527_start -- TARGET statement list begin
7540
7541    ffestc_R527_start();
7542
7543    Verify that TARGET is valid here, and begin accepting items in the
7544    list.  */
7545
7546 void
7547 ffestc_R527_start ()
7548 {
7549   ffestc_check_start_ ();
7550   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7551     {
7552       ffestc_ok_ = FALSE;
7553       return;
7554     }
7555   ffestc_labeldef_useless_ ();
7556
7557   ffestd_R527_start ();
7558
7559   ffestc_ok_ = TRUE;
7560 }
7561
7562 /* ffestc_R527_item -- TARGET statement for object-name
7563
7564    ffestc_R527_item(name_token,dim_list);
7565
7566    Make sure name_token identifies a valid object to be TARGETd.  */
7567
7568 void
7569 ffestc_R527_item (ffelexToken name, ffesttDimList dims)
7570 {
7571   ffestc_check_item_ ();
7572   assert (name != NULL);
7573   if (!ffestc_ok_)
7574     return;
7575
7576   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7577
7578   ffestd_R527_item (name, dims);
7579 }
7580
7581 /* ffestc_R527_finish -- TARGET statement list complete
7582
7583    ffestc_R527_finish();
7584
7585    Just wrap up any local activities.  */
7586
7587 void
7588 ffestc_R527_finish ()
7589 {
7590   ffestc_check_finish_ ();
7591   if (!ffestc_ok_)
7592     return;
7593
7594   ffestd_R527_finish ();
7595 }
7596
7597 #endif
7598 /* ffestc_R528_start -- DATA statement list begin
7599
7600    ffestc_R528_start();
7601
7602    Verify that DATA is valid here, and begin accepting items in the list.  */
7603
7604 void
7605 ffestc_R528_start ()
7606 {
7607   ffestcOrder_ order;
7608
7609   ffestc_check_start_ ();
7610   if (ffe_is_pedantic_not_90 ())
7611     order = ffestc_order_data77_ ();
7612   else
7613     order = ffestc_order_data_ ();
7614   if (order != FFESTC_orderOK_)
7615     {
7616       ffestc_ok_ = FALSE;
7617       return;
7618     }
7619   ffestc_labeldef_useless_ ();
7620
7621   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7622
7623 #if 1
7624   ffestc_local_.data.objlist = NULL;
7625 #else
7626   ffestd_R528_start_ ();
7627 #endif
7628
7629   ffestc_ok_ = TRUE;
7630 }
7631
7632 /* ffestc_R528_item_object -- DATA statement target object
7633
7634    ffestc_R528_item_object(object,object_token);
7635
7636    Make sure object is valid to be DATAd.  */
7637
7638 void
7639 ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
7640 {
7641   ffestc_check_item_ ();
7642   if (!ffestc_ok_)
7643     return;
7644
7645 #if 1
7646   if (ffestc_local_.data.objlist == NULL)
7647     ffebld_init_list (&ffestc_local_.data.objlist,
7648                       &ffestc_local_.data.list_bottom);
7649
7650   ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
7651 #else
7652   ffestd_R528_item_object_ (expr, expr_token);
7653 #endif
7654 }
7655
7656 /* ffestc_R528_item_startvals -- DATA statement start list of values
7657
7658    ffestc_R528_item_startvals();
7659
7660    No more objects, gonna specify values for the list of objects now.  */
7661
7662 void
7663 ffestc_R528_item_startvals ()
7664 {
7665   ffestc_check_item_startvals_ ();
7666   if (!ffestc_ok_)
7667     return;
7668
7669 #if 1
7670   assert (ffestc_local_.data.objlist != NULL);
7671   ffebld_end_list (&ffestc_local_.data.list_bottom);
7672   ffedata_begin (ffestc_local_.data.objlist);
7673 #else
7674   ffestd_R528_item_startvals_ ();
7675 #endif
7676 }
7677
7678 /* ffestc_R528_item_value -- DATA statement source value
7679
7680    ffestc_R528_item_value(repeat,repeat_token,value,value_token);
7681
7682    Make sure repeat and value are valid for the objects being initialized.  */
7683
7684 void
7685 ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
7686                         ffebld value, ffelexToken value_token)
7687 {
7688   ffetargetIntegerDefault rpt;
7689
7690   ffestc_check_item_value_ ();
7691   if (!ffestc_ok_)
7692     return;
7693
7694 #if 1
7695   if (repeat == NULL)
7696     rpt = 1;
7697   else if (ffebld_op (repeat) == FFEBLD_opCONTER)
7698     rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
7699   else
7700     {
7701       ffestc_ok_ = FALSE;
7702       ffedata_end (TRUE, NULL);
7703       return;
7704     }
7705
7706   if (!(ffestc_ok_ = ffedata_value (rpt, value,
7707                                     (repeat_token == NULL)
7708                                     ? value_token
7709                                     : repeat_token)))
7710     ffedata_end (TRUE, NULL);
7711
7712 #else
7713   ffestd_R528_item_value_ (repeat, value);
7714 #endif
7715 }
7716
7717 /* ffestc_R528_item_endvals -- DATA statement start list of values
7718
7719    ffelexToken t;  // the SLASH token that ends the list.
7720    ffestc_R528_item_endvals(t);
7721
7722    No more values, might specify more objects now.  */
7723
7724 void
7725 ffestc_R528_item_endvals (ffelexToken t)
7726 {
7727   ffestc_check_item_endvals_ ();
7728   if (!ffestc_ok_)
7729     return;
7730
7731 #if 1
7732   ffedata_end (!ffestc_ok_, t);
7733   ffestc_local_.data.objlist = NULL;
7734 #else
7735   ffestd_R528_item_endvals_ (t);
7736 #endif
7737 }
7738
7739 /* ffestc_R528_finish -- DATA statement list complete
7740
7741    ffestc_R528_finish();
7742
7743    Just wrap up any local activities.  */
7744
7745 void
7746 ffestc_R528_finish ()
7747 {
7748   ffestc_check_finish_ ();
7749
7750 #if 1
7751 #else
7752   ffestd_R528_finish_ ();
7753 #endif
7754 }
7755
7756 /* ffestc_R537_start -- PARAMETER statement list begin
7757
7758    ffestc_R537_start();
7759
7760    Verify that PARAMETER is valid here, and begin accepting items in the
7761    list.  */
7762
7763 void
7764 ffestc_R537_start ()
7765 {
7766   ffestc_check_start_ ();
7767   if (ffestc_order_parameter_ () != FFESTC_orderOK_)
7768     {
7769       ffestc_ok_ = FALSE;
7770       return;
7771     }
7772   ffestc_labeldef_useless_ ();
7773
7774   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
7775
7776   ffestd_R537_start ();
7777
7778   ffestc_ok_ = TRUE;
7779 }
7780
7781 /* ffestc_R537_item -- PARAMETER statement assignment
7782
7783    ffestc_R537_item(dest,dest_token,source,source_token);
7784
7785    Make sure the source is a valid source for the destination; make the
7786    assignment.  */
7787
7788 void
7789 ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
7790                   ffelexToken source_token)
7791 {
7792   ffesymbol s;
7793
7794   ffestc_check_item_ ();
7795   if (!ffestc_ok_)
7796     return;
7797
7798   if ((ffebld_op (dest) == FFEBLD_opANY)
7799       || (ffebld_op (source) == FFEBLD_opANY))
7800     {
7801       if (ffebld_op (dest) == FFEBLD_opSYMTER)
7802         {
7803           s = ffebld_symter (dest);
7804           ffesymbol_set_init (s, ffebld_new_any ());
7805           ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
7806           ffesymbol_signal_unreported (s);
7807         }
7808       ffestd_R537_item (dest, source);
7809       return;
7810     }
7811
7812   assert (ffebld_op (dest) == FFEBLD_opSYMTER);
7813   assert (ffebld_op (source) == FFEBLD_opCONTER);
7814
7815   s = ffebld_symter (dest);
7816   if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
7817       && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
7818     {                           /* Destination has explicit/implicit
7819                                    CHARACTER*(*) type; set length. */
7820       ffesymbol_set_info (s,
7821                           ffeinfo_new (ffesymbol_basictype (s),
7822                                        ffesymbol_kindtype (s),
7823                                        0,
7824                                        ffesymbol_kind (s),
7825                                        ffesymbol_where (s),
7826                                        ffebld_size (source)));
7827       ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
7828     }
7829
7830   source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
7831                                  FFEEXPR_contextDATA);
7832
7833   ffesymbol_set_init (s, source);
7834
7835   ffesymbol_signal_unreported (s);
7836
7837   ffestd_R537_item (dest, source);
7838 }
7839
7840 /* ffestc_R537_finish -- PARAMETER statement list complete
7841
7842    ffestc_R537_finish();
7843
7844    Just wrap up any local activities.  */
7845
7846 void
7847 ffestc_R537_finish ()
7848 {
7849   ffestc_check_finish_ ();
7850   if (!ffestc_ok_)
7851     return;
7852
7853   ffestd_R537_finish ();
7854 }
7855
7856 /* ffestc_R539 -- IMPLICIT NONE statement
7857
7858    ffestc_R539();
7859
7860    Verify that the IMPLICIT NONE statement is ok here and implement.  */
7861
7862 void
7863 ffestc_R539 ()
7864 {
7865   ffestc_check_simple_ ();
7866   if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
7867     return;
7868   ffestc_labeldef_useless_ ();
7869
7870   ffeimplic_none ();
7871
7872   ffestd_R539 ();
7873 }
7874
7875 /* ffestc_R539start -- IMPLICIT statement
7876
7877    ffestc_R539start();
7878
7879    Verify that the IMPLICIT statement is ok here and implement.  */
7880
7881 void
7882 ffestc_R539start ()
7883 {
7884   ffestc_check_start_ ();
7885   if (ffestc_order_implicit_ () != FFESTC_orderOK_)
7886     {
7887       ffestc_ok_ = FALSE;
7888       return;
7889     }
7890   ffestc_labeldef_useless_ ();
7891
7892   ffestd_R539start ();
7893
7894   ffestc_ok_ = TRUE;
7895 }
7896
7897 /* ffestc_R539item -- IMPLICIT statement specification (R540)
7898
7899    ffestc_R539item(...);
7900
7901    Verify that the type and letter list are all ok and implement.  */
7902
7903 void
7904 ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
7905                  ffebld len, ffelexToken lent, ffesttImpList letters)
7906 {
7907   ffestc_check_item_ ();
7908   if (!ffestc_ok_)
7909     return;
7910
7911   if ((type == FFESTP_typeCHARACTER) && (len != NULL)
7912       && (ffebld_op (len) == FFEBLD_opSTAR))
7913     {                           /* Complain and pretend they're CHARACTER
7914                                    [*1]. */
7915       ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
7916       ffebad_here (0, ffelex_token_where_line (lent),
7917                    ffelex_token_where_column (lent));
7918       ffebad_finish ();
7919       len = NULL;
7920       lent = NULL;
7921     }
7922   ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
7923   ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
7924
7925   ffestt_implist_drive (letters, ffestc_establish_impletter_);
7926
7927   ffestd_R539item (type, kind, kindt, len, lent, letters);
7928 }
7929
7930 /* ffestc_R539finish -- IMPLICIT statement
7931
7932    ffestc_R539finish();
7933
7934    Finish up any local activities.  */
7935
7936 void
7937 ffestc_R539finish ()
7938 {
7939   ffestc_check_finish_ ();
7940   if (!ffestc_ok_)
7941     return;
7942
7943   ffestd_R539finish ();
7944 }
7945
7946 /* ffestc_R542_start -- NAMELIST statement list begin
7947
7948    ffestc_R542_start();
7949
7950    Verify that NAMELIST is valid here, and begin accepting items in the
7951    list.  */
7952
7953 void
7954 ffestc_R542_start ()
7955 {
7956   ffestc_check_start_ ();
7957   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
7958     {
7959       ffestc_ok_ = FALSE;
7960       return;
7961     }
7962   ffestc_labeldef_useless_ ();
7963
7964   if (ffe_is_f2c_library ()
7965       && (ffe_case_source () == FFE_caseNONE))
7966     {
7967       ffebad_start (FFEBAD_NAMELIST_CASE);
7968       ffesta_ffebad_here_current_stmt (0);
7969       ffebad_finish ();
7970     }
7971
7972   ffestd_R542_start ();
7973
7974   ffestc_local_.namelist.symbol = NULL;
7975
7976   ffestc_ok_ = TRUE;
7977 }
7978
7979 /* ffestc_R542_item_nlist -- NAMELIST statement for group-name
7980
7981    ffestc_R542_item_nlist(groupname_token);
7982
7983    Make sure name_token identifies a valid object to be NAMELISTd.  */
7984
7985 void
7986 ffestc_R542_item_nlist (ffelexToken name)
7987 {
7988   ffesymbol s;
7989
7990   ffestc_check_item_ ();
7991   assert (name != NULL);
7992   if (!ffestc_ok_)
7993     return;
7994
7995   if (ffestc_local_.namelist.symbol != NULL)
7996     ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
7997
7998   s = ffesymbol_declare_local (name, FALSE);
7999
8000   if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
8001       || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
8002           && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
8003     {
8004       ffestc_parent_ok_ = TRUE;
8005       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8006         {
8007           ffebld_init_list (ffesymbol_ptr_to_namelist (s),
8008                             ffesymbol_ptr_to_listbottom (s));
8009           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8010           ffesymbol_set_info (s,
8011                               ffeinfo_new (FFEINFO_basictypeNONE,
8012                                            FFEINFO_kindtypeNONE,
8013                                            0,
8014                                            FFEINFO_kindNAMELIST,
8015                                            FFEINFO_whereLOCAL,
8016                                            FFETARGET_charactersizeNONE));
8017         }
8018     }
8019   else
8020     {
8021       if (ffesymbol_kind (s) != FFEINFO_kindANY)
8022         ffesymbol_error (s, name);
8023       ffestc_parent_ok_ = FALSE;
8024     }
8025
8026   ffestc_local_.namelist.symbol = s;
8027
8028   ffestd_R542_item_nlist (name);
8029 }
8030
8031 /* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
8032
8033    ffestc_R542_item_nitem(name_token);
8034
8035    Make sure name_token identifies a valid object to be NAMELISTd.  */
8036
8037 void
8038 ffestc_R542_item_nitem (ffelexToken name)
8039 {
8040   ffesymbol s;
8041   ffesymbolAttrs sa;
8042   ffesymbolAttrs na;
8043   ffebld e;
8044
8045   ffestc_check_item_ ();
8046   assert (name != NULL);
8047   if (!ffestc_ok_)
8048     return;
8049
8050   s = ffesymbol_declare_local (name, FALSE);
8051   sa = ffesymbol_attrs (s);
8052
8053   /* Figure out what kind of object we've got based on previous declarations
8054      of or references to the object. */
8055
8056   if (!ffesymbol_is_specable (s)
8057       && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
8058           || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
8059               && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
8060     na = FFESYMBOL_attrsetNONE;
8061   else if (sa & FFESYMBOL_attrsANY)
8062     na = FFESYMBOL_attrsANY;
8063   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
8064                     | FFESYMBOL_attrsARRAY
8065                     | FFESYMBOL_attrsCOMMON
8066                     | FFESYMBOL_attrsEQUIV
8067                     | FFESYMBOL_attrsINIT
8068                     | FFESYMBOL_attrsNAMELIST
8069                     | FFESYMBOL_attrsSAVE
8070                     | FFESYMBOL_attrsSFARG
8071                     | FFESYMBOL_attrsTYPE)))
8072     na = sa | FFESYMBOL_attrsNAMELIST;
8073   else
8074     na = FFESYMBOL_attrsetNONE;
8075
8076   /* Now see what we've got for a new object: NONE means a new error cropped
8077      up; ANY means an old error to be ignored; otherwise, everything's ok,
8078      update the object (symbol) and continue on. */
8079
8080   if (na == FFESYMBOL_attrsetNONE)
8081     ffesymbol_error (s, name);
8082   else if (!(na & FFESYMBOL_attrsANY))
8083     {
8084       ffesymbol_set_attrs (s, na);
8085       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8086         ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8087       ffesymbol_set_namelisted (s, TRUE);
8088       ffesymbol_signal_unreported (s);
8089 #if 0                           /* No need to establish type yet! */
8090       if (!ffeimplic_establish_symbol (s))
8091         ffesymbol_error (s, name);
8092 #endif
8093     }
8094
8095   if (ffestc_parent_ok_)
8096     {
8097       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8098                              FFEINTRIN_impNONE);
8099       ffebld_set_info (e,
8100                        ffeinfo_new (FFEINFO_basictypeNONE,
8101                                     FFEINFO_kindtypeNONE, 0,
8102                                     FFEINFO_kindNONE,
8103                                     FFEINFO_whereNONE,
8104                                     FFETARGET_charactersizeNONE));
8105       ffebld_append_item
8106         (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
8107     }
8108
8109   ffestd_R542_item_nitem (name);
8110 }
8111
8112 /* ffestc_R542_finish -- NAMELIST statement list complete
8113
8114    ffestc_R542_finish();
8115
8116    Just wrap up any local activities.  */
8117
8118 void
8119 ffestc_R542_finish ()
8120 {
8121   ffestc_check_finish_ ();
8122   if (!ffestc_ok_)
8123     return;
8124
8125   ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
8126
8127   ffestd_R542_finish ();
8128 }
8129
8130 /* ffestc_R544_start -- EQUIVALENCE statement list begin
8131
8132    ffestc_R544_start();
8133
8134    Verify that EQUIVALENCE is valid here, and begin accepting items in the
8135    list.  */
8136
8137 void
8138 ffestc_R544_start ()
8139 {
8140   ffestc_check_start_ ();
8141   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
8142     {
8143       ffestc_ok_ = FALSE;
8144       return;
8145     }
8146   ffestc_labeldef_useless_ ();
8147
8148   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
8149
8150   ffestc_ok_ = TRUE;
8151 }
8152
8153 /* ffestc_R544_item -- EQUIVALENCE statement assignment
8154
8155    ffestc_R544_item(exprlist);
8156
8157    Make sure the equivalence is valid, then implement it.  */
8158
8159 void
8160 ffestc_R544_item (ffesttExprList exprlist)
8161 {
8162   ffestc_check_item_ ();
8163   if (!ffestc_ok_)
8164     return;
8165
8166   /* First we go through the list and come up with one ffeequiv object that
8167      will describe all items in the list.  When an ffeequiv object is first
8168      found, it is used (else we create one as a "local equiv" for the time
8169      being).  If subsequent ffeequiv objects are found, they are merged with
8170      the first so we end up with one.  However, if more than one COMMON
8171      variable is involved, then an error condition occurs. */
8172
8173   ffestc_local_.equiv.ok = TRUE;
8174   ffestc_local_.equiv.t = NULL; /* No token yet. */
8175   ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
8176   ffestc_local_.equiv.save = FALSE;     /* No SAVEd variables yet. */
8177
8178   ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
8179   ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
8180   ffebld_end_list (&ffestc_local_.equiv.bottom);
8181
8182   if (!ffestc_local_.equiv.ok)
8183     return;                     /* Something went wrong, stop bothering with
8184                                    this stuff. */
8185
8186   if (ffestc_local_.equiv.eq == NULL)
8187     ffestc_local_.equiv.eq = ffeequiv_new ();   /* Make local equivalence. */
8188
8189   /* Append this list of equivalences to list of such lists for this
8190      equivalence. */
8191
8192   ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
8193                 ffestc_local_.equiv.t);
8194   if (ffestc_local_.equiv.save)
8195     ffeequiv_update_save (ffestc_local_.equiv.eq);
8196 }
8197
8198 /* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
8199
8200    ffebld expr;
8201    ffelexToken t;
8202    ffestc_R544_equiv_(expr,t);
8203
8204    Record information, if any, on symbol in expr; if symbol has equivalence
8205    object already, merge with outstanding object if present or make it
8206    the outstanding object.  */
8207
8208 static void
8209 ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
8210 {
8211   ffesymbol s;
8212
8213   if (!ffestc_local_.equiv.ok)
8214     return;
8215
8216   if (ffestc_local_.equiv.t == NULL)
8217     ffestc_local_.equiv.t = t;
8218
8219   switch (ffebld_op (expr))
8220     {
8221     case FFEBLD_opANY:
8222       return;                   /* Don't put this on the list. */
8223
8224     case FFEBLD_opSYMTER:
8225     case FFEBLD_opARRAYREF:
8226     case FFEBLD_opSUBSTR:
8227       break;                    /* All of these are ok. */
8228
8229     default:
8230       assert ("ffestc_R544_equiv_ bad op" == NULL);
8231       return;
8232     }
8233
8234   ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
8235
8236   s = ffeequiv_symbol (expr);
8237
8238   /* See if symbol has an equivalence object already. */
8239
8240   if (ffesymbol_equiv (s) != NULL)
8241     {
8242       if (ffestc_local_.equiv.eq == NULL)
8243         ffestc_local_.equiv.eq = ffesymbol_equiv (s);   /* New equiv obj. */
8244       else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
8245         {
8246           ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
8247                                                    ffestc_local_.equiv.eq,
8248                                                    t);
8249           if (ffestc_local_.equiv.eq == NULL)
8250             ffestc_local_.equiv.ok = FALSE;     /* Couldn't merge. */
8251         }
8252     }
8253
8254   if (ffesymbol_is_save (s))
8255     ffestc_local_.equiv.save = TRUE;
8256 }
8257
8258 /* ffestc_R544_finish -- EQUIVALENCE statement list complete
8259
8260    ffestc_R544_finish();
8261
8262    Just wrap up any local activities.  */
8263
8264 void
8265 ffestc_R544_finish ()
8266 {
8267   ffestc_check_finish_ ();
8268 }
8269
8270 /* ffestc_R547_start -- COMMON statement list begin
8271
8272    ffestc_R547_start();
8273
8274    Verify that COMMON is valid here, and begin accepting items in the list.  */
8275
8276 void
8277 ffestc_R547_start ()
8278 {
8279   ffestc_check_start_ ();
8280   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
8281     {
8282       ffestc_ok_ = FALSE;
8283       return;
8284     }
8285   ffestc_labeldef_useless_ ();
8286
8287   ffestc_local_.common.symbol = NULL;   /* Blank common is the default. */
8288   ffestc_parent_ok_ = TRUE;
8289
8290   ffestd_R547_start ();
8291
8292   ffestc_ok_ = TRUE;
8293 }
8294
8295 /* ffestc_R547_item_object -- COMMON statement for object-name
8296
8297    ffestc_R547_item_object(name_token,dim_list);
8298
8299    Make sure name_token identifies a valid object to be COMMONd.  */
8300
8301 void
8302 ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
8303 {
8304   ffesymbol s;
8305   ffebld array_size;
8306   ffebld extents;
8307   ffesymbolAttrs sa;
8308   ffesymbolAttrs na;
8309   ffestpDimtype nd;
8310   ffebld e;
8311   ffeinfoRank rank;
8312   bool is_ugly_assumed;
8313
8314   if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
8315     ffestc_R547_item_cblock (NULL);     /* As if "COMMON [//] ...". */
8316
8317   ffestc_check_item_ ();
8318   assert (name != NULL);
8319   if (!ffestc_ok_)
8320     return;
8321
8322   if (dims != NULL)
8323     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
8324
8325   s = ffesymbol_declare_local (name, FALSE);
8326   sa = ffesymbol_attrs (s);
8327
8328   /* First figure out what kind of object this is based solely on the current
8329      object situation (dimension list). */
8330
8331   is_ugly_assumed = (ffe_is_ugly_assumed ()
8332                      && ((sa & FFESYMBOL_attrsDUMMY)
8333                          || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
8334
8335   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
8336   switch (nd)
8337     {
8338     case FFESTP_dimtypeNONE:
8339       na = FFESYMBOL_attrsCOMMON;
8340       break;
8341
8342     case FFESTP_dimtypeKNOWN:
8343       na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
8344       break;
8345
8346     default:
8347       na = FFESYMBOL_attrsetNONE;
8348       break;
8349     }
8350
8351   /* Figure out what kind of object we've got based on previous declarations
8352      of or references to the object. */
8353
8354   if (na == FFESYMBOL_attrsetNONE)
8355     ;
8356   else if (!ffesymbol_is_specable (s))
8357     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
8358   else if (sa & FFESYMBOL_attrsANY)
8359     na = FFESYMBOL_attrsANY;
8360   else if ((sa & (FFESYMBOL_attrsADJUSTS
8361                   | FFESYMBOL_attrsARRAY
8362                   | FFESYMBOL_attrsINIT
8363                   | FFESYMBOL_attrsSFARG))
8364            && (na & FFESYMBOL_attrsARRAY))
8365     na = FFESYMBOL_attrsetNONE;
8366   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
8367                     | FFESYMBOL_attrsARRAY
8368                     | FFESYMBOL_attrsEQUIV
8369                     | FFESYMBOL_attrsINIT
8370                     | FFESYMBOL_attrsNAMELIST
8371                     | FFESYMBOL_attrsSFARG
8372                     | FFESYMBOL_attrsTYPE)))
8373     na |= sa;
8374   else
8375     na = FFESYMBOL_attrsetNONE;
8376
8377   /* Now see what we've got for a new object: NONE means a new error cropped
8378      up; ANY means an old error to be ignored; otherwise, everything's ok,
8379      update the object (symbol) and continue on. */
8380
8381   if (na == FFESYMBOL_attrsetNONE)
8382     ffesymbol_error (s, name);
8383   else if ((ffesymbol_equiv (s) != NULL)
8384            && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
8385            && (ffeequiv_common (ffesymbol_equiv (s))
8386                != ffestc_local_.common.symbol))
8387     {
8388       /* Oops, just COMMONed a symbol to a different area (via equiv).  */
8389       ffebad_start (FFEBAD_EQUIV_COMMON);
8390       ffebad_here (0, ffelex_token_where_line (name),
8391                    ffelex_token_where_column (name));
8392       ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
8393       ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
8394       ffebad_finish ();
8395       ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
8396       ffesymbol_set_info (s, ffeinfo_new_any ());
8397       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8398       ffesymbol_signal_unreported (s);
8399     }
8400   else if (!(na & FFESYMBOL_attrsANY))
8401     {
8402       ffesymbol_set_attrs (s, na);
8403       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8404       ffesymbol_set_common (s, ffestc_local_.common.symbol);
8405 #if FFEGLOBAL_ENABLED
8406       if (ffesymbol_is_init (s))
8407         ffeglobal_init_common (ffestc_local_.common.symbol, name);
8408 #endif
8409       if (ffesymbol_is_save (ffestc_local_.common.symbol))
8410         ffesymbol_update_save (s);
8411       if (ffesymbol_equiv (s) != NULL)
8412         {                       /* Is this newly COMMONed symbol involved in
8413                                    an equivalence? */
8414           if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
8415             ffeequiv_set_common (ffesymbol_equiv (s),   /* Yes, tell equiv obj. */
8416                                  ffestc_local_.common.symbol);
8417 #if FFEGLOBAL_ENABLED
8418           if (ffeequiv_is_init (ffesymbol_equiv (s)))
8419             ffeglobal_init_common (ffestc_local_.common.symbol, name);
8420 #endif
8421           if (ffesymbol_is_save (ffestc_local_.common.symbol))
8422             ffeequiv_update_save (ffesymbol_equiv (s));
8423         }
8424       if (dims != NULL)
8425         {
8426           ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
8427                                                          &array_size,
8428                                                          &extents,
8429                                                          is_ugly_assumed));
8430           ffesymbol_set_arraysize (s, array_size);
8431           ffesymbol_set_extents (s, extents);
8432           if (!(0 && ffe_is_90 ())
8433               && (ffebld_op (array_size) == FFEBLD_opCONTER)
8434               && (ffebld_constant_integerdefault (ffebld_conter (array_size))
8435                   == 0))
8436             {
8437               ffebad_start (FFEBAD_ZERO_ARRAY);
8438               ffebad_here (0, ffelex_token_where_line (name),
8439                            ffelex_token_where_column (name));
8440               ffebad_finish ();
8441             }
8442           ffesymbol_set_info (s,
8443                               ffeinfo_new (ffesymbol_basictype (s),
8444                                            ffesymbol_kindtype (s),
8445                                            rank,
8446                                            ffesymbol_kind (s),
8447                                            ffesymbol_where (s),
8448                                            ffesymbol_size (s)));
8449         }
8450       ffesymbol_signal_unreported (s);
8451     }
8452
8453   if (ffestc_parent_ok_)
8454     {
8455       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8456                              FFEINTRIN_impNONE);
8457       ffebld_set_info (e,
8458                        ffeinfo_new (FFEINFO_basictypeNONE,
8459                                     FFEINFO_kindtypeNONE,
8460                                     0,
8461                                     FFEINFO_kindNONE,
8462                                     FFEINFO_whereNONE,
8463                                     FFETARGET_charactersizeNONE));
8464       ffebld_append_item
8465         (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
8466     }
8467
8468   ffestd_R547_item_object (name, dims);
8469 }
8470
8471 /* ffestc_R547_item_cblock -- COMMON statement for common-block-name
8472
8473    ffestc_R547_item_cblock(name_token);
8474
8475    Make sure name_token identifies a valid common block to be COMMONd.  */
8476
8477 void
8478 ffestc_R547_item_cblock (ffelexToken name)
8479 {
8480   ffesymbol s;
8481   ffesymbolAttrs sa;
8482   ffesymbolAttrs na;
8483
8484   ffestc_check_item_ ();
8485   if (!ffestc_ok_)
8486     return;
8487
8488   if (ffestc_local_.common.symbol != NULL)
8489     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8490
8491   s = ffesymbol_declare_cblock (name,
8492                                 ffelex_token_where_line (ffesta_tokens[0]),
8493                               ffelex_token_where_column (ffesta_tokens[0]));
8494   sa = ffesymbol_attrs (s);
8495
8496   /* Figure out what kind of object we've got based on previous declarations
8497      of or references to the object. */
8498
8499   if (!ffesymbol_is_specable (s))
8500     na = FFESYMBOL_attrsetNONE;
8501   else if (sa & FFESYMBOL_attrsANY)
8502     na = FFESYMBOL_attrsANY;    /* Already have an error here, say nothing. */
8503   else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
8504                     | FFESYMBOL_attrsSAVECBLOCK)))
8505     {
8506       if (!(sa & FFESYMBOL_attrsCBLOCK))
8507         ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
8508                           ffesymbol_ptr_to_listbottom (s));
8509       na = sa | FFESYMBOL_attrsCBLOCK;
8510     }
8511   else
8512     na = FFESYMBOL_attrsetNONE;
8513
8514   /* Now see what we've got for a new object: NONE means a new error cropped
8515      up; ANY means an old error to be ignored; otherwise, everything's ok,
8516      update the object (symbol) and continue on. */
8517
8518   if (na == FFESYMBOL_attrsetNONE)
8519     {
8520       ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
8521       ffestc_parent_ok_ = FALSE;
8522     }
8523   else if (na & FFESYMBOL_attrsANY)
8524     ffestc_parent_ok_ = FALSE;
8525   else
8526     {
8527       ffesymbol_set_attrs (s, na);
8528       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8529       if (name == NULL)
8530         ffesymbol_update_save (s);
8531       ffestc_parent_ok_ = TRUE;
8532     }
8533
8534   ffestc_local_.common.symbol = s;
8535
8536   ffestd_R547_item_cblock (name);
8537 }
8538
8539 /* ffestc_R547_finish -- COMMON statement list complete
8540
8541    ffestc_R547_finish();
8542
8543    Just wrap up any local activities.  */
8544
8545 void
8546 ffestc_R547_finish ()
8547 {
8548   ffestc_check_finish_ ();
8549   if (!ffestc_ok_)
8550     return;
8551
8552   if (ffestc_local_.common.symbol != NULL)
8553     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8554
8555   ffestd_R547_finish ();
8556 }
8557
8558 /* ffestc_R620 -- ALLOCATE statement
8559
8560    ffestc_R620(exprlist,stat,stat_token);
8561
8562    Make sure the expression list is valid, then implement it.  */
8563
8564 #if FFESTR_F90
8565 void
8566 ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8567 {
8568   ffestc_check_simple_ ();
8569   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8570     return;
8571   ffestc_labeldef_branch_begin_ ();
8572
8573   ffestd_R620 (exprlist, stat);
8574
8575   if (ffestc_shriek_after1_ != NULL)
8576     (*ffestc_shriek_after1_) (TRUE);
8577   ffestc_labeldef_branch_end_ ();
8578 }
8579
8580 /* ffestc_R624 -- NULLIFY statement
8581
8582    ffestc_R624(pointer_name_list);
8583
8584    Make sure pointer_name_list identifies valid pointers for a NULLIFY.  */
8585
8586 void
8587 ffestc_R624 (ffesttExprList pointers)
8588 {
8589   ffestc_check_simple_ ();
8590   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8591     return;
8592   ffestc_labeldef_branch_begin_ ();
8593
8594   ffestd_R624 (pointers);
8595
8596   if (ffestc_shriek_after1_ != NULL)
8597     (*ffestc_shriek_after1_) (TRUE);
8598   ffestc_labeldef_branch_end_ ();
8599 }
8600
8601 /* ffestc_R625 -- DEALLOCATE statement
8602
8603    ffestc_R625(exprlist,stat,stat_token);
8604
8605    Make sure the equivalence is valid, then implement it.  */
8606
8607 void
8608 ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8609 {
8610   ffestc_check_simple_ ();
8611   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8612     return;
8613   ffestc_labeldef_branch_begin_ ();
8614
8615   ffestd_R625 (exprlist, stat);
8616
8617   if (ffestc_shriek_after1_ != NULL)
8618     (*ffestc_shriek_after1_) (TRUE);
8619   ffestc_labeldef_branch_end_ ();
8620 }
8621
8622 #endif
8623 /* ffestc_let -- R1213 or R737
8624
8625    ffestc_let(...);
8626
8627    Verify that R1213 defined-assignment or R737 assignment-stmt are
8628    valid here, figure out which one, and implement.  */
8629
8630 #if FFESTR_F90
8631 void
8632 ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
8633 {
8634   ffestc_R737 (dest, source, source_token);
8635 }
8636
8637 #endif
8638 /* ffestc_R737 -- Assignment statement
8639
8640    ffestc_R737(dest_expr,source_expr,source_token);
8641
8642    Make sure the assignment is valid.  */
8643
8644 void
8645 ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
8646 {
8647   ffestc_check_simple_ ();
8648
8649   switch (ffestw_state (ffestw_stack_top ()))
8650     {
8651 #if FFESTR_F90
8652     case FFESTV_stateWHERE:
8653     case FFESTV_stateWHERETHEN:
8654       if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8655         return;
8656       ffestc_labeldef_useless_ ();
8657
8658       ffestd_R737B (dest, source);
8659
8660       if (ffestc_shriek_after1_ != NULL)
8661         (*ffestc_shriek_after1_) (TRUE);
8662       return;
8663 #endif
8664
8665     default:
8666       break;
8667     }
8668
8669   if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8670     return;
8671   ffestc_labeldef_branch_begin_ ();
8672
8673   source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
8674                                  FFEEXPR_contextLET);
8675
8676   ffestd_R737A (dest, source);
8677
8678   if (ffestc_shriek_after1_ != NULL)
8679     (*ffestc_shriek_after1_) (TRUE);
8680   ffestc_labeldef_branch_end_ ();
8681 }
8682
8683 /* ffestc_R738 -- Pointer assignment statement
8684
8685    ffestc_R738(dest_expr,source_expr,source_token);
8686
8687    Make sure the assignment is valid.  */
8688
8689 #if FFESTR_F90
8690 void
8691 ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
8692 {
8693   ffestc_check_simple_ ();
8694   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8695     return;
8696   ffestc_labeldef_branch_begin_ ();
8697
8698   ffestd_R738 (dest, source);
8699
8700   if (ffestc_shriek_after1_ != NULL)
8701     (*ffestc_shriek_after1_) (TRUE);
8702   ffestc_labeldef_branch_end_ ();
8703 }
8704
8705 /* ffestc_R740 -- WHERE statement
8706
8707    ffestc_R740(expr,expr_token);
8708
8709    Make sure statement is valid here; implement.  */
8710
8711 void
8712 ffestc_R740 (ffebld expr, ffelexToken expr_token)
8713 {
8714   ffestw b;
8715
8716   ffestc_check_simple_ ();
8717   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8718     return;
8719   ffestc_labeldef_branch_begin_ ();
8720
8721   b = ffestw_update (ffestw_push (NULL));
8722   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8723   ffestw_set_state (b, FFESTV_stateWHERE);
8724   ffestw_set_blocknum (b, ffestc_blocknum_++);
8725   ffestw_set_shriek (b, ffestc_shriek_where_lost_);
8726
8727   ffestd_R740 (expr);
8728
8729   /* Leave label finishing to next statement. */
8730
8731 }
8732
8733 /* ffestc_R742 -- WHERE-construct statement
8734
8735    ffestc_R742(expr,expr_token);
8736
8737    Make sure statement is valid here; implement.  */
8738
8739 void
8740 ffestc_R742 (ffebld expr, ffelexToken expr_token)
8741 {
8742   ffestw b;
8743
8744   ffestc_check_simple_ ();
8745   if (ffestc_order_exec_ () != FFESTC_orderOK_)
8746     return;
8747   ffestc_labeldef_notloop_probably_this_wont_work_ ();
8748
8749   b = ffestw_update (ffestw_push (NULL));
8750   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8751   ffestw_set_state (b, FFESTV_stateWHERETHEN);
8752   ffestw_set_blocknum (b, ffestc_blocknum_++);
8753   ffestw_set_shriek (b, ffestc_shriek_wherethen_);
8754   ffestw_set_substate (b, 0);   /* Haven't seen ELSEWHERE yet. */
8755
8756   ffestd_R742 (expr);
8757 }
8758
8759 /* ffestc_R744 -- ELSE WHERE statement
8760
8761    ffestc_R744();
8762
8763    Make sure ffestc_kind_ identifies a WHERE block.
8764    Implement the ELSE of the current WHERE block.  */
8765
8766 void
8767 ffestc_R744 ()
8768 {
8769   ffestc_check_simple_ ();
8770   if (ffestc_order_where_ () != FFESTC_orderOK_)
8771     return;
8772   ffestc_labeldef_useless_ ();
8773
8774   if (ffestw_substate (ffestw_stack_top ()) != 0)
8775     {
8776       ffebad_start (FFEBAD_SECOND_ELSE_WHERE);
8777       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8778                    ffelex_token_where_column (ffesta_tokens[0]));
8779       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8780       ffebad_finish ();
8781     }
8782
8783   ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */
8784
8785   ffestd_R744 ();
8786 }
8787
8788 /* ffestc_R745 -- END WHERE statement
8789
8790    ffestc_R745();
8791
8792    Make sure ffestc_kind_ identifies a WHERE block.
8793    Implement the end of the current WHERE block.  */
8794
8795 void
8796 ffestc_R745 ()
8797 {
8798   ffestc_check_simple_ ();
8799   if (ffestc_order_where_ () != FFESTC_orderOK_)
8800     return;
8801   ffestc_labeldef_useless_ ();
8802
8803   ffestc_shriek_wherethen_ (TRUE);
8804 }
8805
8806 #endif
8807 /* ffestc_R803 -- Block IF (IF-THEN) statement
8808
8809    ffestc_R803(construct_name,expr,expr_token);
8810
8811    Make sure statement is valid here; implement.  */
8812
8813 void
8814 ffestc_R803 (ffelexToken construct_name, ffebld expr,
8815              ffelexToken expr_token UNUSED)
8816 {
8817   ffestw b;
8818   ffesymbol s;
8819
8820   ffestc_check_simple_ ();
8821   if (ffestc_order_exec_ () != FFESTC_orderOK_)
8822     return;
8823   ffestc_labeldef_notloop_ ();
8824
8825   b = ffestw_update (ffestw_push (NULL));
8826   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8827   ffestw_set_state (b, FFESTV_stateIFTHEN);
8828   ffestw_set_blocknum (b, ffestc_blocknum_++);
8829   ffestw_set_shriek (b, ffestc_shriek_ifthen_);
8830   ffestw_set_substate (b, 0);   /* Haven't seen ELSE yet. */
8831
8832   if (construct_name == NULL)
8833     ffestw_set_name (b, NULL);
8834   else
8835     {
8836       ffestw_set_name (b, ffelex_token_use (construct_name));
8837
8838       s = ffesymbol_declare_local (construct_name, FALSE);
8839
8840       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8841         {
8842           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8843           ffesymbol_set_info (s,
8844                               ffeinfo_new (FFEINFO_basictypeNONE,
8845                                            FFEINFO_kindtypeNONE,
8846                                            0,
8847                                            FFEINFO_kindCONSTRUCT,
8848                                            FFEINFO_whereLOCAL,
8849                                            FFETARGET_charactersizeNONE));
8850           s = ffecom_sym_learned (s);
8851           ffesymbol_signal_unreported (s);
8852         }
8853       else
8854         ffesymbol_error (s, construct_name);
8855     }
8856
8857   ffestd_R803 (construct_name, expr);
8858 }
8859
8860 /* ffestc_R804 -- ELSE IF statement
8861
8862    ffestc_R804(expr,expr_token,name_token);
8863
8864    Make sure ffestc_kind_ identifies an IF block.  If not
8865    NULL, make sure name_token gives the correct name.  Implement the else
8866    of the IF block.  */
8867
8868 void
8869 ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
8870              ffelexToken name)
8871 {
8872   ffestc_check_simple_ ();
8873   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8874     return;
8875   ffestc_labeldef_useless_ ();
8876
8877   if (name != NULL)
8878     {
8879       if (ffestw_name (ffestw_stack_top ()) == NULL)
8880         {
8881           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8882           ffebad_here (0, ffelex_token_where_line (name),
8883                        ffelex_token_where_column (name));
8884           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8885           ffebad_finish ();
8886         }
8887       else if (ffelex_token_strcmp (name,
8888                                     ffestw_name (ffestw_stack_top ()))
8889                != 0)
8890         {
8891           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
8892           ffebad_here (0, ffelex_token_where_line (name),
8893                        ffelex_token_where_column (name));
8894           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
8895              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
8896           ffebad_finish ();
8897         }
8898     }
8899
8900   if (ffestw_substate (ffestw_stack_top ()) != 0)
8901     {
8902       ffebad_start (FFEBAD_AFTER_ELSE);
8903       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8904                    ffelex_token_where_column (ffesta_tokens[0]));
8905       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8906       ffebad_finish ();
8907       return;                   /* Don't upset back end with ELSEIF
8908                                    after ELSE. */
8909     }
8910
8911   ffestd_R804 (expr, name);
8912 }
8913
8914 /* ffestc_R805 -- ELSE statement
8915
8916    ffestc_R805(name_token);
8917
8918    Make sure ffestc_kind_ identifies an IF block.  If not
8919    NULL, make sure name_token gives the correct name.  Implement the ELSE
8920    of the IF block.  */
8921
8922 void
8923 ffestc_R805 (ffelexToken name)
8924 {
8925   ffestc_check_simple_ ();
8926   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8927     return;
8928   ffestc_labeldef_useless_ ();
8929
8930   if (name != NULL)
8931     {
8932       if (ffestw_name (ffestw_stack_top ()) == NULL)
8933         {
8934           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8935           ffebad_here (0, ffelex_token_where_line (name),
8936                        ffelex_token_where_column (name));
8937           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8938           ffebad_finish ();
8939         }
8940       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
8941         {
8942           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
8943           ffebad_here (0, ffelex_token_where_line (name),
8944                        ffelex_token_where_column (name));
8945           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
8946              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
8947           ffebad_finish ();
8948         }
8949     }
8950
8951   if (ffestw_substate (ffestw_stack_top ()) != 0)
8952     {
8953       ffebad_start (FFEBAD_AFTER_ELSE);
8954       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8955                    ffelex_token_where_column (ffesta_tokens[0]));
8956       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8957       ffebad_finish ();
8958       return;                   /* Tell back end about only one ELSE. */
8959     }
8960
8961   ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
8962
8963   ffestd_R805 (name);
8964 }
8965
8966 /* ffestc_R806 -- END IF statement
8967
8968    ffestc_R806(name_token);
8969
8970    Make sure ffestc_kind_ identifies an IF block.  If not
8971    NULL, make sure name_token gives the correct name.  Implement the end
8972    of the IF block.  */
8973
8974 void
8975 ffestc_R806 (ffelexToken name)
8976 {
8977   ffestc_check_simple_ ();
8978   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8979     return;
8980   ffestc_labeldef_endif_ ();
8981
8982   if (name == NULL)
8983     {
8984       if (ffestw_name (ffestw_stack_top ()) != NULL)
8985         {
8986           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
8987           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8988                        ffelex_token_where_column (ffesta_tokens[0]));
8989           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8990           ffebad_finish ();
8991         }
8992     }
8993   else
8994     {
8995       if (ffestw_name (ffestw_stack_top ()) == NULL)
8996         {
8997           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8998           ffebad_here (0, ffelex_token_where_line (name),
8999                        ffelex_token_where_column (name));
9000           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9001           ffebad_finish ();
9002         }
9003       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
9004         {
9005           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9006           ffebad_here (0, ffelex_token_where_line (name),
9007                        ffelex_token_where_column (name));
9008           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9009              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9010           ffebad_finish ();
9011         }
9012     }
9013
9014   ffestc_shriek_ifthen_ (TRUE);
9015 }
9016
9017 /* ffestc_R807 -- Logical IF statement
9018
9019    ffestc_R807(expr,expr_token);
9020
9021    Make sure statement is valid here; implement.  */
9022
9023 void
9024 ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
9025 {
9026   ffestw b;
9027
9028   ffestc_check_simple_ ();
9029   if (ffestc_order_action_ () != FFESTC_orderOK_)
9030     return;
9031   ffestc_labeldef_branch_begin_ ();
9032
9033   b = ffestw_update (ffestw_push (NULL));
9034   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
9035   ffestw_set_state (b, FFESTV_stateIF);
9036   ffestw_set_blocknum (b, ffestc_blocknum_++);
9037   ffestw_set_shriek (b, ffestc_shriek_if_lost_);
9038
9039   ffestd_R807 (expr);
9040
9041   /* Do the label finishing in the next statement. */
9042
9043 }
9044
9045 /* ffestc_R809 -- SELECT CASE statement
9046
9047    ffestc_R809(construct_name,expr,expr_token);
9048
9049    Make sure statement is valid here; implement.  */
9050
9051 void
9052 ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
9053 {
9054   ffestw b;
9055   mallocPool pool;
9056   ffestwSelect s;
9057   ffesymbol sym;
9058
9059   ffestc_check_simple_ ();
9060   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9061     return;
9062   ffestc_labeldef_notloop_ ();
9063
9064   b = ffestw_update (ffestw_push (NULL));
9065   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
9066   ffestw_set_state (b, FFESTV_stateSELECT0);
9067   ffestw_set_blocknum (b, ffestc_blocknum_++);
9068   ffestw_set_shriek (b, ffestc_shriek_select_);
9069   ffestw_set_substate (b, 0);   /* Haven't seen CASE DEFAULT yet. */
9070
9071   /* Init block to manage CASE list. */
9072
9073   pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
9074   s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
9075   s->first_rel = (ffestwCase) &s->first_rel;
9076   s->last_rel = (ffestwCase) &s->first_rel;
9077   s->first_stmt = (ffestwCase) &s->first_rel;
9078   s->last_stmt = (ffestwCase) &s->first_rel;
9079   s->pool = pool;
9080   s->cases = 1;
9081   s->t = ffelex_token_use (expr_token);
9082   s->type = ffeinfo_basictype (ffebld_info (expr));
9083   s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
9084   ffestw_set_select (b, s);
9085
9086   if (construct_name == NULL)
9087     ffestw_set_name (b, NULL);
9088   else
9089     {
9090       ffestw_set_name (b, ffelex_token_use (construct_name));
9091
9092       sym = ffesymbol_declare_local (construct_name, FALSE);
9093
9094       if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
9095         {
9096           ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
9097           ffesymbol_set_info (sym,
9098                               ffeinfo_new (FFEINFO_basictypeNONE,
9099                                            FFEINFO_kindtypeNONE, 0,
9100                                            FFEINFO_kindCONSTRUCT,
9101                                            FFEINFO_whereLOCAL,
9102                                            FFETARGET_charactersizeNONE));
9103           sym = ffecom_sym_learned (sym);
9104           ffesymbol_signal_unreported (sym);
9105         }
9106       else
9107         ffesymbol_error (sym, construct_name);
9108     }
9109
9110   ffestd_R809 (construct_name, expr);
9111 }
9112
9113 /* ffestc_R810 -- CASE statement
9114
9115    ffestc_R810(case_value_range_list,name);
9116
9117    If case_value_range_list is NULL, it's CASE DEFAULT.  name is the case-
9118    construct-name.  Make sure no more than one CASE DEFAULT is present for
9119    a given case-construct and that there aren't any overlapping ranges or
9120    duplicate case values.  */
9121
9122 void
9123 ffestc_R810 (ffesttCaseList cases, ffelexToken name)
9124 {
9125   ffesttCaseList caseobj;
9126   ffestwSelect s;
9127   ffestwCase c, nc;
9128   ffebldConstant expr1c, expr2c;
9129
9130   ffestc_check_simple_ ();
9131   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9132     return;
9133   ffestc_labeldef_useless_ ();
9134
9135   s = ffestw_select (ffestw_stack_top ());
9136
9137   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
9138     {
9139 #if 0                           /* Not sure we want to have msgs point here
9140                                    instead of SELECT CASE. */
9141       ffestw_update (NULL);     /* Update state line/col info. */
9142 #endif
9143       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
9144     }
9145
9146   if (name != NULL)
9147     {
9148       if (ffestw_name (ffestw_stack_top ()) == NULL)
9149         {
9150           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9151           ffebad_here (0, ffelex_token_where_line (name),
9152                        ffelex_token_where_column (name));
9153           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9154           ffebad_finish ();
9155         }
9156       else if (ffelex_token_strcmp (name,
9157                                     ffestw_name (ffestw_stack_top ()))
9158                != 0)
9159         {
9160           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9161           ffebad_here (0, ffelex_token_where_line (name),
9162                        ffelex_token_where_column (name));
9163           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9164              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9165           ffebad_finish ();
9166         }
9167     }
9168
9169   if (cases == NULL)
9170     {
9171       if (ffestw_substate (ffestw_stack_top ()) != 0)
9172         {
9173           ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
9174           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9175                        ffelex_token_where_column (ffesta_tokens[0]));
9176           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9177           ffebad_finish ();
9178         }
9179
9180       ffestw_set_substate (ffestw_stack_top (), 1);     /* Saw ELSE. */
9181     }
9182   else
9183     {                           /* For each case, try to fit into sorted list
9184                                    of ranges. */
9185       for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
9186         {
9187           if ((caseobj->expr1 == NULL)
9188               && (!caseobj->range
9189                   || (caseobj->expr2 == NULL)))
9190             {                   /* "CASE (:)". */
9191               ffebad_start (FFEBAD_CASE_BAD_RANGE);
9192               ffebad_here (0, ffelex_token_where_line (caseobj->t),
9193                            ffelex_token_where_column (caseobj->t));
9194               ffebad_finish ();
9195               continue;
9196             }
9197
9198           if (((caseobj->expr1 != NULL)
9199                && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
9200                     != s->type)
9201                    || (ffeinfo_kindtype (ffebld_info (caseobj->expr1))
9202                        != s->kindtype)))
9203               || ((caseobj->range)
9204                   && (caseobj->expr2 != NULL)
9205                   && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
9206                        != s->type)
9207                       || (ffeinfo_kindtype (ffebld_info (caseobj->expr2))
9208                           != s->kindtype))))
9209             {
9210               ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
9211               ffebad_here (0, ffelex_token_where_line (caseobj->t),
9212                            ffelex_token_where_column (caseobj->t));
9213               ffebad_here (1, ffelex_token_where_line (s->t),
9214                            ffelex_token_where_column (s->t));
9215               ffebad_finish ();
9216               continue;
9217             }
9218
9219           if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
9220             {
9221               ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
9222               ffebad_here (0, ffelex_token_where_line (caseobj->t),
9223                            ffelex_token_where_column (caseobj->t));
9224               ffebad_finish ();
9225               continue;
9226             }
9227
9228           if (caseobj->expr1 == NULL)
9229             expr1c = NULL;
9230           else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
9231             continue;           /* opANY. */
9232           else
9233             expr1c = ffebld_conter (caseobj->expr1);
9234
9235           if (!caseobj->range)
9236             expr2c = expr1c;    /* expr1c and expr2c are NOT NULL in this
9237                                    case. */
9238           else if (caseobj->expr2 == NULL)
9239             expr2c = NULL;
9240           else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
9241             continue;           /* opANY. */
9242           else
9243             expr2c = ffebld_conter (caseobj->expr2);
9244
9245           if (expr1c == NULL)
9246             {                   /* "CASE (:high)", must be first in list. */
9247               c = s->first_rel;
9248               if ((c != (ffestwCase) &s->first_rel)
9249                   && ((c->low == NULL)
9250                       || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
9251                 {               /* Other "CASE (:high)" or lowest "CASE
9252                                    (low[:high])" low. */
9253                   ffebad_start (FFEBAD_CASE_DUPLICATE);
9254                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9255                                ffelex_token_where_column (caseobj->t));
9256                   ffebad_here (1, ffelex_token_where_line (c->t),
9257                                ffelex_token_where_column (c->t));
9258                   ffebad_finish ();
9259                   continue;
9260                 }
9261             }
9262           else if (expr2c == NULL)
9263             {                   /* "CASE (low:)", must be last in list. */
9264               c = s->last_rel;
9265               if ((c != (ffestwCase) &s->first_rel)
9266                   && ((c->high == NULL)
9267                       || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
9268                 {               /* Other "CASE (low:)" or lowest "CASE
9269                                    ([low:]high)" high. */
9270                   ffebad_start (FFEBAD_CASE_DUPLICATE);
9271                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9272                                ffelex_token_where_column (caseobj->t));
9273                   ffebad_here (1, ffelex_token_where_line (c->t),
9274                                ffelex_token_where_column (c->t));
9275                   ffebad_finish ();
9276                   continue;
9277                 }
9278               c = c->next_rel;  /* Same as c = (ffestwCase) &s->first;. */
9279             }
9280           else
9281             {                   /* (expr1c != NULL) && (expr2c != NULL). */
9282               if (ffebld_constant_cmp (expr1c, expr2c) > 0)
9283                 {               /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
9284                   ffebad_start (FFEBAD_CASE_RANGE_USELESS);     /* Warn/inform only. */
9285                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9286                                ffelex_token_where_column (caseobj->t));
9287                   ffebad_finish ();
9288                   continue;
9289                 }
9290               for (c = s->first_rel;
9291                    (c != (ffestwCase) &s->first_rel)
9292                    && ((c->low == NULL)
9293                        || (ffebld_constant_cmp (expr1c, c->low) > 0));
9294                    c = c->next_rel)
9295                 ;
9296               nc = c;           /* Which one to report? */
9297               if (((c != (ffestwCase) &s->first_rel)
9298                    && (ffebld_constant_cmp (expr2c, c->low) >= 0))
9299                   || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
9300                       && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
9301                 {               /* Interference with range in case nc. */
9302                   ffebad_start (FFEBAD_CASE_DUPLICATE);
9303                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9304                                ffelex_token_where_column (caseobj->t));
9305                   ffebad_here (1, ffelex_token_where_line (nc->t),
9306                                ffelex_token_where_column (nc->t));
9307                   ffebad_finish ();
9308                   continue;
9309                 }
9310             }
9311
9312           /* If we reach here for this case range/value, it's ok (sorts into
9313              the list of ranges/values) so we give it its own case object
9314              sorted into the list of case statements. */
9315
9316           nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
9317           nc->next_rel = c;
9318           nc->previous_rel = c->previous_rel;
9319           nc->next_stmt = (ffestwCase) &s->first_rel;
9320           nc->previous_stmt = s->last_stmt;
9321           nc->low = expr1c;
9322           nc->high = expr2c;
9323           nc->casenum = s->cases;
9324           nc->t = ffelex_token_use (caseobj->t);
9325           nc->next_rel->previous_rel = nc;
9326           nc->previous_rel->next_rel = nc;
9327           nc->next_stmt->previous_stmt = nc;
9328           nc->previous_stmt->next_stmt = nc;
9329         }
9330     }
9331
9332   ffestd_R810 ((cases == NULL) ? 0 : s->cases);
9333
9334   s->cases++;                   /* Increment # of cases. */
9335 }
9336
9337 /* ffestc_R811 -- END SELECT statement
9338
9339    ffestc_R811(name_token);
9340
9341    Make sure ffestc_kind_ identifies a SELECT block.  If not
9342    NULL, make sure name_token gives the correct name.  Implement the end
9343    of the SELECT block.  */
9344
9345 void
9346 ffestc_R811 (ffelexToken name)
9347 {
9348   ffestc_check_simple_ ();
9349   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9350     return;
9351   ffestc_labeldef_notloop_ ();
9352
9353   if (name == NULL)
9354     {
9355       if (ffestw_name (ffestw_stack_top ()) != NULL)
9356         {
9357           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9358           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9359                        ffelex_token_where_column (ffesta_tokens[0]));
9360           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9361           ffebad_finish ();
9362         }
9363     }
9364   else
9365     {
9366       if (ffestw_name (ffestw_stack_top ()) == NULL)
9367         {
9368           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9369           ffebad_here (0, ffelex_token_where_line (name),
9370                        ffelex_token_where_column (name));
9371           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9372           ffebad_finish ();
9373         }
9374       else if (ffelex_token_strcmp (name,
9375                                     ffestw_name (ffestw_stack_top ()))
9376                != 0)
9377         {
9378           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9379           ffebad_here (0, ffelex_token_where_line (name),
9380                        ffelex_token_where_column (name));
9381           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9382              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9383           ffebad_finish ();
9384         }
9385     }
9386
9387   ffestc_shriek_select_ (TRUE);
9388 }
9389
9390 /* ffestc_R819A -- Iterative labeled DO statement
9391
9392    ffestc_R819A(construct_name,label_token,expr,expr_token);
9393
9394    Make sure statement is valid here; implement.  */
9395
9396 void
9397 ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
9398    ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
9399               ffelexToken end_token, ffebld incr, ffelexToken incr_token)
9400 {
9401   ffestw b;
9402   ffelab label;
9403   ffesymbol s;
9404   ffesymbol varsym;
9405
9406   ffestc_check_simple_ ();
9407   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9408     return;
9409   ffestc_labeldef_notloop_ ();
9410
9411   if (!ffestc_labelref_is_loopend_ (label_token, &label))
9412     return;
9413
9414   b = ffestw_update (ffestw_push (NULL));
9415   ffestw_set_top_do (b, b);
9416   ffestw_set_state (b, FFESTV_stateDO);
9417   ffestw_set_blocknum (b, ffestc_blocknum_++);
9418   ffestw_set_shriek (b, ffestc_shriek_do_);
9419   ffestw_set_label (b, label);
9420   switch (ffebld_op (var))
9421     {
9422     case FFEBLD_opSYMTER:
9423       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9424           && ffe_is_warn_surprising ())
9425         {
9426           ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
9427           ffebad_here (0, ffelex_token_where_line (var_token),
9428                        ffelex_token_where_column (var_token));
9429           ffebad_string (ffesymbol_text (ffebld_symter (var)));
9430           ffebad_finish ();
9431         }
9432       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9433         {                       /* Presumably already complained about by
9434                                    ffeexpr_lhs_. */
9435           ffesymbol_set_is_doiter (varsym, TRUE);
9436           ffestw_set_do_iter_var (b, varsym);
9437           ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9438           break;
9439         }
9440       /* Fall through. */
9441     case FFEBLD_opANY:
9442       ffestw_set_do_iter_var (b, NULL);
9443       ffestw_set_do_iter_var_t (b, NULL);
9444       break;
9445
9446     default:
9447       assert ("bad iter var" == NULL);
9448       break;
9449     }
9450
9451   if (construct_name == NULL)
9452     ffestw_set_name (b, NULL);
9453   else
9454     {
9455       ffestw_set_name (b, ffelex_token_use (construct_name));
9456
9457       s = ffesymbol_declare_local (construct_name, FALSE);
9458
9459       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9460         {
9461           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9462           ffesymbol_set_info (s,
9463                               ffeinfo_new (FFEINFO_basictypeNONE,
9464                                            FFEINFO_kindtypeNONE,
9465                                            0,
9466                                            FFEINFO_kindCONSTRUCT,
9467                                            FFEINFO_whereLOCAL,
9468                                            FFETARGET_charactersizeNONE));
9469           s = ffecom_sym_learned (s);
9470           ffesymbol_signal_unreported (s);
9471         }
9472       else
9473         ffesymbol_error (s, construct_name);
9474     }
9475
9476   if (incr == NULL)
9477     {
9478       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9479       ffebld_set_info (incr, ffeinfo_new
9480                        (FFEINFO_basictypeINTEGER,
9481                         FFEINFO_kindtypeINTEGERDEFAULT,
9482                         0,
9483                         FFEINFO_kindENTITY,
9484                         FFEINFO_whereCONSTANT,
9485                         FFETARGET_charactersizeNONE));
9486     }
9487
9488   start = ffeexpr_convert_expr (start, start_token, var, var_token,
9489                                 FFEEXPR_contextLET);
9490   end = ffeexpr_convert_expr (end, end_token, var, var_token,
9491                               FFEEXPR_contextLET);
9492   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9493                                FFEEXPR_contextLET);
9494
9495   ffestd_R819A (construct_name, label, var,
9496                 start, start_token,
9497                 end, end_token,
9498                 incr, incr_token);
9499 }
9500
9501 /* ffestc_R819B -- Labeled DO WHILE statement
9502
9503    ffestc_R819B(construct_name,label_token,expr,expr_token);
9504
9505    Make sure statement is valid here; implement.  */
9506
9507 void
9508 ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
9509               ffebld expr, ffelexToken expr_token UNUSED)
9510 {
9511   ffestw b;
9512   ffelab label;
9513   ffesymbol s;
9514
9515   ffestc_check_simple_ ();
9516   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9517     return;
9518   ffestc_labeldef_notloop_ ();
9519
9520   if (!ffestc_labelref_is_loopend_ (label_token, &label))
9521     return;
9522
9523   b = ffestw_update (ffestw_push (NULL));
9524   ffestw_set_top_do (b, b);
9525   ffestw_set_state (b, FFESTV_stateDO);
9526   ffestw_set_blocknum (b, ffestc_blocknum_++);
9527   ffestw_set_shriek (b, ffestc_shriek_do_);
9528   ffestw_set_label (b, label);
9529   ffestw_set_do_iter_var (b, NULL);
9530   ffestw_set_do_iter_var_t (b, NULL);
9531
9532   if (construct_name == NULL)
9533     ffestw_set_name (b, NULL);
9534   else
9535     {
9536       ffestw_set_name (b, ffelex_token_use (construct_name));
9537
9538       s = ffesymbol_declare_local (construct_name, FALSE);
9539
9540       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9541         {
9542           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9543           ffesymbol_set_info (s,
9544                               ffeinfo_new (FFEINFO_basictypeNONE,
9545                                            FFEINFO_kindtypeNONE,
9546                                            0,
9547                                            FFEINFO_kindCONSTRUCT,
9548                                            FFEINFO_whereLOCAL,
9549                                            FFETARGET_charactersizeNONE));
9550           s = ffecom_sym_learned (s);
9551           ffesymbol_signal_unreported (s);
9552         }
9553       else
9554         ffesymbol_error (s, construct_name);
9555     }
9556
9557   ffestd_R819B (construct_name, label, expr);
9558 }
9559
9560 /* ffestc_R820A -- Iterative nonlabeled DO statement
9561
9562    ffestc_R820A(construct_name,expr,expr_token);
9563
9564    Make sure statement is valid here; implement.  */
9565
9566 void
9567 ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
9568    ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
9569               ffebld incr, ffelexToken incr_token)
9570 {
9571   ffestw b;
9572   ffesymbol s;
9573   ffesymbol varsym;
9574
9575   ffestc_check_simple_ ();
9576   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9577     return;
9578   ffestc_labeldef_notloop_ ();
9579
9580   b = ffestw_update (ffestw_push (NULL));
9581   ffestw_set_top_do (b, b);
9582   ffestw_set_state (b, FFESTV_stateDO);
9583   ffestw_set_blocknum (b, ffestc_blocknum_++);
9584   ffestw_set_shriek (b, ffestc_shriek_do_);
9585   ffestw_set_label (b, NULL);
9586   switch (ffebld_op (var))
9587     {
9588     case FFEBLD_opSYMTER:
9589       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9590           && ffe_is_warn_surprising ())
9591         {
9592           ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
9593           ffebad_here (0, ffelex_token_where_line (var_token),
9594                        ffelex_token_where_column (var_token));
9595           ffebad_string (ffesymbol_text (ffebld_symter (var)));
9596           ffebad_finish ();
9597         }
9598       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9599         {                       /* Presumably already complained about by
9600                                    ffeexpr_lhs_. */
9601           ffesymbol_set_is_doiter (varsym, TRUE);
9602           ffestw_set_do_iter_var (b, varsym);
9603           ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9604           break;
9605         }
9606       /* Fall through. */
9607     case FFEBLD_opANY:
9608       ffestw_set_do_iter_var (b, NULL);
9609       ffestw_set_do_iter_var_t (b, NULL);
9610       break;
9611
9612     default:
9613       assert ("bad iter var" == NULL);
9614       break;
9615     }
9616
9617   if (construct_name == NULL)
9618     ffestw_set_name (b, NULL);
9619   else
9620     {
9621       ffestw_set_name (b, ffelex_token_use (construct_name));
9622
9623       s = ffesymbol_declare_local (construct_name, FALSE);
9624
9625       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9626         {
9627           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9628           ffesymbol_set_info (s,
9629                               ffeinfo_new (FFEINFO_basictypeNONE,
9630                                            FFEINFO_kindtypeNONE,
9631                                            0,
9632                                            FFEINFO_kindCONSTRUCT,
9633                                            FFEINFO_whereLOCAL,
9634                                            FFETARGET_charactersizeNONE));
9635           s = ffecom_sym_learned (s);
9636           ffesymbol_signal_unreported (s);
9637         }
9638       else
9639         ffesymbol_error (s, construct_name);
9640     }
9641
9642   if (incr == NULL)
9643     {
9644       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9645       ffebld_set_info (incr, ffeinfo_new
9646                        (FFEINFO_basictypeINTEGER,
9647                         FFEINFO_kindtypeINTEGERDEFAULT,
9648                         0,
9649                         FFEINFO_kindENTITY,
9650                         FFEINFO_whereCONSTANT,
9651                         FFETARGET_charactersizeNONE));
9652     }
9653
9654   start = ffeexpr_convert_expr (start, start_token, var, var_token,
9655                                 FFEEXPR_contextLET);
9656   end = ffeexpr_convert_expr (end, end_token, var, var_token,
9657                               FFEEXPR_contextLET);
9658   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9659                                FFEEXPR_contextLET);
9660
9661 #if 0
9662   if ((ffebld_op (incr) == FFEBLD_opCONTER)
9663       && (ffebld_constant_is_zero (ffebld_conter (incr))))
9664     {
9665       ffebad_start (FFEBAD_DO_STEP_ZERO);
9666       ffebad_here (0, ffelex_token_where_line (incr_token),
9667                    ffelex_token_where_column (incr_token));
9668       ffebad_string ("Iterative DO loop");
9669       ffebad_finish ();
9670     }
9671 #endif
9672
9673   ffestd_R819A (construct_name, NULL, var,
9674                 start, start_token,
9675                 end, end_token,
9676                 incr, incr_token);
9677 }
9678
9679 /* ffestc_R820B -- Nonlabeled DO WHILE statement
9680
9681    ffestc_R820B(construct_name,expr,expr_token);
9682
9683    Make sure statement is valid here; implement.  */
9684
9685 void
9686 ffestc_R820B (ffelexToken construct_name, ffebld expr,
9687               ffelexToken expr_token UNUSED)
9688 {
9689   ffestw b;
9690   ffesymbol s;
9691
9692   ffestc_check_simple_ ();
9693   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9694     return;
9695   ffestc_labeldef_notloop_ ();
9696
9697   b = ffestw_update (ffestw_push (NULL));
9698   ffestw_set_top_do (b, b);
9699   ffestw_set_state (b, FFESTV_stateDO);
9700   ffestw_set_blocknum (b, ffestc_blocknum_++);
9701   ffestw_set_shriek (b, ffestc_shriek_do_);
9702   ffestw_set_label (b, NULL);
9703   ffestw_set_do_iter_var (b, NULL);
9704   ffestw_set_do_iter_var_t (b, NULL);
9705
9706   if (construct_name == NULL)
9707     ffestw_set_name (b, NULL);
9708   else
9709     {
9710       ffestw_set_name (b, ffelex_token_use (construct_name));
9711
9712       s = ffesymbol_declare_local (construct_name, FALSE);
9713
9714       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9715         {
9716           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9717           ffesymbol_set_info (s,
9718                               ffeinfo_new (FFEINFO_basictypeNONE,
9719                                            FFEINFO_kindtypeNONE,
9720                                            0,
9721                                            FFEINFO_kindCONSTRUCT,
9722                                            FFEINFO_whereLOCAL,
9723                                            FFETARGET_charactersizeNONE));
9724           s = ffecom_sym_learned (s);
9725           ffesymbol_signal_unreported (s);
9726         }
9727       else
9728         ffesymbol_error (s, construct_name);
9729     }
9730
9731   ffestd_R819B (construct_name, NULL, expr);
9732 }
9733
9734 /* ffestc_R825 -- END DO statement
9735
9736    ffestc_R825(name_token);
9737
9738    Make sure ffestc_kind_ identifies a DO block.  If not
9739    NULL, make sure name_token gives the correct name.  Implement the end
9740    of the DO block.  */
9741
9742 void
9743 ffestc_R825 (ffelexToken name)
9744 {
9745   ffestc_check_simple_ ();
9746   if (ffestc_order_do_ () != FFESTC_orderOK_)
9747     return;
9748   ffestc_labeldef_branch_begin_ ();
9749
9750   if (name == NULL)
9751     {
9752       if (ffestw_name (ffestw_stack_top ()) != NULL)
9753         {
9754           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9755           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9756                        ffelex_token_where_column (ffesta_tokens[0]));
9757           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9758           ffebad_finish ();
9759         }
9760     }
9761   else
9762     {
9763       if (ffestw_name (ffestw_stack_top ()) == NULL)
9764         {
9765           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9766           ffebad_here (0, ffelex_token_where_line (name),
9767                        ffelex_token_where_column (name));
9768           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9769           ffebad_finish ();
9770         }
9771       else if (ffelex_token_strcmp (name,
9772                                     ffestw_name (ffestw_stack_top ()))
9773                != 0)
9774         {
9775           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9776           ffebad_here (0, ffelex_token_where_line (name),
9777                        ffelex_token_where_column (name));
9778           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9779              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9780           ffebad_finish ();
9781         }
9782     }
9783
9784   if (ffesta_label_token == NULL)
9785     {                           /* If top of stack has label, its an error! */
9786       if (ffestw_label (ffestw_stack_top ()) != NULL)
9787         {
9788           ffebad_start (FFEBAD_DO_HAD_LABEL);
9789           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9790                        ffelex_token_where_column (ffesta_tokens[0]));
9791           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9792           ffebad_finish ();
9793         }
9794
9795       ffestc_shriek_do_ (TRUE);
9796
9797       ffestc_try_shriek_do_ ();
9798
9799       return;
9800     }
9801
9802   ffestd_R825 (name);
9803
9804   ffestc_labeldef_branch_end_ ();
9805 }
9806
9807 /* ffestc_R834 -- CYCLE statement
9808
9809    ffestc_R834(name_token);
9810
9811    Handle a CYCLE within a loop.  */
9812
9813 void
9814 ffestc_R834 (ffelexToken name)
9815 {
9816   ffestw block;
9817
9818   ffestc_check_simple_ ();
9819   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9820     return;
9821   ffestc_labeldef_notloop_begin_ ();
9822
9823   if (name == NULL)
9824     block = ffestw_top_do (ffestw_stack_top ());
9825   else
9826     {                           /* Search for name. */
9827       for (block = ffestw_top_do (ffestw_stack_top ());
9828            (block != NULL) && (ffestw_blocknum (block) != 0);
9829            block = ffestw_top_do (ffestw_previous (block)))
9830         {
9831           if ((ffestw_name (block) != NULL)
9832               && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9833             break;
9834         }
9835       if ((block == NULL) || (ffestw_blocknum (block) == 0))
9836         {
9837           block = ffestw_top_do (ffestw_stack_top ());
9838           ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9839           ffebad_here (0, ffelex_token_where_line (name),
9840                        ffelex_token_where_column (name));
9841           ffebad_finish ();
9842         }
9843     }
9844
9845   ffestd_R834 (block);
9846
9847   if (ffestc_shriek_after1_ != NULL)
9848     (*ffestc_shriek_after1_) (TRUE);
9849
9850   /* notloop's that are actionif's can be the target of a loop-end
9851      statement if they're in the "then" part of a logical IF, as
9852      in "DO 10", "10 IF (...) CYCLE".  */
9853
9854   ffestc_labeldef_branch_end_ ();
9855 }
9856
9857 /* ffestc_R835 -- EXIT statement
9858
9859    ffestc_R835(name_token);
9860
9861    Handle a EXIT within a loop.  */
9862
9863 void
9864 ffestc_R835 (ffelexToken name)
9865 {
9866   ffestw block;
9867
9868   ffestc_check_simple_ ();
9869   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9870     return;
9871   ffestc_labeldef_notloop_begin_ ();
9872
9873   if (name == NULL)
9874     block = ffestw_top_do (ffestw_stack_top ());
9875   else
9876     {                           /* Search for name. */
9877       for (block = ffestw_top_do (ffestw_stack_top ());
9878            (block != NULL) && (ffestw_blocknum (block) != 0);
9879            block = ffestw_top_do (ffestw_previous (block)))
9880         {
9881           if ((ffestw_name (block) != NULL)
9882               && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9883             break;
9884         }
9885       if ((block == NULL) || (ffestw_blocknum (block) == 0))
9886         {
9887           block = ffestw_top_do (ffestw_stack_top ());
9888           ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9889           ffebad_here (0, ffelex_token_where_line (name),
9890                        ffelex_token_where_column (name));
9891           ffebad_finish ();
9892         }
9893     }
9894
9895   ffestd_R835 (block);
9896
9897   if (ffestc_shriek_after1_ != NULL)
9898     (*ffestc_shriek_after1_) (TRUE);
9899
9900   /* notloop's that are actionif's can be the target of a loop-end
9901      statement if they're in the "then" part of a logical IF, as
9902      in "DO 10", "10 IF (...) EXIT".  */
9903
9904   ffestc_labeldef_branch_end_ ();
9905 }
9906
9907 /* ffestc_R836 -- GOTO statement
9908
9909    ffestc_R836(label_token);
9910
9911    Make sure label_token identifies a valid label for a GOTO.  Update
9912    that label's info to indicate it is the target of a GOTO.  */
9913
9914 void
9915 ffestc_R836 (ffelexToken label_token)
9916 {
9917   ffelab label;
9918
9919   ffestc_check_simple_ ();
9920   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9921     return;
9922   ffestc_labeldef_notloop_begin_ ();
9923
9924   if (ffestc_labelref_is_branch_ (label_token, &label))
9925     ffestd_R836 (label);
9926
9927   if (ffestc_shriek_after1_ != NULL)
9928     (*ffestc_shriek_after1_) (TRUE);
9929
9930   /* notloop's that are actionif's can be the target of a loop-end
9931      statement if they're in the "then" part of a logical IF, as
9932      in "DO 10", "10 IF (...) GOTO 100".  */
9933
9934   ffestc_labeldef_branch_end_ ();
9935 }
9936
9937 /* ffestc_R837 -- Computed GOTO statement
9938
9939    ffestc_R837(label_list,expr,expr_token);
9940
9941    Make sure label_list identifies valid labels for a GOTO.  Update
9942    each label's info to indicate it is the target of a GOTO.  */
9943
9944 void
9945 ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
9946              ffelexToken expr_token UNUSED)
9947 {
9948   ffesttTokenItem ti;
9949   bool ok = TRUE;
9950   int i;
9951   ffelab *labels;
9952
9953   assert (label_toks != NULL);
9954
9955   ffestc_check_simple_ ();
9956   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9957     return;
9958   ffestc_labeldef_branch_begin_ ();
9959
9960   labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
9961                           sizeof (*labels)
9962                           * ffestt_tokenlist_count (label_toks));
9963
9964   for (ti = label_toks->first, i = 0;
9965        ti != (ffesttTokenItem) &label_toks->first;
9966        ti = ti->next, ++i)
9967     {
9968       if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
9969         {
9970           ok = FALSE;
9971           break;
9972         }
9973     }
9974
9975   if (ok)
9976     ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
9977
9978   if (ffestc_shriek_after1_ != NULL)
9979     (*ffestc_shriek_after1_) (TRUE);
9980   ffestc_labeldef_branch_end_ ();
9981 }
9982
9983 /* ffestc_R838 -- ASSIGN statement
9984
9985    ffestc_R838(label_token,target_variable,target_token);
9986
9987    Make sure label_token identifies a valid label for an assignment.  Update
9988    that label's info to indicate it is the source of an assignment.  Update
9989    target_variable's info to indicate it is the target the assignment of that
9990    label.  */
9991
9992 void
9993 ffestc_R838 (ffelexToken label_token, ffebld target,
9994              ffelexToken target_token UNUSED)
9995 {
9996   ffelab label;
9997
9998   ffestc_check_simple_ ();
9999   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10000     return;
10001   ffestc_labeldef_branch_begin_ ();
10002
10003   /* Mark target symbol as target of an ASSIGN.  */
10004   if (ffebld_op (target) == FFEBLD_opSYMTER)
10005     ffesymbol_set_assigned (ffebld_symter (target), TRUE);
10006
10007   if (ffestc_labelref_is_assignable_ (label_token, &label))
10008     ffestd_R838 (label, target);
10009
10010   if (ffestc_shriek_after1_ != NULL)
10011     (*ffestc_shriek_after1_) (TRUE);
10012   ffestc_labeldef_branch_end_ ();
10013 }
10014
10015 /* ffestc_R839 -- Assigned GOTO statement
10016
10017    ffestc_R839(target,target_token,label_list);
10018
10019    Make sure label_list identifies valid labels for a GOTO.  Update
10020    each label's info to indicate it is the target of a GOTO.  */
10021
10022 void
10023 ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
10024              ffesttTokenList label_toks)
10025 {
10026   ffesttTokenItem ti;
10027   bool ok = TRUE;
10028   int i;
10029   ffelab *labels;
10030
10031   ffestc_check_simple_ ();
10032   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10033     return;
10034   ffestc_labeldef_notloop_begin_ ();
10035
10036   if (label_toks == NULL)
10037     {
10038       labels = NULL;
10039       i = 0;
10040     }
10041   else
10042     {
10043       labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
10044                     sizeof (*labels) * ffestt_tokenlist_count (label_toks));
10045
10046       for (ti = label_toks->first, i = 0;
10047            ti != (ffesttTokenItem) &label_toks->first;
10048            ti = ti->next, ++i)
10049         {
10050           if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
10051             {
10052               ok = FALSE;
10053               break;
10054             }
10055         }
10056     }
10057
10058   if (ok)
10059     ffestd_R839 (target, labels, i);
10060
10061   if (ffestc_shriek_after1_ != NULL)
10062     (*ffestc_shriek_after1_) (TRUE);
10063
10064   /* notloop's that are actionif's can be the target of a loop-end
10065      statement if they're in the "then" part of a logical IF, as
10066      in "DO 10", "10 IF (...) GOTO I".  */
10067
10068   ffestc_labeldef_branch_end_ ();
10069 }
10070
10071 /* ffestc_R840 -- Arithmetic IF statement
10072
10073    ffestc_R840(expr,expr_token,neg,zero,pos);
10074
10075    Make sure the labels are valid; implement.  */
10076
10077 void
10078 ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
10079              ffelexToken neg_token, ffelexToken zero_token,
10080              ffelexToken pos_token)
10081 {
10082   ffelab neg;
10083   ffelab zero;
10084   ffelab pos;
10085
10086   ffestc_check_simple_ ();
10087   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10088     return;
10089   ffestc_labeldef_notloop_begin_ ();
10090
10091   if (ffestc_labelref_is_branch_ (neg_token, &neg)
10092       && ffestc_labelref_is_branch_ (zero_token, &zero)
10093       && ffestc_labelref_is_branch_ (pos_token, &pos))
10094     ffestd_R840 (expr, neg, zero, pos);
10095
10096   if (ffestc_shriek_after1_ != NULL)
10097     (*ffestc_shriek_after1_) (TRUE);
10098
10099   /* notloop's that are actionif's can be the target of a loop-end
10100      statement if they're in the "then" part of a logical IF, as
10101      in "DO 10", "10 IF (...) GOTO (100,200,300), I".  */
10102
10103   ffestc_labeldef_branch_end_ ();
10104 }
10105
10106 /* ffestc_R841 -- CONTINUE statement
10107
10108    ffestc_R841();  */
10109
10110 void
10111 ffestc_R841 ()
10112 {
10113   ffestc_check_simple_ ();
10114
10115   if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
10116     return;
10117
10118   switch (ffestw_state (ffestw_stack_top ()))
10119     {
10120 #if FFESTR_F90
10121     case FFESTV_stateWHERE:
10122     case FFESTV_stateWHERETHEN:
10123       ffestc_labeldef_useless_ ();
10124
10125       ffestd_R841 (TRUE);
10126
10127       /* It's okay that we call ffestc_labeldef_branch_end_ () below,
10128          since that will be a no-op after calling _useless_ () above.  */
10129       break;
10130 #endif
10131
10132     default:
10133       ffestc_labeldef_branch_begin_ ();
10134
10135       ffestd_R841 (FALSE);
10136
10137       break;
10138     }
10139
10140   if (ffestc_shriek_after1_ != NULL)
10141     (*ffestc_shriek_after1_) (TRUE);
10142   ffestc_labeldef_branch_end_ ();
10143 }
10144
10145 /* ffestc_R842 -- STOP statement
10146
10147    ffestc_R842(expr,expr_token);
10148
10149    Make sure statement is valid here; implement.  expr and expr_token are
10150    both NULL if there was no expression.  */
10151
10152 void
10153 ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
10154 {
10155   ffestc_check_simple_ ();
10156   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10157     return;
10158   ffestc_labeldef_notloop_begin_ ();
10159
10160   ffestd_R842 (expr);
10161
10162   if (ffestc_shriek_after1_ != NULL)
10163     (*ffestc_shriek_after1_) (TRUE);
10164
10165   /* notloop's that are actionif's can be the target of a loop-end
10166      statement if they're in the "then" part of a logical IF, as
10167      in "DO 10", "10 IF (...) STOP".  */
10168
10169   ffestc_labeldef_branch_end_ ();
10170 }
10171
10172 /* ffestc_R843 -- PAUSE statement
10173
10174    ffestc_R843(expr,expr_token);
10175
10176    Make sure statement is valid here; implement.  expr and expr_token are
10177    both NULL if there was no expression.  */
10178
10179 void
10180 ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
10181 {
10182   ffestc_check_simple_ ();
10183   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10184     return;
10185   ffestc_labeldef_branch_begin_ ();
10186
10187   ffestd_R843 (expr);
10188
10189   if (ffestc_shriek_after1_ != NULL)
10190     (*ffestc_shriek_after1_) (TRUE);
10191   ffestc_labeldef_branch_end_ ();
10192 }
10193
10194 /* ffestc_R904 -- OPEN statement
10195
10196    ffestc_R904();
10197
10198    Make sure an OPEN is valid in the current context, and implement it.  */
10199
10200 void
10201 ffestc_R904 ()
10202 {
10203   int i;
10204   int expect_file;
10205   const char *status_strs[]
10206   =
10207   {
10208     "New",
10209     "Old",
10210     "Replace",
10211     "Scratch",
10212     "Unknown"
10213   };
10214   const char *access_strs[]
10215   =
10216   {
10217     "Append",
10218     "Direct",
10219     "Keyed",
10220     "Sequential"
10221   };
10222   const char *blank_strs[]
10223   =
10224   {
10225     "Null",
10226     "Zero"
10227   };
10228   const char *carriagecontrol_strs[]
10229   =
10230   {
10231     "Fortran",
10232     "List",
10233     "None"
10234   };
10235   const char *dispose_strs[]
10236   =
10237   {
10238     "Delete",
10239     "Keep",
10240     "Print",
10241     "Print/Delete",
10242     "Save",
10243     "Submit",
10244     "Submit/Delete"
10245   };
10246   const char *form_strs[]
10247   =
10248   {
10249     "Formatted",
10250     "Unformatted"
10251   };
10252   const char *organization_strs[]
10253   =
10254   {
10255     "Indexed",
10256     "Relative",
10257     "Sequential"
10258   };
10259   const char *position_strs[]
10260   =
10261   {
10262     "Append",
10263     "AsIs",
10264     "Rewind"
10265   };
10266   const char *action_strs[]
10267   =
10268   {
10269     "Read",
10270     "ReadWrite",
10271     "Write"
10272   };
10273   const char *delim_strs[]
10274   =
10275   {
10276     "Apostrophe",
10277     "None",
10278     "Quote"
10279   };
10280   const char *recordtype_strs[]
10281   =
10282   {
10283     "Fixed",
10284     "Segmented",
10285     "Stream",
10286     "Stream_CR",
10287     "Stream_LF",
10288     "Variable"
10289   };
10290   const char *pad_strs[]
10291   =
10292   {
10293     "No",
10294     "Yes"
10295   };
10296
10297   ffestc_check_simple_ ();
10298   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10299     return;
10300   ffestc_labeldef_branch_begin_ ();
10301
10302   if (ffestc_subr_is_branch_
10303       (&ffestp_file.open.open_spec[FFESTP_openixERR])
10304       && ffestc_subr_is_present_ ("UNIT",
10305                             &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
10306     {
10307       i = ffestc_subr_binsrch_ (status_strs,
10308                                 ARRAY_SIZE (status_strs),
10309                            &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
10310                                 "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
10311       switch (i)
10312         {
10313         case 0:         /* Unknown. */
10314         case 5:         /* UNKNOWN. */
10315           expect_file = 2;      /* Unknown, don't care about FILE=. */
10316           break;
10317
10318         case 1:         /* NEW. */
10319         case 2:         /* OLD. */
10320           if (ffe_is_pedantic ())
10321             expect_file = 1;    /* Yes, need FILE=. */
10322           else
10323             expect_file = 2;    /* f2clib doesn't care about FILE=. */
10324           break;
10325
10326         case 3:         /* REPLACE. */
10327           expect_file = 1;      /* Yes, need FILE=. */
10328           break;
10329
10330         case 4:         /* SCRATCH. */
10331           expect_file = 0;      /* No, disallow FILE=. */
10332           break;
10333
10334         default:
10335           assert ("invalid _binsrch_ result" == NULL);
10336           expect_file = 0;
10337           break;
10338         }
10339       if ((expect_file == 0)
10340           && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10341         {
10342           ffebad_start (FFEBAD_CONFLICTING_SPECS);
10343           assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
10344           if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
10345             {
10346               ffebad_here (0, ffelex_token_where_line
10347                          (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
10348                            ffelex_token_where_column
10349                         (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
10350             }
10351           else
10352             {
10353               ffebad_here (0, ffelex_token_where_line
10354                       (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
10355                            ffelex_token_where_column
10356                      (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
10357             }
10358           assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10359           if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10360             {
10361               ffebad_here (1, ffelex_token_where_line
10362                        (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10363                            ffelex_token_where_column
10364                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10365             }
10366           else
10367             {
10368               ffebad_here (1, ffelex_token_where_line
10369                     (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10370                            ffelex_token_where_column
10371                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10372             }
10373           ffebad_finish ();
10374         }
10375       else if ((expect_file == 1)
10376         && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10377         {
10378           ffebad_start (FFEBAD_MISSING_SPECIFIER);
10379           assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10380           if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10381             {
10382               ffebad_here (0, ffelex_token_where_line
10383                        (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10384                            ffelex_token_where_column
10385                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10386             }
10387           else
10388             {
10389               ffebad_here (0, ffelex_token_where_line
10390                     (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10391                            ffelex_token_where_column
10392                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10393             }
10394           ffebad_string ("FILE=");
10395           ffebad_finish ();
10396         }
10397
10398       ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
10399                             &ffestp_file.open.open_spec[FFESTP_openixACCESS],
10400                             "APPEND, DIRECT, KEYED, or SEQUENTIAL");
10401
10402       ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
10403                             &ffestp_file.open.open_spec[FFESTP_openixBLANK],
10404                             "NULL or ZERO");
10405
10406       ffestc_subr_binsrch_ (carriagecontrol_strs,
10407                             ARRAY_SIZE (carriagecontrol_strs),
10408                   &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
10409                             "FORTRAN, LIST, or NONE");
10410
10411       ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
10412                           &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
10413        "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10414
10415       ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
10416                             &ffestp_file.open.open_spec[FFESTP_openixFORM],
10417                             "FORMATTED or UNFORMATTED");
10418
10419       ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
10420                      &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
10421                             "INDEXED, RELATIVE, or SEQUENTIAL");
10422
10423       ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
10424                          &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
10425                             "APPEND, ASIS, or REWIND");
10426
10427       ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
10428                             &ffestp_file.open.open_spec[FFESTP_openixACTION],
10429                             "READ, READWRITE, or WRITE");
10430
10431       ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
10432                             &ffestp_file.open.open_spec[FFESTP_openixDELIM],
10433                             "APOSTROPHE, NONE, or QUOTE");
10434
10435       ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
10436                        &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
10437              "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
10438
10439       ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
10440                             &ffestp_file.open.open_spec[FFESTP_openixPAD],
10441                             "NO or YES");
10442
10443       ffestd_R904 ();
10444     }
10445
10446   if (ffestc_shriek_after1_ != NULL)
10447     (*ffestc_shriek_after1_) (TRUE);
10448   ffestc_labeldef_branch_end_ ();
10449 }
10450
10451 /* ffestc_R907 -- CLOSE statement
10452
10453    ffestc_R907();
10454
10455    Make sure a CLOSE is valid in the current context, and implement it.  */
10456
10457 void
10458 ffestc_R907 ()
10459 {
10460   const char *status_strs[]
10461   =
10462   {
10463     "Delete",
10464     "Keep",
10465     "Print",
10466     "Print/Delete",
10467     "Save",
10468     "Submit",
10469     "Submit/Delete"
10470   };
10471
10472   ffestc_check_simple_ ();
10473   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10474     return;
10475   ffestc_labeldef_branch_begin_ ();
10476
10477   if (ffestc_subr_is_branch_
10478       (&ffestp_file.close.close_spec[FFESTP_closeixERR])
10479       && ffestc_subr_is_present_ ("UNIT",
10480                          &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
10481     {
10482       ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
10483                         &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
10484        "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10485
10486       ffestd_R907 ();
10487     }
10488
10489   if (ffestc_shriek_after1_ != NULL)
10490     (*ffestc_shriek_after1_) (TRUE);
10491   ffestc_labeldef_branch_end_ ();
10492 }
10493
10494 /* ffestc_R909_start -- READ(...) statement list begin
10495
10496    ffestc_R909_start(FALSE);
10497
10498    Verify that READ is valid here, and begin accepting items in the
10499    list.  */
10500
10501 void
10502 ffestc_R909_start (bool only_format)
10503 {
10504   ffestvUnit unit;
10505   ffestvFormat format;
10506   bool rec;
10507   bool key;
10508   ffestpReadIx keyn;
10509   ffestpReadIx spec1;
10510   ffestpReadIx spec2;
10511
10512   ffestc_check_start_ ();
10513   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10514     {
10515       ffestc_ok_ = FALSE;
10516       return;
10517     }
10518   ffestc_labeldef_branch_begin_ ();
10519
10520   if (!ffestc_subr_is_format_
10521       (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
10522     {
10523       ffestc_ok_ = FALSE;
10524       return;
10525     }
10526
10527   format = ffestc_subr_format_
10528     (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
10529   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10530
10531   if (only_format)
10532     {
10533       ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
10534
10535       ffestc_ok_ = TRUE;
10536       return;
10537     }
10538
10539   if (!ffestc_subr_is_branch_
10540       (&ffestp_file.read.read_spec[FFESTP_readixEOR])
10541       || !ffestc_subr_is_branch_
10542       (&ffestp_file.read.read_spec[FFESTP_readixERR])
10543       || !ffestc_subr_is_branch_
10544       (&ffestp_file.read.read_spec[FFESTP_readixEND]))
10545     {
10546       ffestc_ok_ = FALSE;
10547       return;
10548     }
10549
10550   unit = ffestc_subr_unit_
10551     (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
10552   if (unit == FFESTV_unitNONE)
10553     {
10554       ffebad_start (FFEBAD_NO_UNIT_SPEC);
10555       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10556                    ffelex_token_where_column (ffesta_tokens[0]));
10557       ffebad_finish ();
10558       ffestc_ok_ = FALSE;
10559       return;
10560     }
10561
10562   rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
10563
10564   if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
10565     {
10566       key = TRUE;
10567       keyn = spec1 = FFESTP_readixKEYEQ;
10568     }
10569   else
10570     {
10571       key = FALSE;
10572       keyn = spec1 = FFESTP_readix;
10573     }
10574
10575   if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
10576     {
10577       if (key)
10578         {
10579           spec2 = FFESTP_readixKEYGT;
10580         whine:                  /* :::::::::::::::::::: */
10581           ffebad_start (FFEBAD_CONFLICTING_SPECS);
10582           assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
10583           if (ffestp_file.read.read_spec[spec1].kw_present)
10584             {
10585               ffebad_here (0, ffelex_token_where_line
10586                            (ffestp_file.read.read_spec[spec1].kw),
10587                            ffelex_token_where_column
10588                            (ffestp_file.read.read_spec[spec1].kw));
10589             }
10590           else
10591             {
10592               ffebad_here (0, ffelex_token_where_line
10593                            (ffestp_file.read.read_spec[spec1].value),
10594                            ffelex_token_where_column
10595                            (ffestp_file.read.read_spec[spec1].value));
10596             }
10597           assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
10598           if (ffestp_file.read.read_spec[spec2].kw_present)
10599             {
10600               ffebad_here (1, ffelex_token_where_line
10601                            (ffestp_file.read.read_spec[spec2].kw),
10602                            ffelex_token_where_column
10603                            (ffestp_file.read.read_spec[spec2].kw));
10604             }
10605           else
10606             {
10607               ffebad_here (1, ffelex_token_where_line
10608                            (ffestp_file.read.read_spec[spec2].value),
10609                            ffelex_token_where_column
10610                            (ffestp_file.read.read_spec[spec2].value));
10611             }
10612           ffebad_finish ();
10613           ffestc_ok_ = FALSE;
10614           return;
10615         }
10616       key = TRUE;
10617       keyn = spec1 = FFESTP_readixKEYGT;
10618     }
10619
10620   if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
10621     {
10622       if (key)
10623         {
10624           spec2 = FFESTP_readixKEYGT;
10625           goto whine;           /* :::::::::::::::::::: */
10626         }
10627       key = TRUE;
10628       keyn = FFESTP_readixKEYGT;
10629     }
10630
10631   if (rec)
10632     {
10633       spec1 = FFESTP_readixREC;
10634       if (key)
10635         {
10636           spec2 = keyn;
10637           goto whine;           /* :::::::::::::::::::: */
10638         }
10639       if (unit == FFESTV_unitCHAREXPR)
10640         {
10641           spec2 = FFESTP_readixUNIT;
10642           goto whine;           /* :::::::::::::::::::: */
10643         }
10644       if ((format == FFESTV_formatASTERISK)
10645           || (format == FFESTV_formatNAMELIST))
10646         {
10647           spec2 = FFESTP_readixFORMAT;
10648           goto whine;           /* :::::::::::::::::::: */
10649         }
10650       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10651         {
10652           spec2 = FFESTP_readixADVANCE;
10653           goto whine;           /* :::::::::::::::::::: */
10654         }
10655       if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10656         {
10657           spec2 = FFESTP_readixEND;
10658           goto whine;           /* :::::::::::::::::::: */
10659         }
10660       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10661         {
10662           spec2 = FFESTP_readixNULLS;
10663           goto whine;           /* :::::::::::::::::::: */
10664         }
10665     }
10666   else if (key)
10667     {
10668       spec1 = keyn;
10669       if (unit == FFESTV_unitCHAREXPR)
10670         {
10671           spec2 = FFESTP_readixUNIT;
10672           goto whine;           /* :::::::::::::::::::: */
10673         }
10674       if ((format == FFESTV_formatASTERISK)
10675           || (format == FFESTV_formatNAMELIST))
10676         {
10677           spec2 = FFESTP_readixFORMAT;
10678           goto whine;           /* :::::::::::::::::::: */
10679         }
10680       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10681         {
10682           spec2 = FFESTP_readixADVANCE;
10683           goto whine;           /* :::::::::::::::::::: */
10684         }
10685       if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10686         {
10687           spec2 = FFESTP_readixEND;
10688           goto whine;           /* :::::::::::::::::::: */
10689         }
10690       if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10691         {
10692           spec2 = FFESTP_readixEOR;
10693           goto whine;           /* :::::::::::::::::::: */
10694         }
10695       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10696         {
10697           spec2 = FFESTP_readixNULLS;
10698           goto whine;           /* :::::::::::::::::::: */
10699         }
10700       if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
10701         {
10702           spec2 = FFESTP_readixREC;
10703           goto whine;           /* :::::::::::::::::::: */
10704         }
10705       if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10706         {
10707           spec2 = FFESTP_readixSIZE;
10708           goto whine;           /* :::::::::::::::::::: */
10709         }
10710     }
10711   else
10712     {                           /* Sequential/Internal. */
10713       if (unit == FFESTV_unitCHAREXPR)
10714         {                       /* Internal file. */
10715           spec1 = FFESTP_readixUNIT;
10716           if (format == FFESTV_formatNAMELIST)
10717             {
10718               spec2 = FFESTP_readixFORMAT;
10719               goto whine;       /* :::::::::::::::::::: */
10720             }
10721           if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10722             {
10723               spec2 = FFESTP_readixADVANCE;
10724               goto whine;       /* :::::::::::::::::::: */
10725             }
10726         }
10727       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10728         {                       /* ADVANCE= specified. */
10729           spec1 = FFESTP_readixADVANCE;
10730           if (format == FFESTV_formatNONE)
10731             {
10732               ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10733               ffebad_here (0, ffelex_token_where_line
10734                            (ffestp_file.read.read_spec[spec1].kw),
10735                            ffelex_token_where_column
10736                            (ffestp_file.read.read_spec[spec1].kw));
10737               ffebad_finish ();
10738
10739               ffestc_ok_ = FALSE;
10740               return;
10741             }
10742           if (format == FFESTV_formatNAMELIST)
10743             {
10744               spec2 = FFESTP_readixFORMAT;
10745               goto whine;       /* :::::::::::::::::::: */
10746             }
10747         }
10748       if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10749         {                       /* EOR= specified. */
10750           spec1 = FFESTP_readixEOR;
10751           if (ffestc_subr_speccmp_ ("No",
10752                           &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10753                                     NULL, NULL) != 0)
10754             {
10755               goto whine_advance;       /* :::::::::::::::::::: */
10756             }
10757         }
10758       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10759         {                       /* NULLS= specified. */
10760           spec1 = FFESTP_readixNULLS;
10761           if (format != FFESTV_formatASTERISK)
10762             {
10763               spec2 = FFESTP_readixFORMAT;
10764               goto whine;       /* :::::::::::::::::::: */
10765             }
10766         }
10767       if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10768         {                       /* SIZE= specified. */
10769           spec1 = FFESTP_readixSIZE;
10770           if (ffestc_subr_speccmp_ ("No",
10771                           &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10772                                     NULL, NULL) != 0)
10773             {
10774             whine_advance:      /* :::::::::::::::::::: */
10775               if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
10776                   .kw_or_val_present)
10777                 {
10778                   ffebad_start (FFEBAD_CONFLICTING_SPECS);
10779                   ffebad_here (0, ffelex_token_where_line
10780                                (ffestp_file.read.read_spec[spec1].kw),
10781                                ffelex_token_where_column
10782                                (ffestp_file.read.read_spec[spec1].kw));
10783                   ffebad_here (1, ffelex_token_where_line
10784                       (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
10785                                ffelex_token_where_column
10786                      (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
10787                   ffebad_finish ();
10788                 }
10789               else
10790                 {
10791                   ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
10792                   ffebad_here (0, ffelex_token_where_line
10793                                (ffestp_file.read.read_spec[spec1].kw),
10794                                ffelex_token_where_column
10795                                (ffestp_file.read.read_spec[spec1].kw));
10796                   ffebad_finish ();
10797                 }
10798
10799               ffestc_ok_ = FALSE;
10800               return;
10801             }
10802         }
10803     }
10804
10805   if (unit == FFESTV_unitCHAREXPR)
10806     ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
10807   else
10808     ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
10809
10810   ffestd_R909_start (FALSE, unit, format, rec, key);
10811
10812   ffestc_ok_ = TRUE;
10813 }
10814
10815 /* ffestc_R909_item -- READ statement i/o item
10816
10817    ffestc_R909_item(expr,expr_token);
10818
10819    Implement output-list expression.  */
10820
10821 void
10822 ffestc_R909_item (ffebld expr, ffelexToken expr_token)
10823 {
10824   ffestc_check_item_ ();
10825   if (!ffestc_ok_)
10826     return;
10827
10828   if (ffestc_namelist_ != 0)
10829     {
10830       if (ffestc_namelist_ == 1)
10831         {
10832           ffestc_namelist_ = 2;
10833           ffebad_start (FFEBAD_NAMELIST_ITEMS);
10834           ffebad_here (0, ffelex_token_where_line (expr_token),
10835                        ffelex_token_where_column (expr_token));
10836           ffebad_finish ();
10837         }
10838       return;
10839     }
10840
10841   ffestd_R909_item (expr, expr_token);
10842 }
10843
10844 /* ffestc_R909_finish -- READ statement list complete
10845
10846    ffestc_R909_finish();
10847
10848    Just wrap up any local activities.  */
10849
10850 void
10851 ffestc_R909_finish ()
10852 {
10853   ffestc_check_finish_ ();
10854   if (!ffestc_ok_)
10855     return;
10856
10857   ffestd_R909_finish ();
10858
10859   if (ffestc_shriek_after1_ != NULL)
10860     (*ffestc_shriek_after1_) (TRUE);
10861   ffestc_labeldef_branch_end_ ();
10862 }
10863
10864 /* ffestc_R910_start -- WRITE(...) statement list begin
10865
10866    ffestc_R910_start();
10867
10868    Verify that WRITE is valid here, and begin accepting items in the
10869    list.  */
10870
10871 void
10872 ffestc_R910_start ()
10873 {
10874   ffestvUnit unit;
10875   ffestvFormat format;
10876   bool rec;
10877   ffestpWriteIx spec1;
10878   ffestpWriteIx spec2;
10879
10880   ffestc_check_start_ ();
10881   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10882     {
10883       ffestc_ok_ = FALSE;
10884       return;
10885     }
10886   ffestc_labeldef_branch_begin_ ();
10887
10888   if (!ffestc_subr_is_branch_
10889       (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
10890       || !ffestc_subr_is_branch_
10891       (&ffestp_file.write.write_spec[FFESTP_writeixERR])
10892       || !ffestc_subr_is_format_
10893       (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
10894     {
10895       ffestc_ok_ = FALSE;
10896       return;
10897     }
10898
10899   format = ffestc_subr_format_
10900     (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
10901   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10902
10903   unit = ffestc_subr_unit_
10904     (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
10905   if (unit == FFESTV_unitNONE)
10906     {
10907       ffebad_start (FFEBAD_NO_UNIT_SPEC);
10908       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10909                    ffelex_token_where_column (ffesta_tokens[0]));
10910       ffebad_finish ();
10911       ffestc_ok_ = FALSE;
10912       return;
10913     }
10914
10915   rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
10916
10917   if (rec)
10918     {
10919       spec1 = FFESTP_writeixREC;
10920       if (unit == FFESTV_unitCHAREXPR)
10921         {
10922           spec2 = FFESTP_writeixUNIT;
10923         whine:                  /* :::::::::::::::::::: */
10924           ffebad_start (FFEBAD_CONFLICTING_SPECS);
10925           assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
10926           if (ffestp_file.write.write_spec[spec1].kw_present)
10927             {
10928               ffebad_here (0, ffelex_token_where_line
10929                            (ffestp_file.write.write_spec[spec1].kw),
10930                            ffelex_token_where_column
10931                            (ffestp_file.write.write_spec[spec1].kw));
10932             }
10933           else
10934             {
10935               ffebad_here (0, ffelex_token_where_line
10936                            (ffestp_file.write.write_spec[spec1].value),
10937                            ffelex_token_where_column
10938                            (ffestp_file.write.write_spec[spec1].value));
10939             }
10940           assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
10941           if (ffestp_file.write.write_spec[spec2].kw_present)
10942             {
10943               ffebad_here (1, ffelex_token_where_line
10944                            (ffestp_file.write.write_spec[spec2].kw),
10945                            ffelex_token_where_column
10946                            (ffestp_file.write.write_spec[spec2].kw));
10947             }
10948           else
10949             {
10950               ffebad_here (1, ffelex_token_where_line
10951                            (ffestp_file.write.write_spec[spec2].value),
10952                            ffelex_token_where_column
10953                            (ffestp_file.write.write_spec[spec2].value));
10954             }
10955           ffebad_finish ();
10956           ffestc_ok_ = FALSE;
10957           return;
10958         }
10959       if ((format == FFESTV_formatASTERISK)
10960           || (format == FFESTV_formatNAMELIST))
10961         {
10962           spec2 = FFESTP_writeixFORMAT;
10963           goto whine;           /* :::::::::::::::::::: */
10964         }
10965       if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10966         {
10967           spec2 = FFESTP_writeixADVANCE;
10968           goto whine;           /* :::::::::::::::::::: */
10969         }
10970     }
10971   else
10972     {                           /* Sequential/Indexed/Internal. */
10973       if (unit == FFESTV_unitCHAREXPR)
10974         {                       /* Internal file. */
10975           spec1 = FFESTP_writeixUNIT;
10976           if (format == FFESTV_formatNAMELIST)
10977             {
10978               spec2 = FFESTP_writeixFORMAT;
10979               goto whine;       /* :::::::::::::::::::: */
10980             }
10981           if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10982             {
10983               spec2 = FFESTP_writeixADVANCE;
10984               goto whine;       /* :::::::::::::::::::: */
10985             }
10986         }
10987       if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10988         {                       /* ADVANCE= specified. */
10989           spec1 = FFESTP_writeixADVANCE;
10990           if (format == FFESTV_formatNONE)
10991             {
10992               ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10993               ffebad_here (0, ffelex_token_where_line
10994                            (ffestp_file.write.write_spec[spec1].kw),
10995                            ffelex_token_where_column
10996                            (ffestp_file.write.write_spec[spec1].kw));
10997               ffebad_finish ();
10998
10999               ffestc_ok_ = FALSE;
11000               return;
11001             }
11002           if (format == FFESTV_formatNAMELIST)
11003             {
11004               spec2 = FFESTP_writeixFORMAT;
11005               goto whine;       /* :::::::::::::::::::: */
11006             }
11007         }
11008       if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
11009         {                       /* EOR= specified. */
11010           spec1 = FFESTP_writeixEOR;
11011           if (ffestc_subr_speccmp_ ("No",
11012                        &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
11013                                     NULL, NULL) != 0)
11014             {
11015               if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
11016                   .kw_or_val_present)
11017                 {
11018                   ffebad_start (FFEBAD_CONFLICTING_SPECS);
11019                   ffebad_here (0, ffelex_token_where_line
11020                                (ffestp_file.write.write_spec[spec1].kw),
11021                                ffelex_token_where_column
11022                                (ffestp_file.write.write_spec[spec1].kw));
11023                   ffebad_here (1, ffelex_token_where_line
11024                    (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
11025                                ffelex_token_where_column
11026                   (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
11027                   ffebad_finish ();
11028                 }
11029               else
11030                 {
11031                   ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
11032                   ffebad_here (0, ffelex_token_where_line
11033                                (ffestp_file.write.write_spec[spec1].kw),
11034                                ffelex_token_where_column
11035                                (ffestp_file.write.write_spec[spec1].kw));
11036                   ffebad_finish ();
11037                 }
11038
11039               ffestc_ok_ = FALSE;
11040               return;
11041             }
11042         }
11043     }
11044
11045   if (unit == FFESTV_unitCHAREXPR)
11046     ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
11047   else
11048     ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
11049
11050   ffestd_R910_start (unit, format, rec);
11051
11052   ffestc_ok_ = TRUE;
11053 }
11054
11055 /* ffestc_R910_item -- WRITE statement i/o item
11056
11057    ffestc_R910_item(expr,expr_token);
11058
11059    Implement output-list expression.  */
11060
11061 void
11062 ffestc_R910_item (ffebld expr, ffelexToken expr_token)
11063 {
11064   ffestc_check_item_ ();
11065   if (!ffestc_ok_)
11066     return;
11067
11068   if (ffestc_namelist_ != 0)
11069     {
11070       if (ffestc_namelist_ == 1)
11071         {
11072           ffestc_namelist_ = 2;
11073           ffebad_start (FFEBAD_NAMELIST_ITEMS);
11074           ffebad_here (0, ffelex_token_where_line (expr_token),
11075                        ffelex_token_where_column (expr_token));
11076           ffebad_finish ();
11077         }
11078       return;
11079     }
11080
11081   ffestd_R910_item (expr, expr_token);
11082 }
11083
11084 /* ffestc_R910_finish -- WRITE statement list complete
11085
11086    ffestc_R910_finish();
11087
11088    Just wrap up any local activities.  */
11089
11090 void
11091 ffestc_R910_finish ()
11092 {
11093   ffestc_check_finish_ ();
11094   if (!ffestc_ok_)
11095     return;
11096
11097   ffestd_R910_finish ();
11098
11099   if (ffestc_shriek_after1_ != NULL)
11100     (*ffestc_shriek_after1_) (TRUE);
11101   ffestc_labeldef_branch_end_ ();
11102 }
11103
11104 /* ffestc_R911_start -- PRINT(...) statement list begin
11105
11106    ffestc_R911_start();
11107
11108    Verify that PRINT is valid here, and begin accepting items in the
11109    list.  */
11110
11111 void
11112 ffestc_R911_start ()
11113 {
11114   ffestvFormat format;
11115
11116   ffestc_check_start_ ();
11117   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11118     {
11119       ffestc_ok_ = FALSE;
11120       return;
11121     }
11122   ffestc_labeldef_branch_begin_ ();
11123
11124   if (!ffestc_subr_is_format_
11125       (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
11126     {
11127       ffestc_ok_ = FALSE;
11128       return;
11129     }
11130
11131   format = ffestc_subr_format_
11132     (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
11133   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
11134
11135   ffestd_R911_start (format);
11136
11137   ffestc_ok_ = TRUE;
11138 }
11139
11140 /* ffestc_R911_item -- PRINT statement i/o item
11141
11142    ffestc_R911_item(expr,expr_token);
11143
11144    Implement output-list expression.  */
11145
11146 void
11147 ffestc_R911_item (ffebld expr, ffelexToken expr_token)
11148 {
11149   ffestc_check_item_ ();
11150   if (!ffestc_ok_)
11151     return;
11152
11153   if (ffestc_namelist_ != 0)
11154     {
11155       if (ffestc_namelist_ == 1)
11156         {
11157           ffestc_namelist_ = 2;
11158           ffebad_start (FFEBAD_NAMELIST_ITEMS);
11159           ffebad_here (0, ffelex_token_where_line (expr_token),
11160                        ffelex_token_where_column (expr_token));
11161           ffebad_finish ();
11162         }
11163       return;
11164     }
11165
11166   ffestd_R911_item (expr, expr_token);
11167 }
11168
11169 /* ffestc_R911_finish -- PRINT statement list complete
11170
11171    ffestc_R911_finish();
11172
11173    Just wrap up any local activities.  */
11174
11175 void
11176 ffestc_R911_finish ()
11177 {
11178   ffestc_check_finish_ ();
11179   if (!ffestc_ok_)
11180     return;
11181
11182   ffestd_R911_finish ();
11183
11184   if (ffestc_shriek_after1_ != NULL)
11185     (*ffestc_shriek_after1_) (TRUE);
11186   ffestc_labeldef_branch_end_ ();
11187 }
11188
11189 /* ffestc_R919 -- BACKSPACE statement
11190
11191    ffestc_R919();
11192
11193    Make sure a BACKSPACE is valid in the current context, and implement it.  */
11194
11195 void
11196 ffestc_R919 ()
11197 {
11198   ffestc_check_simple_ ();
11199   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11200     return;
11201   ffestc_labeldef_branch_begin_ ();
11202
11203   if (ffestc_subr_is_branch_
11204       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11205       && ffestc_subr_is_present_ ("UNIT",
11206                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11207     ffestd_R919 ();
11208
11209   if (ffestc_shriek_after1_ != NULL)
11210     (*ffestc_shriek_after1_) (TRUE);
11211   ffestc_labeldef_branch_end_ ();
11212 }
11213
11214 /* ffestc_R920 -- ENDFILE statement
11215
11216    ffestc_R920();
11217
11218    Make sure a ENDFILE is valid in the current context, and implement it.  */
11219
11220 void
11221 ffestc_R920 ()
11222 {
11223   ffestc_check_simple_ ();
11224   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11225     return;
11226   ffestc_labeldef_branch_begin_ ();
11227
11228   if (ffestc_subr_is_branch_
11229       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11230       && ffestc_subr_is_present_ ("UNIT",
11231                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11232     ffestd_R920 ();
11233
11234   if (ffestc_shriek_after1_ != NULL)
11235     (*ffestc_shriek_after1_) (TRUE);
11236   ffestc_labeldef_branch_end_ ();
11237 }
11238
11239 /* ffestc_R921 -- REWIND statement
11240
11241    ffestc_R921();
11242
11243    Make sure a REWIND is valid in the current context, and implement it.  */
11244
11245 void
11246 ffestc_R921 ()
11247 {
11248   ffestc_check_simple_ ();
11249   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11250     return;
11251   ffestc_labeldef_branch_begin_ ();
11252
11253   if (ffestc_subr_is_branch_
11254       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11255       && ffestc_subr_is_present_ ("UNIT",
11256                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11257     ffestd_R921 ();
11258
11259   if (ffestc_shriek_after1_ != NULL)
11260     (*ffestc_shriek_after1_) (TRUE);
11261   ffestc_labeldef_branch_end_ ();
11262 }
11263
11264 /* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
11265
11266    ffestc_R923A();
11267
11268    Make sure an INQUIRE is valid in the current context, and implement it.  */
11269
11270 void
11271 ffestc_R923A ()
11272 {
11273   bool by_file;
11274   bool by_unit;
11275
11276   ffestc_check_simple_ ();
11277   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11278     return;
11279   ffestc_labeldef_branch_begin_ ();
11280
11281   if (ffestc_subr_is_branch_
11282       (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
11283     {
11284       by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
11285         .kw_or_val_present;
11286       by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
11287         .kw_or_val_present;
11288       if (by_file && by_unit)
11289         {
11290           ffebad_start (FFEBAD_CONFLICTING_SPECS);
11291           assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
11292           if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
11293             {
11294               ffebad_here (0, ffelex_token_where_line
11295                 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
11296                            ffelex_token_where_column
11297                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
11298             }
11299           else
11300             {
11301               ffebad_here (0, ffelex_token_where_line
11302               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
11303                            ffelex_token_where_column
11304                            (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
11305             }
11306           assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
11307           if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
11308             {
11309               ffebad_here (1, ffelex_token_where_line
11310                 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
11311                            ffelex_token_where_column
11312                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
11313             }
11314           else
11315             {
11316               ffebad_here (1, ffelex_token_where_line
11317               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
11318                            ffelex_token_where_column
11319                            (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
11320             }
11321           ffebad_finish ();
11322         }
11323       else if (!by_file && !by_unit)
11324         {
11325           ffebad_start (FFEBAD_MISSING_SPECIFIER);
11326           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11327                        ffelex_token_where_column (ffesta_tokens[0]));
11328           ffebad_string ("UNIT= or FILE=");
11329           ffebad_finish ();
11330         }
11331       else
11332         ffestd_R923A (by_file);
11333     }
11334
11335   if (ffestc_shriek_after1_ != NULL)
11336     (*ffestc_shriek_after1_) (TRUE);
11337   ffestc_labeldef_branch_end_ ();
11338 }
11339
11340 /* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
11341
11342    ffestc_R923B_start();
11343
11344    Verify that INQUIRE is valid here, and begin accepting items in the
11345    list.  */
11346
11347 void
11348 ffestc_R923B_start ()
11349 {
11350   ffestc_check_start_ ();
11351   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11352     {
11353       ffestc_ok_ = FALSE;
11354       return;
11355     }
11356   ffestc_labeldef_branch_begin_ ();
11357
11358   ffestd_R923B_start ();
11359
11360   ffestc_ok_ = TRUE;
11361 }
11362
11363 /* ffestc_R923B_item -- INQUIRE statement i/o item
11364
11365    ffestc_R923B_item(expr,expr_token);
11366
11367    Implement output-list expression.  */
11368
11369 void
11370 ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
11371 {
11372   ffestc_check_item_ ();
11373   if (!ffestc_ok_)
11374     return;
11375
11376   ffestd_R923B_item (expr);
11377 }
11378
11379 /* ffestc_R923B_finish -- INQUIRE statement list complete
11380
11381    ffestc_R923B_finish();
11382
11383    Just wrap up any local activities.  */
11384
11385 void
11386 ffestc_R923B_finish ()
11387 {
11388   ffestc_check_finish_ ();
11389   if (!ffestc_ok_)
11390     return;
11391
11392   ffestd_R923B_finish ();
11393
11394   if (ffestc_shriek_after1_ != NULL)
11395     (*ffestc_shriek_after1_) (TRUE);
11396   ffestc_labeldef_branch_end_ ();
11397 }
11398
11399 /* ffestc_R1001 -- FORMAT statement
11400
11401    ffestc_R1001(format_list);
11402
11403    Make sure format_list is valid.  Update label's info to indicate it is a
11404    FORMAT label, and (perhaps) warn if there is no label!  */
11405
11406 void
11407 ffestc_R1001 (ffesttFormatList f)
11408 {
11409   ffestc_check_simple_ ();
11410   if (ffestc_order_format_ () != FFESTC_orderOK_)
11411     return;
11412   ffestc_labeldef_format_ ();
11413
11414   ffestd_R1001 (f);
11415 }
11416
11417 /* ffestc_R1102 -- PROGRAM statement
11418
11419    ffestc_R1102(name_token);
11420
11421    Make sure ffestc_kind_ identifies an empty block.  Make sure name_token
11422    gives a valid name.  Implement the beginning of a main program.  */
11423
11424 void
11425 ffestc_R1102 (ffelexToken name)
11426 {
11427   ffestw b;
11428   ffesymbol s;
11429
11430   assert (name != NULL);
11431
11432   ffestc_check_simple_ ();
11433   if (ffestc_order_unit_ () != FFESTC_orderOK_)
11434     return;
11435   ffestc_labeldef_useless_ ();
11436
11437   ffestc_blocknum_ = 0;
11438   b = ffestw_update (ffestw_push (NULL));
11439   ffestw_set_top_do (b, NULL);
11440   ffestw_set_state (b, FFESTV_statePROGRAM0);
11441   ffestw_set_blocknum (b, ffestc_blocknum_++);
11442   ffestw_set_shriek (b, ffestc_shriek_end_program_);
11443
11444   ffestw_set_name (b, ffelex_token_use (name));
11445
11446   s = ffesymbol_declare_programunit (name,
11447                                  ffelex_token_where_line (ffesta_tokens[0]),
11448                               ffelex_token_where_column (ffesta_tokens[0]));
11449
11450   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11451     {
11452       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11453       ffesymbol_set_info (s,
11454                           ffeinfo_new (FFEINFO_basictypeNONE,
11455                                        FFEINFO_kindtypeNONE,
11456                                        0,
11457                                        FFEINFO_kindPROGRAM,
11458                                        FFEINFO_whereLOCAL,
11459                                        FFETARGET_charactersizeNONE));
11460       ffesymbol_signal_unreported (s);
11461     }
11462   else
11463     ffesymbol_error (s, name);
11464
11465   ffestd_R1102 (s, name);
11466 }
11467
11468 /* ffestc_R1103 -- END PROGRAM statement
11469
11470    ffestc_R1103(name_token);
11471
11472    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
11473    NULL, make sure name_token gives the correct name.  Implement the end
11474    of the current program unit.  */
11475
11476 void
11477 ffestc_R1103 (ffelexToken name)
11478 {
11479   ffestc_check_simple_ ();
11480   if (ffestc_order_program_ () != FFESTC_orderOK_)
11481     return;
11482   ffestc_labeldef_notloop_ ();
11483
11484   if (name != NULL)
11485     {
11486       if (ffestw_name (ffestw_stack_top ()) == NULL)
11487         {
11488           ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
11489           ffebad_here (0, ffelex_token_where_line (name),
11490                        ffelex_token_where_column (name));
11491           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11492           ffebad_finish ();
11493         }
11494       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11495         {
11496           ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11497           ffebad_here (0, ffelex_token_where_line (name),
11498                        ffelex_token_where_column (name));
11499           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11500              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11501           ffebad_finish ();
11502         }
11503     }
11504
11505   ffestc_shriek_end_program_ (TRUE);
11506 }
11507
11508 /* ffestc_R1105 -- MODULE statement
11509
11510    ffestc_R1105(name_token);
11511
11512    Make sure ffestc_kind_ identifies an empty block.  Make sure name_token
11513    gives a valid name.  Implement the beginning of a module.  */
11514
11515 #if FFESTR_F90
11516 void
11517 ffestc_R1105 (ffelexToken name)
11518 {
11519   ffestw b;
11520
11521   assert (name != NULL);
11522
11523   ffestc_check_simple_ ();
11524   if (ffestc_order_unit_ () != FFESTC_orderOK_)
11525     return;
11526   ffestc_labeldef_useless_ ();
11527
11528   ffestc_blocknum_ = 0;
11529   b = ffestw_update (ffestw_push (NULL));
11530   ffestw_set_top_do (b, NULL);
11531   ffestw_set_state (b, FFESTV_stateMODULE0);
11532   ffestw_set_blocknum (b, ffestc_blocknum_++);
11533   ffestw_set_shriek (b, ffestc_shriek_module_);
11534   ffestw_set_name (b, ffelex_token_use (name));
11535
11536   ffestd_R1105 (name);
11537 }
11538
11539 /* ffestc_R1106 -- END MODULE statement
11540
11541    ffestc_R1106(name_token);
11542
11543    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
11544    NULL, make sure name_token gives the correct name.  Implement the end
11545    of the current program unit.  */
11546
11547 void
11548 ffestc_R1106 (ffelexToken name)
11549 {
11550   ffestc_check_simple_ ();
11551   if (ffestc_order_module_ () != FFESTC_orderOK_)
11552     return;
11553   ffestc_labeldef_useless_ ();
11554
11555   if ((name != NULL)
11556       && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
11557     {
11558       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11559       ffebad_here (0, ffelex_token_where_line (name),
11560                    ffelex_token_where_column (name));
11561       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11562              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11563       ffebad_finish ();
11564     }
11565
11566   ffestc_shriek_module_ (TRUE);
11567 }
11568
11569 /* ffestc_R1107_start -- USE statement list begin
11570
11571    ffestc_R1107_start();
11572
11573    Verify that USE is valid here, and begin accepting items in the list.  */
11574
11575 void
11576 ffestc_R1107_start (ffelexToken name, bool only)
11577 {
11578   ffestc_check_start_ ();
11579   if (ffestc_order_use_ () != FFESTC_orderOK_)
11580     {
11581       ffestc_ok_ = FALSE;
11582       return;
11583     }
11584   ffestc_labeldef_useless_ ();
11585
11586   ffestd_R1107_start (name, only);
11587
11588   ffestc_ok_ = TRUE;
11589 }
11590
11591 /* ffestc_R1107_item -- USE statement for name
11592
11593    ffestc_R1107_item(local_token,use_token);
11594
11595    Make sure name_token identifies a valid object to be USEed.  local_token
11596    may be NULL if _start_ was called with only==TRUE.  */
11597
11598 void
11599 ffestc_R1107_item (ffelexToken local, ffelexToken use)
11600 {
11601   ffestc_check_item_ ();
11602   assert (use != NULL);
11603   if (!ffestc_ok_)
11604     return;
11605
11606   ffestd_R1107_item (local, use);
11607 }
11608
11609 /* ffestc_R1107_finish -- USE statement list complete
11610
11611    ffestc_R1107_finish();
11612
11613    Just wrap up any local activities.  */
11614
11615 void
11616 ffestc_R1107_finish ()
11617 {
11618   ffestc_check_finish_ ();
11619   if (!ffestc_ok_)
11620     return;
11621
11622   ffestd_R1107_finish ();
11623 }
11624
11625 #endif
11626 /* ffestc_R1111 -- BLOCK DATA statement
11627
11628    ffestc_R1111(name_token);
11629
11630    Make sure ffestc_kind_ identifies no current program unit.  If not
11631    NULL, make sure name_token gives a valid name.  Implement the beginning
11632    of a block data program unit.  */
11633
11634 void
11635 ffestc_R1111 (ffelexToken name)
11636 {
11637   ffestw b;
11638   ffesymbol s;
11639
11640   ffestc_check_simple_ ();
11641   if (ffestc_order_unit_ () != FFESTC_orderOK_)
11642     return;
11643   ffestc_labeldef_useless_ ();
11644
11645   ffestc_blocknum_ = 0;
11646   b = ffestw_update (ffestw_push (NULL));
11647   ffestw_set_top_do (b, NULL);
11648   ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
11649   ffestw_set_blocknum (b, ffestc_blocknum_++);
11650   ffestw_set_shriek (b, ffestc_shriek_blockdata_);
11651
11652   if (name == NULL)
11653     ffestw_set_name (b, NULL);
11654   else
11655     ffestw_set_name (b, ffelex_token_use (name));
11656
11657   s = ffesymbol_declare_blockdataunit (name,
11658                                  ffelex_token_where_line (ffesta_tokens[0]),
11659                               ffelex_token_where_column (ffesta_tokens[0]));
11660
11661   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11662     {
11663       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11664       ffesymbol_set_info (s,
11665                           ffeinfo_new (FFEINFO_basictypeNONE,
11666                                        FFEINFO_kindtypeNONE,
11667                                        0,
11668                                        FFEINFO_kindBLOCKDATA,
11669                                        FFEINFO_whereLOCAL,
11670                                        FFETARGET_charactersizeNONE));
11671       ffesymbol_signal_unreported (s);
11672     }
11673   else
11674     ffesymbol_error (s, name);
11675
11676   ffestd_R1111 (s, name);
11677 }
11678
11679 /* ffestc_R1112 -- END BLOCK DATA statement
11680
11681    ffestc_R1112(name_token);
11682
11683    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
11684    NULL, make sure name_token gives the correct name.  Implement the end
11685    of the current program unit.  */
11686
11687 void
11688 ffestc_R1112 (ffelexToken name)
11689 {
11690   ffestc_check_simple_ ();
11691   if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
11692     return;
11693   ffestc_labeldef_useless_ ();
11694
11695   if (name != NULL)
11696     {
11697       if (ffestw_name (ffestw_stack_top ()) == NULL)
11698         {
11699           ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
11700           ffebad_here (0, ffelex_token_where_line (name),
11701                        ffelex_token_where_column (name));
11702           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11703           ffebad_finish ();
11704         }
11705       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11706         {
11707           ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11708           ffebad_here (0, ffelex_token_where_line (name),
11709                        ffelex_token_where_column (name));
11710           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11711              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11712           ffebad_finish ();
11713         }
11714     }
11715
11716   ffestc_shriek_blockdata_ (TRUE);
11717 }
11718
11719 /* ffestc_R1202 -- INTERFACE statement
11720
11721    ffestc_R1202(operator,defined_name);
11722
11723    Make sure ffestc_kind_ identifies an INTERFACE block.
11724    Implement the end of the current interface.
11725
11726    15-May-90  JCB  1.1
11727       Allow no operator or name to mean INTERFACE by itself; missed this
11728       valid form when originally doing syntactic analysis code.  */
11729
11730 #if FFESTR_F90
11731 void
11732 ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name)
11733 {
11734   ffestw b;
11735
11736   ffestc_check_simple_ ();
11737   if (ffestc_order_interfacespec_ () != FFESTC_orderOK_)
11738     return;
11739   ffestc_labeldef_useless_ ();
11740
11741   b = ffestw_update (ffestw_push (NULL));
11742   ffestw_set_top_do (b, NULL);
11743   ffestw_set_state (b, FFESTV_stateINTERFACE0);
11744   ffestw_set_blocknum (b, 0);
11745   ffestw_set_shriek (b, ffestc_shriek_interface_);
11746
11747   if ((operator == FFESTP_definedoperatorNone) && (name == NULL))
11748     ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE
11749                                    PROCEDURE. */
11750   else
11751     ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */
11752
11753   ffestd_R1202 (operator, name);
11754
11755   ffe_init_4 ();
11756 }
11757
11758 /* ffestc_R1203 -- END INTERFACE statement
11759
11760    ffestc_R1203();
11761
11762    Make sure ffestc_kind_ identifies an INTERFACE block.
11763    Implement the end of the current interface.  */
11764
11765 void
11766 ffestc_R1203 ()
11767 {
11768   ffestc_check_simple_ ();
11769   if (ffestc_order_interface_ () != FFESTC_orderOK_)
11770     return;
11771   ffestc_labeldef_useless_ ();
11772
11773   ffestc_shriek_interface_ (TRUE);
11774
11775   ffe_terminate_4 ();
11776 }
11777
11778 /* ffestc_R1205_start -- MODULE PROCEDURE statement list begin
11779
11780    ffestc_R1205_start();
11781
11782    Verify that MODULE PROCEDURE is valid here, and begin accepting items in
11783    the list.  */
11784
11785 void
11786 ffestc_R1205_start ()
11787 {
11788   ffestc_check_start_ ();
11789   if (ffestc_order_interface_ () != FFESTC_orderOK_)
11790     {
11791       ffestc_ok_ = FALSE;
11792       return;
11793     }
11794   ffestc_labeldef_useless_ ();
11795
11796   if (ffestw_substate (ffestw_stack_top ()) == 0)
11797     {
11798       ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE);
11799       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11800                    ffelex_token_where_column (ffesta_tokens[0]));
11801       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11802       ffebad_finish ();
11803       ffestc_ok_ = FALSE;
11804       return;
11805     }
11806
11807   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0)
11808     {
11809       ffestw_update (NULL);     /* Update state line/col info. */
11810       ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1);
11811     }
11812
11813   ffestd_R1205_start ();
11814
11815   ffestc_ok_ = TRUE;
11816 }
11817
11818 /* ffestc_R1205_item -- MODULE PROCEDURE statement for name
11819
11820    ffestc_R1205_item(name_token);
11821
11822    Make sure name_token identifies a valid object to be MODULE PROCEDUREed.  */
11823
11824 void
11825 ffestc_R1205_item (ffelexToken name)
11826 {
11827   ffestc_check_item_ ();
11828   assert (name != NULL);
11829   if (!ffestc_ok_)
11830     return;
11831
11832   ffestd_R1205_item (name);
11833 }
11834
11835 /* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete
11836
11837    ffestc_R1205_finish();
11838
11839    Just wrap up any local activities.  */
11840
11841 void
11842 ffestc_R1205_finish ()
11843 {
11844   ffestc_check_finish_ ();
11845   if (!ffestc_ok_)
11846     return;
11847
11848   ffestd_R1205_finish ();
11849 }
11850
11851 #endif
11852 /* ffestc_R1207_start -- EXTERNAL statement list begin
11853
11854    ffestc_R1207_start();
11855
11856    Verify that EXTERNAL is valid here, and begin accepting items in the list.  */
11857
11858 void
11859 ffestc_R1207_start ()
11860 {
11861   ffestc_check_start_ ();
11862   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11863     {
11864       ffestc_ok_ = FALSE;
11865       return;
11866     }
11867   ffestc_labeldef_useless_ ();
11868
11869   ffestd_R1207_start ();
11870
11871   ffestc_ok_ = TRUE;
11872 }
11873
11874 /* ffestc_R1207_item -- EXTERNAL statement for name
11875
11876    ffestc_R1207_item(name_token);
11877
11878    Make sure name_token identifies a valid object to be EXTERNALd.  */
11879
11880 void
11881 ffestc_R1207_item (ffelexToken name)
11882 {
11883   ffesymbol s;
11884   ffesymbolAttrs sa;
11885   ffesymbolAttrs na;
11886
11887   ffestc_check_item_ ();
11888   assert (name != NULL);
11889   if (!ffestc_ok_)
11890     return;
11891
11892   s = ffesymbol_declare_local (name, FALSE);
11893   sa = ffesymbol_attrs (s);
11894
11895   /* Figure out what kind of object we've got based on previous declarations
11896      of or references to the object. */
11897
11898   if (!ffesymbol_is_specable (s))
11899     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11900   else if (sa & FFESYMBOL_attrsANY)
11901     na = FFESYMBOL_attrsANY;
11902   else if (!(sa & ~(FFESYMBOL_attrsDUMMY
11903                     | FFESYMBOL_attrsTYPE)))
11904     na = sa | FFESYMBOL_attrsEXTERNAL;
11905   else
11906     na = FFESYMBOL_attrsetNONE;
11907
11908   /* Now see what we've got for a new object: NONE means a new error cropped
11909      up; ANY means an old error to be ignored; otherwise, everything's ok,
11910      update the object (symbol) and continue on. */
11911
11912   if (na == FFESYMBOL_attrsetNONE)
11913     ffesymbol_error (s, name);
11914   else if (!(na & FFESYMBOL_attrsANY))
11915     {
11916       ffesymbol_set_attrs (s, na);
11917       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
11918       ffesymbol_set_explicitwhere (s, TRUE);
11919       ffesymbol_reference (s, name, FALSE);
11920       ffesymbol_signal_unreported (s);
11921     }
11922
11923   ffestd_R1207_item (name);
11924 }
11925
11926 /* ffestc_R1207_finish -- EXTERNAL statement list complete
11927
11928    ffestc_R1207_finish();
11929
11930    Just wrap up any local activities.  */
11931
11932 void
11933 ffestc_R1207_finish ()
11934 {
11935   ffestc_check_finish_ ();
11936   if (!ffestc_ok_)
11937     return;
11938
11939   ffestd_R1207_finish ();
11940 }
11941
11942 /* ffestc_R1208_start -- INTRINSIC statement list begin
11943
11944    ffestc_R1208_start();
11945
11946    Verify that INTRINSIC is valid here, and begin accepting items in the list.  */
11947
11948 void
11949 ffestc_R1208_start ()
11950 {
11951   ffestc_check_start_ ();
11952   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11953     {
11954       ffestc_ok_ = FALSE;
11955       return;
11956     }
11957   ffestc_labeldef_useless_ ();
11958
11959   ffestd_R1208_start ();
11960
11961   ffestc_ok_ = TRUE;
11962 }
11963
11964 /* ffestc_R1208_item -- INTRINSIC statement for name
11965
11966    ffestc_R1208_item(name_token);
11967
11968    Make sure name_token identifies a valid object to be INTRINSICd.  */
11969
11970 void
11971 ffestc_R1208_item (ffelexToken name)
11972 {
11973   ffesymbol s;
11974   ffesymbolAttrs sa;
11975   ffesymbolAttrs na;
11976   ffeintrinGen gen;
11977   ffeintrinSpec spec;
11978   ffeintrinImp imp;
11979
11980   ffestc_check_item_ ();
11981   assert (name != NULL);
11982   if (!ffestc_ok_)
11983     return;
11984
11985   s = ffesymbol_declare_local (name, TRUE);
11986   sa = ffesymbol_attrs (s);
11987
11988   /* Figure out what kind of object we've got based on previous declarations
11989      of or references to the object. */
11990
11991   if (!ffesymbol_is_specable (s))
11992     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11993   else if (sa & FFESYMBOL_attrsANY)
11994     na = sa;
11995   else if (!(sa & ~FFESYMBOL_attrsTYPE))
11996     {
11997       if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
11998                                   &gen, &spec, &imp)
11999           && ((imp == FFEINTRIN_impNONE)
12000 #if 0   /* Don't bother with this for now. */
12001               || ((ffeintrin_basictype (spec)
12002                    == ffesymbol_basictype (s))
12003                   && (ffeintrin_kindtype (spec)
12004                       == ffesymbol_kindtype (s)))
12005 #else
12006               || 1
12007 #endif
12008               || !(sa & FFESYMBOL_attrsTYPE)))
12009         na = sa | FFESYMBOL_attrsINTRINSIC;
12010       else
12011         na = FFESYMBOL_attrsetNONE;
12012     }
12013   else
12014     na = FFESYMBOL_attrsetNONE;
12015
12016   /* Now see what we've got for a new object: NONE means a new error cropped
12017      up; ANY means an old error to be ignored; otherwise, everything's ok,
12018      update the object (symbol) and continue on. */
12019
12020   if (na == FFESYMBOL_attrsetNONE)
12021     ffesymbol_error (s, name);
12022   else if (!(na & FFESYMBOL_attrsANY))
12023     {
12024       ffesymbol_set_attrs (s, na);
12025       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12026       ffesymbol_set_generic (s, gen);
12027       ffesymbol_set_specific (s, spec);
12028       ffesymbol_set_implementation (s, imp);
12029       ffesymbol_set_info (s,
12030                           ffeinfo_new (ffesymbol_basictype (s),
12031                                        ffesymbol_kindtype (s),
12032                                        0,
12033                                        FFEINFO_kindNONE,
12034                                        FFEINFO_whereINTRINSIC,
12035                                        ffesymbol_size (s)));
12036       ffesymbol_set_explicitwhere (s, TRUE);
12037       ffesymbol_reference (s, name, TRUE);
12038     }
12039
12040   ffesymbol_signal_unreported (s);
12041
12042   ffestd_R1208_item (name);
12043 }
12044
12045 /* ffestc_R1208_finish -- INTRINSIC statement list complete
12046
12047    ffestc_R1208_finish();
12048
12049    Just wrap up any local activities.  */
12050
12051 void
12052 ffestc_R1208_finish ()
12053 {
12054   ffestc_check_finish_ ();
12055   if (!ffestc_ok_)
12056     return;
12057
12058   ffestd_R1208_finish ();
12059 }
12060
12061 /* ffestc_R1212 -- CALL statement
12062
12063    ffestc_R1212(expr,expr_token);
12064
12065    Make sure statement is valid here; implement.  */
12066
12067 void
12068 ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
12069 {
12070   ffebld item;                  /* ITEM. */
12071   ffebld labexpr;               /* LABTOK=>LABTER. */
12072   ffelab label;
12073   bool ok;                      /* TRUE if all LABTOKs were ok. */
12074   bool ok1;                     /* TRUE if a particular LABTOK is ok. */
12075
12076   ffestc_check_simple_ ();
12077   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12078     return;
12079   ffestc_labeldef_branch_begin_ ();
12080
12081   if (ffebld_op (expr) != FFEBLD_opSUBRREF)
12082     ffestd_R841 (FALSE);        /* CONTINUE. */
12083   else
12084     {
12085       ok = TRUE;
12086
12087       for (item = ffebld_right (expr);
12088            item != NULL;
12089            item = ffebld_trail (item))
12090         {
12091           if (((labexpr = ffebld_head (item)) != NULL)
12092               && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
12093             {
12094               ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
12095                                                 &label);
12096               ffelex_token_kill (ffebld_labtok (labexpr));
12097               if (!ok1)
12098                 {
12099                   label = NULL;
12100                   ok = FALSE;
12101                 }
12102               ffebld_set_op (labexpr, FFEBLD_opLABTER);
12103               ffebld_set_labter (labexpr, label);
12104             }
12105         }
12106
12107       if (ok)
12108         ffestd_R1212 (expr);
12109     }
12110
12111   if (ffestc_shriek_after1_ != NULL)
12112     (*ffestc_shriek_after1_) (TRUE);
12113   ffestc_labeldef_branch_end_ ();
12114 }
12115
12116 /* ffestc_R1213 -- Defined assignment statement
12117
12118    ffestc_R1213(dest_expr,source_expr,source_token);
12119
12120    Make sure the assignment is valid.  */
12121
12122 #if FFESTR_F90
12123 void
12124 ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token)
12125 {
12126   ffestc_check_simple_ ();
12127   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12128     return;
12129   ffestc_labeldef_branch_begin_ ();
12130
12131   ffestd_R1213 (dest, source);
12132
12133   if (ffestc_shriek_after1_ != NULL)
12134     (*ffestc_shriek_after1_) (TRUE);
12135   ffestc_labeldef_branch_end_ ();
12136 }
12137
12138 #endif
12139 /* ffestc_R1219 -- FUNCTION statement
12140
12141    ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
12142          recursive);
12143
12144    Make sure statement is valid here, register arguments for the
12145    function name, and so on.
12146
12147    06-Apr-90  JCB  2.0
12148       Added the kind, len, and recursive arguments.  */
12149
12150 void
12151 ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
12152               ffelexToken final UNUSED, ffestpType type, ffebld kind,
12153               ffelexToken kindt, ffebld len, ffelexToken lent,
12154               ffelexToken recursive, ffelexToken result)
12155 {
12156   ffestw b;
12157   ffesymbol s;
12158   ffesymbol fs;                 /* FUNCTION symbol when dealing with RESULT
12159                                    symbol. */
12160   ffesymbolAttrs sa;
12161   ffesymbolAttrs na;
12162   ffelexToken res;
12163   bool separate_result;
12164
12165   assert ((funcname != NULL)
12166           && (ffelex_token_type (funcname) == FFELEX_typeNAME));
12167
12168   ffestc_check_simple_ ();
12169   if (ffestc_order_iface_ () != FFESTC_orderOK_)
12170     return;
12171   ffestc_labeldef_useless_ ();
12172
12173   ffestc_blocknum_ = 0;
12174   ffesta_is_entry_valid =
12175     (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12176   b = ffestw_update (ffestw_push (NULL));
12177   ffestw_set_top_do (b, NULL);
12178   ffestw_set_state (b, FFESTV_stateFUNCTION0);
12179   ffestw_set_blocknum (b, ffestc_blocknum_++);
12180   ffestw_set_shriek (b, ffestc_shriek_function_);
12181   ffestw_set_name (b, ffelex_token_use (funcname));
12182
12183   if (type == FFESTP_typeNone)
12184     {
12185       ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
12186       ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
12187       ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
12188     }
12189   else
12190     {
12191       ffestc_establish_declstmt_ (type, ffesta_tokens[0],
12192                                   kind, kindt, len, lent);
12193       ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
12194     }
12195
12196   separate_result = (result != NULL)
12197     && (ffelex_token_strcmp (funcname, result) != 0);
12198
12199   if (separate_result)
12200     fs = ffesymbol_declare_funcnotresunit (funcname);   /* Global/local. */
12201   else
12202     fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
12203
12204   if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12205     {
12206       ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12207       ffesymbol_signal_unreported (fs);
12208
12209       /* Note that .basic_type and .kind_type might be NONE here. */
12210
12211       ffesymbol_set_info (fs,
12212                           ffeinfo_new (ffestc_local_.decl.basic_type,
12213                                        ffestc_local_.decl.kind_type,
12214                                        0,
12215                                        FFEINFO_kindFUNCTION,
12216                                        FFEINFO_whereLOCAL,
12217                                        ffestc_local_.decl.size));
12218
12219       /* Check whether the type info fits the filewide expectations;
12220          set ok flag accordingly.  */
12221
12222       ffesymbol_reference (fs, funcname, FALSE);
12223       if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
12224         ffestc_parent_ok_ = FALSE;
12225       else
12226         ffestc_parent_ok_ = TRUE;
12227     }
12228   else
12229     {
12230       if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12231         ffesymbol_error (fs, funcname);
12232       ffestc_parent_ok_ = FALSE;
12233     }
12234
12235   if (ffestc_parent_ok_)
12236     {
12237       ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12238       ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12239       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12240     }
12241
12242   if (result == NULL)
12243     res = funcname;
12244   else
12245     res = result;
12246
12247   s = ffesymbol_declare_funcresult (res);
12248   sa = ffesymbol_attrs (s);
12249
12250   /* Figure out what kind of object we've got based on previous declarations
12251      of or references to the object. */
12252
12253   if (sa & FFESYMBOL_attrsANY)
12254     na = FFESYMBOL_attrsANY;
12255   else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
12256     na = FFESYMBOL_attrsetNONE;
12257   else
12258     {
12259       na = FFESYMBOL_attrsRESULT;
12260       if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12261         {
12262           na |= FFESYMBOL_attrsTYPE;
12263           if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
12264               && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
12265             na |= FFESYMBOL_attrsANYLEN;
12266         }
12267     }
12268
12269   /* Now see what we've got for a new object: NONE means a new error cropped
12270      up; ANY means an old error to be ignored; otherwise, everything's ok,
12271      update the object (symbol) and continue on. */
12272
12273   if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
12274     {
12275       if (!(na & FFESYMBOL_attrsANY))
12276         ffesymbol_error (s, res);
12277       ffesymbol_set_funcresult (fs, NULL);
12278       ffesymbol_set_funcresult (s, NULL);
12279       ffestc_parent_ok_ = FALSE;
12280     }
12281   else
12282     {
12283       ffesymbol_set_attrs (s, na);
12284       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12285       ffesymbol_set_funcresult (fs, s);
12286       ffesymbol_set_funcresult (s, fs);
12287       if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12288         {
12289           ffesymbol_set_info (s,
12290                               ffeinfo_new (ffestc_local_.decl.basic_type,
12291                                            ffestc_local_.decl.kind_type,
12292                                            0,
12293                                            FFEINFO_kindNONE,
12294                                            FFEINFO_whereNONE,
12295                                            ffestc_local_.decl.size));
12296         }
12297     }
12298
12299   ffesymbol_signal_unreported (fs);
12300
12301   ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
12302                 (recursive != NULL), result, separate_result);
12303 }
12304
12305 /* ffestc_R1221 -- END FUNCTION statement
12306
12307    ffestc_R1221(name_token);
12308
12309    Make sure ffestc_kind_ identifies the current kind of program unit.  If
12310    not NULL, make sure name_token gives the correct name.  Implement the end
12311    of the current program unit.  */
12312
12313 void
12314 ffestc_R1221 (ffelexToken name)
12315 {
12316   ffestc_check_simple_ ();
12317   if (ffestc_order_function_ () != FFESTC_orderOK_)
12318     return;
12319   ffestc_labeldef_notloop_ ();
12320
12321   if ((name != NULL)
12322     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12323     {
12324       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12325       ffebad_here (0, ffelex_token_where_line (name),
12326                    ffelex_token_where_column (name));
12327       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12328              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12329       ffebad_finish ();
12330     }
12331
12332   ffestc_shriek_function_ (TRUE);
12333 }
12334
12335 /* ffestc_R1223 -- SUBROUTINE statement
12336
12337    ffestc_R1223(subrname,arglist,ending_token,recursive_token);
12338
12339    Make sure statement is valid here, register arguments for the
12340    subroutine name, and so on.
12341
12342    06-Apr-90  JCB  2.0
12343       Added the recursive argument.  */
12344
12345 void
12346 ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
12347               ffelexToken final, ffelexToken recursive)
12348 {
12349   ffestw b;
12350   ffesymbol s;
12351
12352   assert ((subrname != NULL)
12353           && (ffelex_token_type (subrname) == FFELEX_typeNAME));
12354
12355   ffestc_check_simple_ ();
12356   if (ffestc_order_iface_ () != FFESTC_orderOK_)
12357     return;
12358   ffestc_labeldef_useless_ ();
12359
12360   ffestc_blocknum_ = 0;
12361   ffesta_is_entry_valid
12362     = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12363   b = ffestw_update (ffestw_push (NULL));
12364   ffestw_set_top_do (b, NULL);
12365   ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
12366   ffestw_set_blocknum (b, ffestc_blocknum_++);
12367   ffestw_set_shriek (b, ffestc_shriek_subroutine_);
12368   ffestw_set_name (b, ffelex_token_use (subrname));
12369
12370   s = ffesymbol_declare_subrunit (subrname);
12371   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12372     {
12373       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12374       ffesymbol_set_info (s,
12375                           ffeinfo_new (FFEINFO_basictypeNONE,
12376                                        FFEINFO_kindtypeNONE,
12377                                        0,
12378                                        FFEINFO_kindSUBROUTINE,
12379                                        FFEINFO_whereLOCAL,
12380                                        FFETARGET_charactersizeNONE));
12381       ffestc_parent_ok_ = TRUE;
12382     }
12383   else
12384     {
12385       if (ffesymbol_kind (s) != FFEINFO_kindANY)
12386         ffesymbol_error (s, subrname);
12387       ffestc_parent_ok_ = FALSE;
12388     }
12389
12390   if (ffestc_parent_ok_)
12391     {
12392       ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12393       ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12394       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12395     }
12396
12397   ffesymbol_signal_unreported (s);
12398
12399   ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
12400 }
12401
12402 /* ffestc_R1225 -- END SUBROUTINE statement
12403
12404    ffestc_R1225(name_token);
12405
12406    Make sure ffestc_kind_ identifies the current kind of program unit.  If
12407    not NULL, make sure name_token gives the correct name.  Implement the end
12408    of the current program unit.  */
12409
12410 void
12411 ffestc_R1225 (ffelexToken name)
12412 {
12413   ffestc_check_simple_ ();
12414   if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
12415     return;
12416   ffestc_labeldef_notloop_ ();
12417
12418   if ((name != NULL)
12419     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12420     {
12421       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12422       ffebad_here (0, ffelex_token_where_line (name),
12423                    ffelex_token_where_column (name));
12424       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12425              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12426       ffebad_finish ();
12427     }
12428
12429   ffestc_shriek_subroutine_ (TRUE);
12430 }
12431
12432 /* ffestc_R1226 -- ENTRY statement
12433
12434    ffestc_R1226(entryname,arglist,ending_token);
12435
12436    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
12437    entry point name, and so on.  */
12438
12439 void
12440 ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
12441               ffelexToken final UNUSED)
12442 {
12443   ffesymbol s;
12444   ffesymbol fs;
12445   ffesymbolAttrs sa;
12446   ffesymbolAttrs na;
12447   bool in_spec;                 /* TRUE if further specification statements
12448                                    may follow, FALSE if executable stmts. */
12449   bool in_func;                 /* TRUE if ENTRY is a FUNCTION, not
12450                                    SUBROUTINE. */
12451
12452   assert ((entryname != NULL)
12453           && (ffelex_token_type (entryname) == FFELEX_typeNAME));
12454
12455   ffestc_check_simple_ ();
12456   if (ffestc_order_entry_ () != FFESTC_orderOK_)
12457     return;
12458   ffestc_labeldef_useless_ ();
12459
12460   switch (ffestw_state (ffestw_stack_top ()))
12461     {
12462     case FFESTV_stateFUNCTION1:
12463     case FFESTV_stateFUNCTION2:
12464     case FFESTV_stateFUNCTION3:
12465       in_func = TRUE;
12466       in_spec = TRUE;
12467       break;
12468
12469     case FFESTV_stateFUNCTION4:
12470       in_func = TRUE;
12471       in_spec = FALSE;
12472       break;
12473
12474     case FFESTV_stateSUBROUTINE1:
12475     case FFESTV_stateSUBROUTINE2:
12476     case FFESTV_stateSUBROUTINE3:
12477       in_func = FALSE;
12478       in_spec = TRUE;
12479       break;
12480
12481     case FFESTV_stateSUBROUTINE4:
12482       in_func = FALSE;
12483       in_spec = FALSE;
12484       break;
12485
12486     default:
12487       assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
12488       in_func = FALSE;
12489       in_spec = FALSE;
12490       break;
12491     }
12492
12493   if (in_func)
12494     fs = ffesymbol_declare_funcunit (entryname);
12495   else
12496     fs = ffesymbol_declare_subrunit (entryname);
12497
12498   if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12499     ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12500   else
12501     {
12502       if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12503         ffesymbol_error (fs, entryname);
12504     }
12505
12506   ++ffestc_entry_num_;
12507
12508   ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12509   if (in_spec)
12510     ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12511   else
12512     ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
12513   ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12514
12515   if (in_func)
12516     {
12517       s = ffesymbol_declare_funcresult (entryname);
12518       ffesymbol_set_funcresult (fs, s);
12519       ffesymbol_set_funcresult (s, fs);
12520       sa = ffesymbol_attrs (s);
12521
12522       /* Figure out what kind of object we've got based on previous
12523          declarations of or references to the object. */
12524
12525       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
12526         na = FFESYMBOL_attrsetNONE;
12527       else if (sa & FFESYMBOL_attrsANY)
12528         na = FFESYMBOL_attrsANY;
12529       else if (!(sa & ~(FFESYMBOL_attrsANYLEN
12530                         | FFESYMBOL_attrsTYPE)))
12531         na = sa | FFESYMBOL_attrsRESULT;
12532       else
12533         na = FFESYMBOL_attrsetNONE;
12534
12535       /* Now see what we've got for a new object: NONE means a new error
12536          cropped up; ANY means an old error to be ignored; otherwise,
12537          everything's ok, update the object (symbol) and continue on. */
12538
12539       if (na == FFESYMBOL_attrsetNONE)
12540         {
12541           ffesymbol_error (s, entryname);
12542           ffestc_parent_ok_ = FALSE;
12543         }
12544       else if (na & FFESYMBOL_attrsANY)
12545         {
12546           ffestc_parent_ok_ = FALSE;
12547         }
12548       else
12549         {
12550           ffesymbol_set_attrs (s, na);
12551           if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12552             ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12553           else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
12554             {
12555               ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12556               ffesymbol_set_info (s,
12557                                   ffeinfo_new (ffesymbol_basictype (s),
12558                                                ffesymbol_kindtype (s),
12559                                                0,
12560                                                FFEINFO_kindENTITY,
12561                                                FFEINFO_whereRESULT,
12562                                                ffesymbol_size (s)));
12563               ffesymbol_resolve_intrin (s);
12564               ffestorag_exec_layout (s);
12565             }
12566         }
12567
12568       /* Since ENTRY might appear after executable stmts, do what would have
12569          been done if it hadn't -- give symbol implicit type and
12570          exec-transition it.  */
12571
12572       if (!in_spec && ffesymbol_is_specable (s))
12573         {
12574           if (!ffeimplic_establish_symbol (s))  /* Do implicit typing. */
12575             ffesymbol_error (s, entryname);
12576           s = ffecom_sym_exec_transition (s);
12577         }
12578
12579       /* Use whatever type info is available for ENTRY to set up type for its
12580          global-name-space function symbol relative.  */
12581
12582       ffesymbol_set_info (fs,
12583                           ffeinfo_new (ffesymbol_basictype (s),
12584                                        ffesymbol_kindtype (s),
12585                                        0,
12586                                        FFEINFO_kindFUNCTION,
12587                                        FFEINFO_whereLOCAL,
12588                                        ffesymbol_size (s)));
12589
12590
12591       /* Check whether the type info fits the filewide expectations;
12592          set ok flag accordingly.  */
12593
12594       ffesymbol_reference (fs, entryname, FALSE);
12595
12596       /* ~~Question??:
12597          When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
12598          if FOO and IBAR would normally end up with different types?  I think
12599          the answer is that FOO is always given whatever type would be chosen
12600          for IBAR, rather than the other way around, and I think it ends up
12601          working that way for FUNCTION FOO() RESULT(IBAR), but this should be
12602          checked out in all its different combos. Related question is, is
12603          there any way that FOO in either case ends up without type info
12604          filled in?  Does anyone care?  */
12605
12606       ffesymbol_signal_unreported (s);
12607     }
12608   else
12609     {
12610       ffesymbol_set_info (fs,
12611                           ffeinfo_new (FFEINFO_basictypeNONE,
12612                                        FFEINFO_kindtypeNONE,
12613                                        0,
12614                                        FFEINFO_kindSUBROUTINE,
12615                                        FFEINFO_whereLOCAL,
12616                                        FFETARGET_charactersizeNONE));
12617     }
12618
12619   if (!in_spec)
12620     fs = ffecom_sym_exec_transition (fs);
12621
12622   ffesymbol_signal_unreported (fs);
12623
12624   ffestd_R1226 (fs);
12625 }
12626
12627 /* ffestc_R1227 -- RETURN statement
12628
12629    ffestc_R1227(expr,expr_token);
12630
12631    Make sure statement is valid here; implement.  expr and expr_token are
12632    both NULL if there was no expression.  */
12633
12634 void
12635 ffestc_R1227 (ffebld expr, ffelexToken expr_token)
12636 {
12637   ffestw b;
12638
12639   ffestc_check_simple_ ();
12640   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12641     return;
12642   ffestc_labeldef_notloop_begin_ ();
12643
12644   for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
12645     {
12646       switch (ffestw_state (b))
12647         {
12648         case FFESTV_statePROGRAM4:
12649         case FFESTV_stateSUBROUTINE4:
12650         case FFESTV_stateFUNCTION4:
12651           goto base;            /* :::::::::::::::::::: */
12652
12653         case FFESTV_stateNIL:
12654           assert ("bad state" == NULL);
12655           break;
12656
12657         default:
12658           break;
12659         }
12660     }
12661
12662  base:
12663   switch (ffestw_state (b))
12664     {
12665     case FFESTV_statePROGRAM4:
12666       if (ffe_is_pedantic ())
12667         {
12668           ffebad_start (FFEBAD_RETURN_IN_MAIN);
12669           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12670                        ffelex_token_where_column (ffesta_tokens[0]));
12671           ffebad_finish ();
12672         }
12673       if (expr != NULL)
12674         {
12675           ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
12676           ffebad_here (0, ffelex_token_where_line (expr_token),
12677                        ffelex_token_where_column (expr_token));
12678           ffebad_finish ();
12679           expr = NULL;
12680         }
12681       break;
12682
12683     case FFESTV_stateSUBROUTINE4:
12684       break;
12685
12686     case FFESTV_stateFUNCTION4:
12687       if (expr != NULL)
12688         {
12689           ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
12690           ffebad_here (0, ffelex_token_where_line (expr_token),
12691                        ffelex_token_where_column (expr_token));
12692           ffebad_finish ();
12693           expr = NULL;
12694         }
12695       break;
12696
12697     default:
12698       assert ("bad state #2" == NULL);
12699       break;
12700     }
12701
12702   ffestd_R1227 (expr);
12703
12704   if (ffestc_shriek_after1_ != NULL)
12705     (*ffestc_shriek_after1_) (TRUE);
12706
12707   /* notloop's that are actionif's can be the target of a loop-end
12708      statement if they're in the "then" part of a logical IF, as
12709      in "DO 10", "10 IF (...) RETURN".  */
12710
12711   ffestc_labeldef_branch_end_ ();
12712 }
12713
12714 /* ffestc_R1228 -- CONTAINS statement
12715
12716    ffestc_R1228();  */
12717
12718 #if FFESTR_F90
12719 void
12720 ffestc_R1228 ()
12721 {
12722   ffestc_check_simple_ ();
12723   if (ffestc_order_contains_ () != FFESTC_orderOK_)
12724     return;
12725   ffestc_labeldef_useless_ ();
12726
12727   ffestd_R1228 ();
12728
12729   ffe_terminate_3 ();
12730   ffe_init_3 ();
12731 }
12732
12733 #endif
12734 /* ffestc_R1229_start -- STMTFUNCTION statement begin
12735
12736    ffestc_R1229_start(func_name,func_arg_list,close_paren);
12737
12738    Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
12739    "live" scope within the current scope, and expect the actual expression
12740    (or NULL) in ffestc_R1229_finish.  The reason there are two ffestc
12741    functions to handle this is so the scope can be established, allowing
12742    ffeexpr to assign proper characteristics to references to the dummy
12743    arguments.  */
12744
12745 void
12746 ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
12747                     ffelexToken final UNUSED)
12748 {
12749   ffesymbol s;
12750   ffesymbolAttrs sa;
12751   ffesymbolAttrs na;
12752
12753   ffestc_check_start_ ();
12754   if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
12755     {
12756       ffestc_ok_ = FALSE;
12757       return;
12758     }
12759   ffestc_labeldef_useless_ ();
12760
12761   assert (name != NULL);
12762   assert (args != NULL);
12763
12764   s = ffesymbol_declare_local (name, FALSE);
12765   sa = ffesymbol_attrs (s);
12766
12767   /* Figure out what kind of object we've got based on previous declarations
12768      of or references to the object. */
12769
12770   if (!ffesymbol_is_specable (s))
12771     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
12772   else if (sa & FFESYMBOL_attrsANY)
12773     na = FFESYMBOL_attrsANY;
12774   else if (!(sa & ~FFESYMBOL_attrsTYPE))
12775     na = sa | FFESYMBOL_attrsSFUNC;
12776   else
12777     na = FFESYMBOL_attrsetNONE;
12778
12779   /* Now see what we've got for a new object: NONE means a new error cropped
12780      up; ANY means an old error to be ignored; otherwise, everything's ok,
12781      update the object (symbol) and continue on. */
12782
12783   if (na == FFESYMBOL_attrsetNONE)
12784     {
12785       ffesymbol_error (s, name);
12786       ffestc_parent_ok_ = FALSE;
12787     }
12788   else if (na & FFESYMBOL_attrsANY)
12789     ffestc_parent_ok_ = FALSE;
12790   else
12791     {
12792       ffesymbol_set_attrs (s, na);
12793       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12794       if (!ffeimplic_establish_symbol (s)
12795           || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
12796               && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
12797         {
12798           ffesymbol_error (s, ffesta_tokens[0]);
12799           ffestc_parent_ok_ = FALSE;
12800         }
12801       else
12802         {
12803           /* Tell ffeexpr that sfunc def is in progress.  */
12804           ffesymbol_set_sfexpr (s, ffebld_new_any ());
12805           ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
12806           ffestc_parent_ok_ = TRUE;
12807         }
12808     }
12809
12810   ffe_init_4 ();
12811
12812   if (ffestc_parent_ok_)
12813     {
12814       ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12815       ffestc_sfdummy_argno_ = 0;
12816       ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
12817       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12818     }
12819
12820   ffestc_local_.sfunc.symbol = s;
12821
12822   ffestd_R1229_start (name, args);
12823
12824   ffestc_ok_ = TRUE;
12825 }
12826
12827 /* ffestc_R1229_finish -- STMTFUNCTION statement list complete
12828
12829    ffestc_R1229_finish(expr,expr_token);
12830
12831    If expr is NULL, an error occurred parsing the expansion expression, so
12832    just cancel the effects of ffestc_R1229_start and pretend nothing
12833    happened.  Otherwise, install the expression as the expansion for the
12834    statement function named in _start_, then clean up.  */
12835
12836 void
12837 ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
12838 {
12839   ffestc_check_finish_ ();
12840   if (!ffestc_ok_)
12841     return;
12842
12843   if (ffestc_parent_ok_ && (expr != NULL))
12844     ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
12845                           ffeexpr_convert_to_sym (expr,
12846                                                   expr_token,
12847                                                   ffestc_local_.sfunc.symbol,
12848                                                   ffesta_tokens[0]));
12849
12850   ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
12851
12852   ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
12853
12854   ffe_terminate_4 ();
12855 }
12856
12857 /* ffestc_S3P4 -- INCLUDE line
12858
12859    ffestc_S3P4(filename,filename_token);
12860
12861    Make sure INCLUDE not preceded by any semicolons or a label def; implement.  */
12862
12863 void
12864 ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
12865 {
12866   ffestc_check_simple_ ();
12867   ffestc_labeldef_invalid_ ();
12868
12869   ffestd_S3P4 (filename);
12870 }
12871
12872 /* ffestc_V003_start -- STRUCTURE statement list begin
12873
12874    ffestc_V003_start(structure_name);
12875
12876    Verify that STRUCTURE is valid here, and begin accepting items in the list.  */
12877
12878 #if FFESTR_VXT
12879 void
12880 ffestc_V003_start (ffelexToken structure_name)
12881 {
12882   ffestw b;
12883
12884   ffestc_check_start_ ();
12885   if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_)
12886     {
12887       ffestc_ok_ = FALSE;
12888       return;
12889     }
12890   ffestc_labeldef_useless_ ();
12891
12892   switch (ffestw_state (ffestw_stack_top ()))
12893     {
12894     case FFESTV_stateSTRUCTURE:
12895     case FFESTV_stateMAP:
12896       ffestc_local_.V003.list_state = 2;        /* Require at least one field
12897                                                    name. */
12898       ffestw_set_substate (ffestw_stack_top (), 1);     /* Seen at least one
12899                                                            member. */
12900       break;
12901
12902     default:
12903       ffestc_local_.V003.list_state = 0;        /* No field names required. */
12904       if (structure_name == NULL)
12905         {
12906           ffebad_start (FFEBAD_STRUCT_MISSING_NAME);
12907           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12908                        ffelex_token_where_column (ffesta_tokens[0]));
12909           ffebad_finish ();
12910         }
12911       break;
12912     }
12913
12914   b = ffestw_update (ffestw_push (NULL));
12915   ffestw_set_top_do (b, NULL);
12916   ffestw_set_state (b, FFESTV_stateSTRUCTURE);
12917   ffestw_set_blocknum (b, 0);
12918   ffestw_set_shriek (b, ffestc_shriek_structure_);
12919   ffestw_set_substate (b, 0);   /* No field-declarations seen yet. */
12920
12921   ffestd_V003_start (structure_name);
12922
12923   ffestc_ok_ = TRUE;
12924 }
12925
12926 /* ffestc_V003_item -- STRUCTURE statement for object-name
12927
12928    ffestc_V003_item(name_token,dim_list);
12929
12930    Make sure name_token identifies a valid object to be STRUCTUREd.  */
12931
12932 void
12933 ffestc_V003_item (ffelexToken name, ffesttDimList dims)
12934 {
12935   ffestc_check_item_ ();
12936   assert (name != NULL);
12937   if (!ffestc_ok_)
12938     return;
12939
12940   if (ffestc_local_.V003.list_state < 2)
12941     {
12942       if (ffestc_local_.V003.list_state == 0)
12943         {
12944           ffestc_local_.V003.list_state = 1;
12945           ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD);
12946           ffebad_here (0, ffelex_token_where_line (name),
12947                        ffelex_token_where_column (name));
12948           ffebad_finish ();
12949         }
12950       return;
12951     }
12952   ffestc_local_.V003.list_state = 3;    /* Have at least one field name. */
12953
12954   if (dims != NULL)
12955     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
12956
12957   ffestd_V003_item (name, dims);
12958 }
12959
12960 /* ffestc_V003_finish -- STRUCTURE statement list complete
12961
12962    ffestc_V003_finish();
12963
12964    Just wrap up any local activities.  */
12965
12966 void
12967 ffestc_V003_finish ()
12968 {
12969   ffestc_check_finish_ ();
12970   if (!ffestc_ok_)
12971     return;
12972
12973   if (ffestc_local_.V003.list_state == 2)
12974     {
12975       ffebad_start (FFEBAD_STRUCT_MISSING_FIELD);
12976       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12977                    ffelex_token_where_column (ffesta_tokens[0]));
12978       ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())),
12979                    ffestw_col (ffestw_previous (ffestw_stack_top ())));
12980       ffebad_finish ();
12981     }
12982
12983   ffestd_V003_finish ();
12984 }
12985
12986 /* ffestc_V004 -- END STRUCTURE statement
12987
12988    ffestc_V004();
12989
12990    Make sure ffestc_kind_ identifies a STRUCTURE block.
12991    Implement the end of the current STRUCTURE block.  */
12992
12993 void
12994 ffestc_V004 ()
12995 {
12996   ffestc_check_simple_ ();
12997   if (ffestc_order_structure_ () != FFESTC_orderOK_)
12998     return;
12999   ffestc_labeldef_useless_ ();
13000
13001   if (ffestw_substate (ffestw_stack_top ()) != 1)
13002     {
13003       ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS);
13004       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13005                    ffelex_token_where_column (ffesta_tokens[0]));
13006       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13007       ffebad_finish ();
13008     }
13009
13010   ffestc_shriek_structure_ (TRUE);
13011 }
13012
13013 /* ffestc_V009 -- UNION statement
13014
13015    ffestc_V009();  */
13016
13017 void
13018 ffestc_V009 ()
13019 {
13020   ffestw b;
13021
13022   ffestc_check_simple_ ();
13023   if (ffestc_order_structure_ () != FFESTC_orderOK_)
13024     return;
13025   ffestc_labeldef_useless_ ();
13026
13027   ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */
13028
13029   b = ffestw_update (ffestw_push (NULL));
13030   ffestw_set_top_do (b, NULL);
13031   ffestw_set_state (b, FFESTV_stateUNION);
13032   ffestw_set_blocknum (b, 0);
13033   ffestw_set_shriek (b, ffestc_shriek_union_);
13034   ffestw_set_substate (b, 0);   /* No map decls seen yet. */
13035
13036   ffestd_V009 ();
13037 }
13038
13039 /* ffestc_V010 -- END UNION statement
13040
13041    ffestc_V010();
13042
13043    Make sure ffestc_kind_ identifies a UNION block.
13044    Implement the end of the current UNION block.  */
13045
13046 void
13047 ffestc_V010 ()
13048 {
13049   ffestc_check_simple_ ();
13050   if (ffestc_order_union_ () != FFESTC_orderOK_)
13051     return;
13052   ffestc_labeldef_useless_ ();
13053
13054   if (ffestw_substate (ffestw_stack_top ()) != 2)
13055     {
13056       ffebad_start (FFEBAD_UNION_NO_TWO_MAPS);
13057       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13058                    ffelex_token_where_column (ffesta_tokens[0]));
13059       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13060       ffebad_finish ();
13061     }
13062
13063   ffestc_shriek_union_ (TRUE);
13064 }
13065
13066 /* ffestc_V012 -- MAP statement
13067
13068    ffestc_V012();  */
13069
13070 void
13071 ffestc_V012 ()
13072 {
13073   ffestw b;
13074
13075   ffestc_check_simple_ ();
13076   if (ffestc_order_union_ () != FFESTC_orderOK_)
13077     return;
13078   ffestc_labeldef_useless_ ();
13079
13080   if (ffestw_substate (ffestw_stack_top ()) != 2)
13081     ffestw_substate (ffestw_stack_top ())++;    /* 0=>1, 1=>2. */
13082
13083   b = ffestw_update (ffestw_push (NULL));
13084   ffestw_set_top_do (b, NULL);
13085   ffestw_set_state (b, FFESTV_stateMAP);
13086   ffestw_set_blocknum (b, 0);
13087   ffestw_set_shriek (b, ffestc_shriek_map_);
13088   ffestw_set_substate (b, 0);   /* No field-declarations seen yet. */
13089
13090   ffestd_V012 ();
13091 }
13092
13093 /* ffestc_V013 -- END MAP statement
13094
13095    ffestc_V013();
13096
13097    Make sure ffestc_kind_ identifies a MAP block.
13098    Implement the end of the current MAP block.  */
13099
13100 void
13101 ffestc_V013 ()
13102 {
13103   ffestc_check_simple_ ();
13104   if (ffestc_order_map_ () != FFESTC_orderOK_)
13105     return;
13106   ffestc_labeldef_useless_ ();
13107
13108   if (ffestw_substate (ffestw_stack_top ()) != 1)
13109     {
13110       ffebad_start (FFEBAD_MAP_NO_COMPONENTS);
13111       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13112                    ffelex_token_where_column (ffesta_tokens[0]));
13113       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13114       ffebad_finish ();
13115     }
13116
13117   ffestc_shriek_map_ (TRUE);
13118 }
13119
13120 #endif
13121 /* ffestc_V014_start -- VOLATILE statement list begin
13122
13123    ffestc_V014_start();
13124
13125    Verify that VOLATILE is valid here, and begin accepting items in the
13126    list.  */
13127
13128 void
13129 ffestc_V014_start ()
13130 {
13131   ffestc_check_start_ ();
13132   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
13133     {
13134       ffestc_ok_ = FALSE;
13135       return;
13136     }
13137   ffestc_labeldef_useless_ ();
13138
13139   ffestd_V014_start ();
13140
13141   ffestc_ok_ = TRUE;
13142 }
13143
13144 /* ffestc_V014_item_object -- VOLATILE statement for object-name
13145
13146    ffestc_V014_item_object(name_token);
13147
13148    Make sure name_token identifies a valid object to be VOLATILEd.  */
13149
13150 void
13151 ffestc_V014_item_object (ffelexToken name)
13152 {
13153   ffestc_check_item_ ();
13154   assert (name != NULL);
13155   if (!ffestc_ok_)
13156     return;
13157
13158   ffestd_V014_item_object (name);
13159 }
13160
13161 /* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
13162
13163    ffestc_V014_item_cblock(name_token);
13164
13165    Make sure name_token identifies a valid common block to be VOLATILEd.  */
13166
13167 void
13168 ffestc_V014_item_cblock (ffelexToken name)
13169 {
13170   ffestc_check_item_ ();
13171   assert (name != NULL);
13172   if (!ffestc_ok_)
13173     return;
13174
13175   ffestd_V014_item_cblock (name);
13176 }
13177
13178 /* ffestc_V014_finish -- VOLATILE statement list complete
13179
13180    ffestc_V014_finish();
13181
13182    Just wrap up any local activities.  */
13183
13184 void
13185 ffestc_V014_finish ()
13186 {
13187   ffestc_check_finish_ ();
13188   if (!ffestc_ok_)
13189     return;
13190
13191   ffestd_V014_finish ();
13192 }
13193
13194 /* ffestc_V016_start -- RECORD statement list begin
13195
13196    ffestc_V016_start();
13197
13198    Verify that RECORD is valid here, and begin accepting items in the list.  */
13199
13200 #if FFESTR_VXT
13201 void
13202 ffestc_V016_start ()
13203 {
13204   ffestc_check_start_ ();
13205   if (ffestc_order_record_ () != FFESTC_orderOK_)
13206     {
13207       ffestc_ok_ = FALSE;
13208       return;
13209     }
13210   ffestc_labeldef_useless_ ();
13211
13212   switch (ffestw_state (ffestw_stack_top ()))
13213     {
13214     case FFESTV_stateSTRUCTURE:
13215     case FFESTV_stateMAP:
13216       ffestw_set_substate (ffestw_stack_top (), 1);     /* Seen at least one
13217                                                            member. */
13218       break;
13219
13220     default:
13221       break;
13222     }
13223
13224   ffestd_V016_start ();
13225
13226   ffestc_ok_ = TRUE;
13227 }
13228
13229 /* ffestc_V016_item_structure -- RECORD statement for common-block-name
13230
13231    ffestc_V016_item_structure(name_token);
13232
13233    Make sure name_token identifies a valid structure to be RECORDed.  */
13234
13235 void
13236 ffestc_V016_item_structure (ffelexToken name)
13237 {
13238   ffestc_check_item_ ();
13239   assert (name != NULL);
13240   if (!ffestc_ok_)
13241     return;
13242
13243   ffestd_V016_item_structure (name);
13244 }
13245
13246 /* ffestc_V016_item_object -- RECORD statement for object-name
13247
13248    ffestc_V016_item_object(name_token,dim_list);
13249
13250    Make sure name_token identifies a valid object to be RECORDd.  */
13251
13252 void
13253 ffestc_V016_item_object (ffelexToken name, ffesttDimList dims)
13254 {
13255   ffestc_check_item_ ();
13256   assert (name != NULL);
13257   if (!ffestc_ok_)
13258     return;
13259
13260   if (dims != NULL)
13261     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
13262
13263   ffestd_V016_item_object (name, dims);
13264 }
13265
13266 /* ffestc_V016_finish -- RECORD statement list complete
13267
13268    ffestc_V016_finish();
13269
13270    Just wrap up any local activities.  */
13271
13272 void
13273 ffestc_V016_finish ()
13274 {
13275   ffestc_check_finish_ ();
13276   if (!ffestc_ok_)
13277     return;
13278
13279   ffestd_V016_finish ();
13280 }
13281
13282 /* ffestc_V018_start -- REWRITE(...) statement list begin
13283
13284    ffestc_V018_start();
13285
13286    Verify that REWRITE is valid here, and begin accepting items in the
13287    list.  */
13288
13289 void
13290 ffestc_V018_start ()
13291 {
13292   ffestvFormat format;
13293
13294   ffestc_check_start_ ();
13295   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13296     {
13297       ffestc_ok_ = FALSE;
13298       return;
13299     }
13300   ffestc_labeldef_branch_begin_ ();
13301
13302   if (!ffestc_subr_is_branch_
13303       (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR])
13304       || !ffestc_subr_is_format_
13305       (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT])
13306       || !ffestc_subr_is_present_ ("UNIT",
13307                    &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT]))
13308     {
13309       ffestc_ok_ = FALSE;
13310       return;
13311     }
13312
13313   format = ffestc_subr_format_
13314     (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]);
13315   switch (format)
13316     {
13317     case FFESTV_formatNAMELIST:
13318     case FFESTV_formatASTERISK:
13319       ffebad_start (FFEBAD_CONFLICTING_SPECS);
13320       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13321                    ffelex_token_where_column (ffesta_tokens[0]));
13322       assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present);
13323       if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present)
13324         {
13325           ffebad_here (0, ffelex_token_where_line
13326                  (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw),
13327                        ffelex_token_where_column
13328                 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw));
13329         }
13330       else
13331         {
13332           ffebad_here (1, ffelex_token_where_line
13333               (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value),
13334                        ffelex_token_where_column
13335              (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value));
13336         }
13337       ffebad_finish ();
13338       ffestc_ok_ = FALSE;
13339       return;
13340
13341     default:
13342       break;
13343     }
13344
13345   ffestd_V018_start (format);
13346
13347   ffestc_ok_ = TRUE;
13348 }
13349
13350 /* ffestc_V018_item -- REWRITE statement i/o item
13351
13352    ffestc_V018_item(expr,expr_token);
13353
13354    Implement output-list expression.  */
13355
13356 void
13357 ffestc_V018_item (ffebld expr, ffelexToken expr_token)
13358 {
13359   ffestc_check_item_ ();
13360   if (!ffestc_ok_)
13361     return;
13362
13363   ffestd_V018_item (expr);
13364 }
13365
13366 /* ffestc_V018_finish -- REWRITE statement list complete
13367
13368    ffestc_V018_finish();
13369
13370    Just wrap up any local activities.  */
13371
13372 void
13373 ffestc_V018_finish ()
13374 {
13375   ffestc_check_finish_ ();
13376   if (!ffestc_ok_)
13377     return;
13378
13379   ffestd_V018_finish ();
13380
13381   if (ffestc_shriek_after1_ != NULL)
13382     (*ffestc_shriek_after1_) (TRUE);
13383   ffestc_labeldef_branch_end_ ();
13384 }
13385
13386 /* ffestc_V019_start -- ACCEPT statement list begin
13387
13388    ffestc_V019_start();
13389
13390    Verify that ACCEPT is valid here, and begin accepting items in the
13391    list.  */
13392
13393 void
13394 ffestc_V019_start ()
13395 {
13396   ffestvFormat format;
13397
13398   ffestc_check_start_ ();
13399   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13400     {
13401       ffestc_ok_ = FALSE;
13402       return;
13403     }
13404   ffestc_labeldef_branch_begin_ ();
13405
13406   if (!ffestc_subr_is_format_
13407       (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]))
13408     {
13409       ffestc_ok_ = FALSE;
13410       return;
13411     }
13412
13413   format = ffestc_subr_format_
13414     (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]);
13415   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13416
13417   ffestd_V019_start (format);
13418
13419   ffestc_ok_ = TRUE;
13420 }
13421
13422 /* ffestc_V019_item -- ACCEPT statement i/o item
13423
13424    ffestc_V019_item(expr,expr_token);
13425
13426    Implement output-list expression.  */
13427
13428 void
13429 ffestc_V019_item (ffebld expr, ffelexToken expr_token)
13430 {
13431   ffestc_check_item_ ();
13432   if (!ffestc_ok_)
13433     return;
13434
13435   if (ffestc_namelist_ != 0)
13436     {
13437       if (ffestc_namelist_ == 1)
13438         {
13439           ffestc_namelist_ = 2;
13440           ffebad_start (FFEBAD_NAMELIST_ITEMS);
13441           ffebad_here (0, ffelex_token_where_line (expr_token),
13442                        ffelex_token_where_column (expr_token));
13443           ffebad_finish ();
13444         }
13445       return;
13446     }
13447
13448   ffestd_V019_item (expr);
13449 }
13450
13451 /* ffestc_V019_finish -- ACCEPT statement list complete
13452
13453    ffestc_V019_finish();
13454
13455    Just wrap up any local activities.  */
13456
13457 void
13458 ffestc_V019_finish ()
13459 {
13460   ffestc_check_finish_ ();
13461   if (!ffestc_ok_)
13462     return;
13463
13464   ffestd_V019_finish ();
13465
13466   if (ffestc_shriek_after1_ != NULL)
13467     (*ffestc_shriek_after1_) (TRUE);
13468   ffestc_labeldef_branch_end_ ();
13469 }
13470
13471 #endif
13472 /* ffestc_V020_start -- TYPE statement list begin
13473
13474    ffestc_V020_start();
13475
13476    Verify that TYPE is valid here, and begin accepting items in the
13477    list.  */
13478
13479 void
13480 ffestc_V020_start ()
13481 {
13482   ffestvFormat format;
13483
13484   ffestc_check_start_ ();
13485   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13486     {
13487       ffestc_ok_ = FALSE;
13488       return;
13489     }
13490   ffestc_labeldef_branch_begin_ ();
13491
13492   if (!ffestc_subr_is_format_
13493       (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
13494     {
13495       ffestc_ok_ = FALSE;
13496       return;
13497     }
13498
13499   format = ffestc_subr_format_
13500     (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
13501   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13502
13503   ffestd_V020_start (format);
13504
13505   ffestc_ok_ = TRUE;
13506 }
13507
13508 /* ffestc_V020_item -- TYPE statement i/o item
13509
13510    ffestc_V020_item(expr,expr_token);
13511
13512    Implement output-list expression.  */
13513
13514 void
13515 ffestc_V020_item (ffebld expr, ffelexToken expr_token)
13516 {
13517   ffestc_check_item_ ();
13518   if (!ffestc_ok_)
13519     return;
13520
13521   if (ffestc_namelist_ != 0)
13522     {
13523       if (ffestc_namelist_ == 1)
13524         {
13525           ffestc_namelist_ = 2;
13526           ffebad_start (FFEBAD_NAMELIST_ITEMS);
13527           ffebad_here (0, ffelex_token_where_line (expr_token),
13528                        ffelex_token_where_column (expr_token));
13529           ffebad_finish ();
13530         }
13531       return;
13532     }
13533
13534   ffestd_V020_item (expr);
13535 }
13536
13537 /* ffestc_V020_finish -- TYPE statement list complete
13538
13539    ffestc_V020_finish();
13540
13541    Just wrap up any local activities.  */
13542
13543 void
13544 ffestc_V020_finish ()
13545 {
13546   ffestc_check_finish_ ();
13547   if (!ffestc_ok_)
13548     return;
13549
13550   ffestd_V020_finish ();
13551
13552   if (ffestc_shriek_after1_ != NULL)
13553     (*ffestc_shriek_after1_) (TRUE);
13554   ffestc_labeldef_branch_end_ ();
13555 }
13556
13557 /* ffestc_V021 -- DELETE statement
13558
13559    ffestc_V021();
13560
13561    Make sure a DELETE is valid in the current context, and implement it.  */
13562
13563 #if FFESTR_VXT
13564 void
13565 ffestc_V021 ()
13566 {
13567   ffestc_check_simple_ ();
13568   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13569     return;
13570   ffestc_labeldef_branch_begin_ ();
13571
13572   if (ffestc_subr_is_branch_
13573       (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR])
13574       && ffestc_subr_is_present_ ("UNIT",
13575                       &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT]))
13576     ffestd_V021 ();
13577
13578   if (ffestc_shriek_after1_ != NULL)
13579     (*ffestc_shriek_after1_) (TRUE);
13580   ffestc_labeldef_branch_end_ ();
13581 }
13582
13583 /* ffestc_V022 -- UNLOCK statement
13584
13585    ffestc_V022();
13586
13587    Make sure a UNLOCK is valid in the current context, and implement it.  */
13588
13589 void
13590 ffestc_V022 ()
13591 {
13592   ffestc_check_simple_ ();
13593   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13594     return;
13595   ffestc_labeldef_branch_begin_ ();
13596
13597   if (ffestc_subr_is_branch_
13598       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
13599       && ffestc_subr_is_present_ ("UNIT",
13600                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
13601     ffestd_V022 ();
13602
13603   if (ffestc_shriek_after1_ != NULL)
13604     (*ffestc_shriek_after1_) (TRUE);
13605   ffestc_labeldef_branch_end_ ();
13606 }
13607
13608 /* ffestc_V023_start -- ENCODE(...) statement list begin
13609
13610    ffestc_V023_start();
13611
13612    Verify that ENCODE is valid here, and begin accepting items in the
13613    list.  */
13614
13615 void
13616 ffestc_V023_start ()
13617 {
13618   ffestc_check_start_ ();
13619   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13620     {
13621       ffestc_ok_ = FALSE;
13622       return;
13623     }
13624   ffestc_labeldef_branch_begin_ ();
13625
13626   if (!ffestc_subr_is_branch_
13627       (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13628     {
13629       ffestc_ok_ = FALSE;
13630       return;
13631     }
13632
13633   ffestd_V023_start ();
13634
13635   ffestc_ok_ = TRUE;
13636 }
13637
13638 /* ffestc_V023_item -- ENCODE statement i/o item
13639
13640    ffestc_V023_item(expr,expr_token);
13641
13642    Implement output-list expression.  */
13643
13644 void
13645 ffestc_V023_item (ffebld expr, ffelexToken expr_token)
13646 {
13647   ffestc_check_item_ ();
13648   if (!ffestc_ok_)
13649     return;
13650
13651   ffestd_V023_item (expr);
13652 }
13653
13654 /* ffestc_V023_finish -- ENCODE statement list complete
13655
13656    ffestc_V023_finish();
13657
13658    Just wrap up any local activities.  */
13659
13660 void
13661 ffestc_V023_finish ()
13662 {
13663   ffestc_check_finish_ ();
13664   if (!ffestc_ok_)
13665     return;
13666
13667   ffestd_V023_finish ();
13668
13669   if (ffestc_shriek_after1_ != NULL)
13670     (*ffestc_shriek_after1_) (TRUE);
13671   ffestc_labeldef_branch_end_ ();
13672 }
13673
13674 /* ffestc_V024_start -- DECODE(...) statement list begin
13675
13676    ffestc_V024_start();
13677
13678    Verify that DECODE is valid here, and begin accepting items in the
13679    list.  */
13680
13681 void
13682 ffestc_V024_start ()
13683 {
13684   ffestc_check_start_ ();
13685   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13686     {
13687       ffestc_ok_ = FALSE;
13688       return;
13689     }
13690   ffestc_labeldef_branch_begin_ ();
13691
13692   if (!ffestc_subr_is_branch_
13693       (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13694     {
13695       ffestc_ok_ = FALSE;
13696       return;
13697     }
13698
13699   ffestd_V024_start ();
13700
13701   ffestc_ok_ = TRUE;
13702 }
13703
13704 /* ffestc_V024_item -- DECODE statement i/o item
13705
13706    ffestc_V024_item(expr,expr_token);
13707
13708    Implement output-list expression.  */
13709
13710 void
13711 ffestc_V024_item (ffebld expr, ffelexToken expr_token)
13712 {
13713   ffestc_check_item_ ();
13714   if (!ffestc_ok_)
13715     return;
13716
13717   ffestd_V024_item (expr);
13718 }
13719
13720 /* ffestc_V024_finish -- DECODE statement list complete
13721
13722    ffestc_V024_finish();
13723
13724    Just wrap up any local activities.  */
13725
13726 void
13727 ffestc_V024_finish ()
13728 {
13729   ffestc_check_finish_ ();
13730   if (!ffestc_ok_)
13731     return;
13732
13733   ffestd_V024_finish ();
13734
13735   if (ffestc_shriek_after1_ != NULL)
13736     (*ffestc_shriek_after1_) (TRUE);
13737   ffestc_labeldef_branch_end_ ();
13738 }
13739
13740 /* ffestc_V025_start -- DEFINEFILE statement list begin
13741
13742    ffestc_V025_start();
13743
13744    Verify that DEFINEFILE is valid here, and begin accepting items in the
13745    list.  */
13746
13747 void
13748 ffestc_V025_start ()
13749 {
13750   ffestc_check_start_ ();
13751   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13752     {
13753       ffestc_ok_ = FALSE;
13754       return;
13755     }
13756   ffestc_labeldef_branch_begin_ ();
13757
13758   ffestd_V025_start ();
13759
13760   ffestc_ok_ = TRUE;
13761 }
13762
13763 /* ffestc_V025_item -- DEFINE FILE statement item
13764
13765    ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt);
13766
13767    Implement item.  */
13768
13769 void
13770 ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt,
13771                   ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt)
13772 {
13773   ffestc_check_item_ ();
13774   if (!ffestc_ok_)
13775     return;
13776
13777   ffestd_V025_item (u, m, n, asv);
13778 }
13779
13780 /* ffestc_V025_finish -- DEFINE FILE statement list complete
13781
13782    ffestc_V025_finish();
13783
13784    Just wrap up any local activities.  */
13785
13786 void
13787 ffestc_V025_finish ()
13788 {
13789   ffestc_check_finish_ ();
13790   if (!ffestc_ok_)
13791     return;
13792
13793   ffestd_V025_finish ();
13794
13795   if (ffestc_shriek_after1_ != NULL)
13796     (*ffestc_shriek_after1_) (TRUE);
13797   ffestc_labeldef_branch_end_ ();
13798 }
13799
13800 /* ffestc_V026 -- FIND statement
13801
13802    ffestc_V026();
13803
13804    Make sure a FIND is valid in the current context, and implement it.  */
13805
13806 void
13807 ffestc_V026 ()
13808 {
13809   ffestc_check_simple_ ();
13810   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13811     return;
13812   ffestc_labeldef_branch_begin_ ();
13813
13814   if (ffestc_subr_is_branch_
13815       (&ffestp_file.find.find_spec[FFESTP_findixERR])
13816       && ffestc_subr_is_present_ ("UNIT",
13817                              &ffestp_file.find.find_spec[FFESTP_findixUNIT])
13818       && ffestc_subr_is_present_ ("REC",
13819                              &ffestp_file.find.find_spec[FFESTP_findixREC]))
13820     ffestd_V026 ();
13821
13822   if (ffestc_shriek_after1_ != NULL)
13823     (*ffestc_shriek_after1_) (TRUE);
13824   ffestc_labeldef_branch_end_ ();
13825 }
13826
13827 #endif
13828 /* ffestc_V027_start -- VXT PARAMETER statement list begin
13829
13830    ffestc_V027_start();
13831
13832    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
13833
13834 void
13835 ffestc_V027_start ()
13836 {
13837   ffestc_check_start_ ();
13838   if (ffestc_order_parameter_ () != FFESTC_orderOK_)
13839     {
13840       ffestc_ok_ = FALSE;
13841       return;
13842     }
13843   ffestc_labeldef_useless_ ();
13844
13845   ffestd_V027_start ();
13846
13847   ffestc_ok_ = TRUE;
13848 }
13849
13850 /* ffestc_V027_item -- VXT PARAMETER statement assignment
13851
13852    ffestc_V027_item(dest,dest_token,source,source_token);
13853
13854    Make sure the source is a valid source for the destination; make the
13855    assignment.  */
13856
13857 void
13858 ffestc_V027_item (ffelexToken dest_token, ffebld source,
13859                   ffelexToken source_token UNUSED)
13860 {
13861   ffestc_check_item_ ();
13862   if (!ffestc_ok_)
13863     return;
13864
13865   ffestd_V027_item (dest_token, source);
13866 }
13867
13868 /* ffestc_V027_finish -- VXT PARAMETER statement list complete
13869
13870    ffestc_V027_finish();
13871
13872    Just wrap up any local activities.  */
13873
13874 void
13875 ffestc_V027_finish ()
13876 {
13877   ffestc_check_finish_ ();
13878   if (!ffestc_ok_)
13879     return;
13880
13881   ffestd_V027_finish ();
13882 }
13883
13884 /* Any executable statement.  Mainly make sure that one-shot things
13885    like the statement for a logical IF are reset.  */
13886
13887 void
13888 ffestc_any ()
13889 {
13890   ffestc_check_simple_ ();
13891
13892   ffestc_order_any_ ();
13893
13894   ffestc_labeldef_any_ ();
13895
13896   if (ffestc_shriek_after1_ == NULL)
13897     return;
13898
13899   ffestd_any ();
13900
13901   (*ffestc_shriek_after1_) (TRUE);
13902 }