gcc/f/stc.c

   1 /* stc.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1997 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
   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_ (char **list, int size, ffestpFile *spec,
 343                                  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_ (char *name, ffestpFile *spec);
 348 static int ffestc_subr_speccmp_ (char *string, ffestpFile *spec,
 349                                  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_ (char **list, int size, ffestpFile *spec, char *whine)
5048 {
5049   int lowest_tested;
5050   int highest_tested;
5051   int halfway;
5052   int offset;
5053   int c;
5054   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_ (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_ (char *string, ffestpFile *spec, 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     if (ffestc_local_.equiv.eq == NULL)
8242       ffestc_local_.equiv.eq = ffesymbol_equiv (s);     /* New equiv obj. */
8243     else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
8244       {
8245         ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
8246                                                  ffestc_local_.equiv.eq,
8247                                                  t);
8248         if (ffestc_local_.equiv.eq == NULL)
8249           ffestc_local_.equiv.ok = FALSE;       /* Couldn't merge. */
8250       }
8251
8252   if (ffesymbol_is_save (s))
8253     ffestc_local_.equiv.save = TRUE;
8254 }
8255
8256 /* ffestc_R544_finish -- EQUIVALENCE statement list complete
8257
8258    ffestc_R544_finish();
8259
8260    Just wrap up any local activities.  */
8261
8262 void
8263 ffestc_R544_finish ()
8264 {
8265   ffestc_check_finish_ ();
8266 }
8267
8268 /* ffestc_R547_start -- COMMON statement list begin
8269
8270    ffestc_R547_start();
8271
8272    Verify that COMMON is valid here, and begin accepting items in the list.  */
8273
8274 void
8275 ffestc_R547_start ()
8276 {
8277   ffestc_check_start_ ();
8278   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
8279     {
8280       ffestc_ok_ = FALSE;
8281       return;
8282     }
8283   ffestc_labeldef_useless_ ();
8284
8285   ffestc_local_.common.symbol = NULL;   /* Blank common is the default. */
8286   ffestc_parent_ok_ = TRUE;
8287
8288   ffestd_R547_start ();
8289
8290   ffestc_ok_ = TRUE;
8291 }
8292
8293 /* ffestc_R547_item_object -- COMMON statement for object-name
8294
8295    ffestc_R547_item_object(name_token,dim_list);
8296
8297    Make sure name_token identifies a valid object to be COMMONd.  */
8298
8299 void
8300 ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
8301 {
8302   ffesymbol s;
8303   ffebld array_size;
8304   ffebld extents;
8305   ffesymbolAttrs sa;
8306   ffesymbolAttrs na;
8307   ffestpDimtype nd;
8308   ffebld e;
8309   ffeinfoRank rank;
8310   bool is_ugly_assumed;
8311
8312   if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
8313     ffestc_R547_item_cblock (NULL);     /* As if "COMMON [//] ...". */
8314
8315   ffestc_check_item_ ();
8316   assert (name != NULL);
8317   if (!ffestc_ok_)
8318     return;
8319
8320   if (dims != NULL)
8321     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
8322
8323   s = ffesymbol_declare_local (name, FALSE);
8324   sa = ffesymbol_attrs (s);
8325
8326   /* First figure out what kind of object this is based solely on the current
8327      object situation (dimension list). */
8328
8329   is_ugly_assumed = (ffe_is_ugly_assumed ()
8330                      && ((sa & FFESYMBOL_attrsDUMMY)
8331                          || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
8332
8333   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
8334   switch (nd)
8335     {
8336     case FFESTP_dimtypeNONE:
8337       na = FFESYMBOL_attrsCOMMON;
8338       break;
8339
8340     case FFESTP_dimtypeKNOWN:
8341       na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
8342       break;
8343
8344     default:
8345       na = FFESYMBOL_attrsetNONE;
8346       break;
8347     }
8348
8349   /* Figure out what kind of object we've got based on previous declarations
8350      of or references to the object. */
8351
8352   if (na == FFESYMBOL_attrsetNONE)
8353     ;
8354   else if (!ffesymbol_is_specable (s))
8355     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
8356   else if (sa & FFESYMBOL_attrsANY)
8357     na = FFESYMBOL_attrsANY;
8358   else if ((sa & (FFESYMBOL_attrsADJUSTS
8359                   | FFESYMBOL_attrsARRAY
8360                   | FFESYMBOL_attrsINIT
8361                   | FFESYMBOL_attrsSFARG))
8362            && (na & FFESYMBOL_attrsARRAY))
8363     na = FFESYMBOL_attrsetNONE;
8364   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
8365                     | FFESYMBOL_attrsARRAY
8366                     | FFESYMBOL_attrsEQUIV
8367                     | FFESYMBOL_attrsINIT
8368                     | FFESYMBOL_attrsNAMELIST
8369                     | FFESYMBOL_attrsSFARG
8370                     | FFESYMBOL_attrsTYPE)))
8371     na |= sa;
8372   else
8373     na = FFESYMBOL_attrsetNONE;
8374
8375   /* Now see what we've got for a new object: NONE means a new error cropped
8376      up; ANY means an old error to be ignored; otherwise, everything's ok,
8377      update the object (symbol) and continue on. */
8378
8379   if (na == FFESYMBOL_attrsetNONE)
8380     ffesymbol_error (s, name);
8381   else if ((ffesymbol_equiv (s) != NULL)
8382            && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
8383            && (ffeequiv_common (ffesymbol_equiv (s))
8384                != ffestc_local_.common.symbol))
8385     {
8386       /* Oops, just COMMONed a symbol to a different area (via equiv).  */
8387       ffebad_start (FFEBAD_EQUIV_COMMON);
8388       ffebad_here (0, ffelex_token_where_line (name),
8389                    ffelex_token_where_column (name));
8390       ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
8391       ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
8392       ffebad_finish ();
8393       ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
8394       ffesymbol_set_info (s, ffeinfo_new_any ());
8395       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8396       ffesymbol_signal_unreported (s);
8397     }
8398   else if (!(na & FFESYMBOL_attrsANY))
8399     {
8400       ffesymbol_set_attrs (s, na);
8401       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8402       ffesymbol_set_common (s, ffestc_local_.common.symbol);
8403 #if FFEGLOBAL_ENABLED
8404       if (ffesymbol_is_init (s))
8405         ffeglobal_init_common (ffestc_local_.common.symbol, name);
8406 #endif
8407       if (ffesymbol_is_save (ffestc_local_.common.symbol))
8408         ffesymbol_update_save (s);
8409       if (ffesymbol_equiv (s) != NULL)
8410         {                       /* Is this newly COMMONed symbol involved in
8411                                    an equivalence? */
8412           if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
8413             ffeequiv_set_common (ffesymbol_equiv (s),   /* Yes, tell equiv obj. */
8414                                  ffestc_local_.common.symbol);
8415 #if FFEGLOBAL_ENABLED
8416           if (ffeequiv_is_init (ffesymbol_equiv (s)))
8417             ffeglobal_init_common (ffestc_local_.common.symbol, name);
8418 #endif
8419           if (ffesymbol_is_save (ffestc_local_.common.symbol))
8420             ffeequiv_update_save (ffesymbol_equiv (s));
8421         }
8422       if (dims != NULL)
8423         {
8424           ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
8425                                                          &array_size,
8426                                                          &extents,
8427                                                          is_ugly_assumed));
8428           ffesymbol_set_arraysize (s, array_size);
8429           ffesymbol_set_extents (s, extents);
8430           if (!(0 && ffe_is_90 ())
8431               && (ffebld_op (array_size) == FFEBLD_opCONTER)
8432               && (ffebld_constant_integerdefault (ffebld_conter (array_size))
8433                   == 0))
8434             {
8435               ffebad_start (FFEBAD_ZERO_ARRAY);
8436               ffebad_here (0, ffelex_token_where_line (name),
8437                            ffelex_token_where_column (name));
8438               ffebad_finish ();
8439             }
8440           ffesymbol_set_info (s,
8441                               ffeinfo_new (ffesymbol_basictype (s),
8442                                            ffesymbol_kindtype (s),
8443                                            rank,
8444                                            ffesymbol_kind (s),
8445                                            ffesymbol_where (s),
8446                                            ffesymbol_size (s)));
8447         }
8448       ffesymbol_signal_unreported (s);
8449     }
8450
8451   if (ffestc_parent_ok_)
8452     {
8453       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8454                              FFEINTRIN_impNONE);
8455       ffebld_set_info (e,
8456                        ffeinfo_new (FFEINFO_basictypeNONE,
8457                                     FFEINFO_kindtypeNONE,
8458                                     0,
8459                                     FFEINFO_kindNONE,
8460                                     FFEINFO_whereNONE,
8461                                     FFETARGET_charactersizeNONE));
8462       ffebld_append_item
8463         (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
8464     }
8465
8466   ffestd_R547_item_object (name, dims);
8467 }
8468
8469 /* ffestc_R547_item_cblock -- COMMON statement for common-block-name
8470
8471    ffestc_R547_item_cblock(name_token);
8472
8473    Make sure name_token identifies a valid common block to be COMMONd.  */
8474
8475 void
8476 ffestc_R547_item_cblock (ffelexToken name)
8477 {
8478   ffesymbol s;
8479   ffesymbolAttrs sa;
8480   ffesymbolAttrs na;
8481
8482   ffestc_check_item_ ();
8483   if (!ffestc_ok_)
8484     return;
8485
8486   if (ffestc_local_.common.symbol != NULL)
8487     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8488
8489   s = ffesymbol_declare_cblock (name,
8490                                 ffelex_token_where_line (ffesta_tokens[0]),
8491                               ffelex_token_where_column (ffesta_tokens[0]));
8492   sa = ffesymbol_attrs (s);
8493
8494   /* Figure out what kind of object we've got based on previous declarations
8495      of or references to the object. */
8496
8497   if (!ffesymbol_is_specable (s))
8498     na = FFESYMBOL_attrsetNONE;
8499   else if (sa & FFESYMBOL_attrsANY)
8500     na = FFESYMBOL_attrsANY;    /* Already have an error here, say nothing. */
8501   else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
8502                     | FFESYMBOL_attrsSAVECBLOCK)))
8503     {
8504       if (!(sa & FFESYMBOL_attrsCBLOCK))
8505         ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
8506                           ffesymbol_ptr_to_listbottom (s));
8507       na = sa | FFESYMBOL_attrsCBLOCK;
8508     }
8509   else
8510     na = FFESYMBOL_attrsetNONE;
8511
8512   /* Now see what we've got for a new object: NONE means a new error cropped
8513      up; ANY means an old error to be ignored; otherwise, everything's ok,
8514      update the object (symbol) and continue on. */
8515
8516   if (na == FFESYMBOL_attrsetNONE)
8517     {
8518       ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
8519       ffestc_parent_ok_ = FALSE;
8520     }
8521   else if (na & FFESYMBOL_attrsANY)
8522     ffestc_parent_ok_ = FALSE;
8523   else
8524     {
8525       ffesymbol_set_attrs (s, na);
8526       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
8527       if (name == NULL)
8528         ffesymbol_update_save (s);
8529       ffestc_parent_ok_ = TRUE;
8530     }
8531
8532   ffestc_local_.common.symbol = s;
8533
8534   ffestd_R547_item_cblock (name);
8535 }
8536
8537 /* ffestc_R547_finish -- COMMON statement list complete
8538
8539    ffestc_R547_finish();
8540
8541    Just wrap up any local activities.  */
8542
8543 void
8544 ffestc_R547_finish ()
8545 {
8546   ffestc_check_finish_ ();
8547   if (!ffestc_ok_)
8548     return;
8549
8550   if (ffestc_local_.common.symbol != NULL)
8551     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
8552
8553   ffestd_R547_finish ();
8554 }
8555
8556 /* ffestc_R620 -- ALLOCATE statement
8557
8558    ffestc_R620(exprlist,stat,stat_token);
8559
8560    Make sure the expression list is valid, then implement it.  */
8561
8562 #if FFESTR_F90
8563 void
8564 ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8565 {
8566   ffestc_check_simple_ ();
8567   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8568     return;
8569   ffestc_labeldef_branch_begin_ ();
8570
8571   ffestd_R620 (exprlist, stat);
8572
8573   if (ffestc_shriek_after1_ != NULL)
8574     (*ffestc_shriek_after1_) (TRUE);
8575   ffestc_labeldef_branch_end_ ();
8576 }
8577
8578 /* ffestc_R624 -- NULLIFY statement
8579
8580    ffestc_R624(pointer_name_list);
8581
8582    Make sure pointer_name_list identifies valid pointers for a NULLIFY.  */
8583
8584 void
8585 ffestc_R624 (ffesttExprList pointers)
8586 {
8587   ffestc_check_simple_ ();
8588   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8589     return;
8590   ffestc_labeldef_branch_begin_ ();
8591
8592   ffestd_R624 (pointers);
8593
8594   if (ffestc_shriek_after1_ != NULL)
8595     (*ffestc_shriek_after1_) (TRUE);
8596   ffestc_labeldef_branch_end_ ();
8597 }
8598
8599 /* ffestc_R625 -- DEALLOCATE statement
8600
8601    ffestc_R625(exprlist,stat,stat_token);
8602
8603    Make sure the equivalence is valid, then implement it.  */
8604
8605 void
8606 ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
8607 {
8608   ffestc_check_simple_ ();
8609   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8610     return;
8611   ffestc_labeldef_branch_begin_ ();
8612
8613   ffestd_R625 (exprlist, stat);
8614
8615   if (ffestc_shriek_after1_ != NULL)
8616     (*ffestc_shriek_after1_) (TRUE);
8617   ffestc_labeldef_branch_end_ ();
8618 }
8619
8620 #endif
8621 /* ffestc_let -- R1213 or R737
8622
8623    ffestc_let(...);
8624
8625    Verify that R1213 defined-assignment or R737 assignment-stmt are
8626    valid here, figure out which one, and implement.  */
8627
8628 #if FFESTR_F90
8629 void
8630 ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
8631 {
8632   ffestc_R737 (dest, source, source_token);
8633 }
8634
8635 #endif
8636 /* ffestc_R737 -- Assignment statement
8637
8638    ffestc_R737(dest_expr,source_expr,source_token);
8639
8640    Make sure the assignment is valid.  */
8641
8642 void
8643 ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
8644 {
8645   ffestc_check_simple_ ();
8646
8647   switch (ffestw_state (ffestw_stack_top ()))
8648     {
8649 #if FFESTR_F90
8650     case FFESTV_stateWHERE:
8651     case FFESTV_stateWHERETHEN:
8652       if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8653         return;
8654       ffestc_labeldef_useless_ ();
8655
8656       ffestd_R737B (dest, source);
8657
8658       if (ffestc_shriek_after1_ != NULL)
8659         (*ffestc_shriek_after1_) (TRUE);
8660       return;
8661 #endif
8662
8663     default:
8664       break;
8665     }
8666
8667   if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
8668     return;
8669   ffestc_labeldef_branch_begin_ ();
8670
8671   source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
8672                                  FFEEXPR_contextLET);
8673
8674   ffestd_R737A (dest, source);
8675
8676   if (ffestc_shriek_after1_ != NULL)
8677     (*ffestc_shriek_after1_) (TRUE);
8678   ffestc_labeldef_branch_end_ ();
8679 }
8680
8681 /* ffestc_R738 -- Pointer assignment statement
8682
8683    ffestc_R738(dest_expr,source_expr,source_token);
8684
8685    Make sure the assignment is valid.  */
8686
8687 #if FFESTR_F90
8688 void
8689 ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
8690 {
8691   ffestc_check_simple_ ();
8692   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8693     return;
8694   ffestc_labeldef_branch_begin_ ();
8695
8696   ffestd_R738 (dest, source);
8697
8698   if (ffestc_shriek_after1_ != NULL)
8699     (*ffestc_shriek_after1_) (TRUE);
8700   ffestc_labeldef_branch_end_ ();
8701 }
8702
8703 /* ffestc_R740 -- WHERE statement
8704
8705    ffestc_R740(expr,expr_token);
8706
8707    Make sure statement is valid here; implement.  */
8708
8709 void
8710 ffestc_R740 (ffebld expr, ffelexToken expr_token)
8711 {
8712   ffestw b;
8713
8714   ffestc_check_simple_ ();
8715   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
8716     return;
8717   ffestc_labeldef_branch_begin_ ();
8718
8719   b = ffestw_update (ffestw_push (NULL));
8720   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8721   ffestw_set_state (b, FFESTV_stateWHERE);
8722   ffestw_set_blocknum (b, ffestc_blocknum_++);
8723   ffestw_set_shriek (b, ffestc_shriek_where_lost_);
8724
8725   ffestd_R740 (expr);
8726
8727   /* Leave label finishing to next statement. */
8728
8729 }
8730
8731 /* ffestc_R742 -- WHERE-construct statement
8732
8733    ffestc_R742(expr,expr_token);
8734
8735    Make sure statement is valid here; implement.  */
8736
8737 void
8738 ffestc_R742 (ffebld expr, ffelexToken expr_token)
8739 {
8740   ffestw b;
8741
8742   ffestc_check_simple_ ();
8743   if (ffestc_order_exec_ () != FFESTC_orderOK_)
8744     return;
8745   ffestc_labeldef_notloop_probably_this_wont_work_ ();
8746
8747   b = ffestw_update (ffestw_push (NULL));
8748   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8749   ffestw_set_state (b, FFESTV_stateWHERETHEN);
8750   ffestw_set_blocknum (b, ffestc_blocknum_++);
8751   ffestw_set_shriek (b, ffestc_shriek_wherethen_);
8752   ffestw_set_substate (b, 0);   /* Haven't seen ELSEWHERE yet. */
8753
8754   ffestd_R742 (expr);
8755 }
8756
8757 /* ffestc_R744 -- ELSE WHERE statement
8758
8759    ffestc_R744();
8760
8761    Make sure ffestc_kind_ identifies a WHERE block.
8762    Implement the ELSE of the current WHERE block.  */
8763
8764 void
8765 ffestc_R744 ()
8766 {
8767   ffestc_check_simple_ ();
8768   if (ffestc_order_where_ () != FFESTC_orderOK_)
8769     return;
8770   ffestc_labeldef_useless_ ();
8771
8772   if (ffestw_substate (ffestw_stack_top ()) != 0)
8773     {
8774       ffebad_start (FFEBAD_SECOND_ELSE_WHERE);
8775       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8776                    ffelex_token_where_column (ffesta_tokens[0]));
8777       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8778       ffebad_finish ();
8779     }
8780
8781   ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */
8782
8783   ffestd_R744 ();
8784 }
8785
8786 /* ffestc_R745 -- END WHERE statement
8787
8788    ffestc_R745();
8789
8790    Make sure ffestc_kind_ identifies a WHERE block.
8791    Implement the end of the current WHERE block.  */
8792
8793 void
8794 ffestc_R745 ()
8795 {
8796   ffestc_check_simple_ ();
8797   if (ffestc_order_where_ () != FFESTC_orderOK_)
8798     return;
8799   ffestc_labeldef_useless_ ();
8800
8801   ffestc_shriek_wherethen_ (TRUE);
8802 }
8803
8804 #endif
8805 /* ffestc_R803 -- Block IF (IF-THEN) statement
8806
8807    ffestc_R803(construct_name,expr,expr_token);
8808
8809    Make sure statement is valid here; implement.  */
8810
8811 void
8812 ffestc_R803 (ffelexToken construct_name, ffebld expr,
8813              ffelexToken expr_token UNUSED)
8814 {
8815   ffestw b;
8816   ffesymbol s;
8817
8818   ffestc_check_simple_ ();
8819   if (ffestc_order_exec_ () != FFESTC_orderOK_)
8820     return;
8821   ffestc_labeldef_notloop_ ();
8822
8823   b = ffestw_update (ffestw_push (NULL));
8824   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
8825   ffestw_set_state (b, FFESTV_stateIFTHEN);
8826   ffestw_set_blocknum (b, ffestc_blocknum_++);
8827   ffestw_set_shriek (b, ffestc_shriek_ifthen_);
8828   ffestw_set_substate (b, 0);   /* Haven't seen ELSE yet. */
8829
8830   if (construct_name == NULL)
8831     ffestw_set_name (b, NULL);
8832   else
8833     {
8834       ffestw_set_name (b, ffelex_token_use (construct_name));
8835
8836       s = ffesymbol_declare_local (construct_name, FALSE);
8837
8838       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
8839         {
8840           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
8841           ffesymbol_set_info (s,
8842                               ffeinfo_new (FFEINFO_basictypeNONE,
8843                                            FFEINFO_kindtypeNONE,
8844                                            0,
8845                                            FFEINFO_kindCONSTRUCT,
8846                                            FFEINFO_whereLOCAL,
8847                                            FFETARGET_charactersizeNONE));
8848           s = ffecom_sym_learned (s);
8849           ffesymbol_signal_unreported (s);
8850         }
8851       else
8852         ffesymbol_error (s, construct_name);
8853     }
8854
8855   ffestd_R803 (construct_name, expr);
8856 }
8857
8858 /* ffestc_R804 -- ELSE IF statement
8859
8860    ffestc_R804(expr,expr_token,name_token);
8861
8862    Make sure ffestc_kind_ identifies an IF block.  If not
8863    NULL, make sure name_token gives the correct name.  Implement the else
8864    of the IF block.  */
8865
8866 void
8867 ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
8868              ffelexToken name)
8869 {
8870   ffestc_check_simple_ ();
8871   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8872     return;
8873   ffestc_labeldef_useless_ ();
8874
8875   if (name != NULL)
8876     {
8877       if (ffestw_name (ffestw_stack_top ()) == NULL)
8878         {
8879           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8880           ffebad_here (0, ffelex_token_where_line (name),
8881                        ffelex_token_where_column (name));
8882           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8883           ffebad_finish ();
8884         }
8885       else if (ffelex_token_strcmp (name,
8886                                     ffestw_name (ffestw_stack_top ()))
8887                != 0)
8888         {
8889           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
8890           ffebad_here (0, ffelex_token_where_line (name),
8891                        ffelex_token_where_column (name));
8892           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
8893              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
8894           ffebad_finish ();
8895         }
8896     }
8897
8898   if (ffestw_substate (ffestw_stack_top ()) != 0)
8899     {
8900       ffebad_start (FFEBAD_AFTER_ELSE);
8901       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8902                    ffelex_token_where_column (ffesta_tokens[0]));
8903       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8904       ffebad_finish ();
8905       return;                   /* Don't upset back end with ELSEIF
8906                                    after ELSE. */
8907     }
8908
8909   ffestd_R804 (expr, name);
8910 }
8911
8912 /* ffestc_R805 -- ELSE statement
8913
8914    ffestc_R805(name_token);
8915
8916    Make sure ffestc_kind_ identifies an IF block.  If not
8917    NULL, make sure name_token gives the correct name.  Implement the ELSE
8918    of the IF block.  */
8919
8920 void
8921 ffestc_R805 (ffelexToken name)
8922 {
8923   ffestc_check_simple_ ();
8924   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8925     return;
8926   ffestc_labeldef_useless_ ();
8927
8928   if (name != NULL)
8929     {
8930       if (ffestw_name (ffestw_stack_top ()) == NULL)
8931         {
8932           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8933           ffebad_here (0, ffelex_token_where_line (name),
8934                        ffelex_token_where_column (name));
8935           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8936           ffebad_finish ();
8937         }
8938       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
8939         {
8940           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
8941           ffebad_here (0, ffelex_token_where_line (name),
8942                        ffelex_token_where_column (name));
8943           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
8944              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
8945           ffebad_finish ();
8946         }
8947     }
8948
8949   if (ffestw_substate (ffestw_stack_top ()) != 0)
8950     {
8951       ffebad_start (FFEBAD_AFTER_ELSE);
8952       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8953                    ffelex_token_where_column (ffesta_tokens[0]));
8954       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8955       ffebad_finish ();
8956       return;                   /* Tell back end about only one ELSE. */
8957     }
8958
8959   ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
8960
8961   ffestd_R805 (name);
8962 }
8963
8964 /* ffestc_R806 -- END IF statement
8965
8966    ffestc_R806(name_token);
8967
8968    Make sure ffestc_kind_ identifies an IF block.  If not
8969    NULL, make sure name_token gives the correct name.  Implement the end
8970    of the IF block.  */
8971
8972 void
8973 ffestc_R806 (ffelexToken name)
8974 {
8975   ffestc_check_simple_ ();
8976   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
8977     return;
8978   ffestc_labeldef_endif_ ();
8979
8980   if (name == NULL)
8981     {
8982       if (ffestw_name (ffestw_stack_top ()) != NULL)
8983         {
8984           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
8985           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
8986                        ffelex_token_where_column (ffesta_tokens[0]));
8987           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8988           ffebad_finish ();
8989         }
8990     }
8991   else
8992     {
8993       if (ffestw_name (ffestw_stack_top ()) == NULL)
8994         {
8995           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
8996           ffebad_here (0, ffelex_token_where_line (name),
8997                        ffelex_token_where_column (name));
8998           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
8999           ffebad_finish ();
9000         }
9001       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
9002         {
9003           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9004           ffebad_here (0, ffelex_token_where_line (name),
9005                        ffelex_token_where_column (name));
9006           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9007              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9008           ffebad_finish ();
9009         }
9010     }
9011
9012   ffestc_shriek_ifthen_ (TRUE);
9013 }
9014
9015 /* ffestc_R807 -- Logical IF statement
9016
9017    ffestc_R807(expr,expr_token);
9018
9019    Make sure statement is valid here; implement.  */
9020
9021 void
9022 ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
9023 {
9024   ffestw b;
9025
9026   ffestc_check_simple_ ();
9027   if (ffestc_order_action_ () != FFESTC_orderOK_)
9028     return;
9029   ffestc_labeldef_branch_begin_ ();
9030
9031   b = ffestw_update (ffestw_push (NULL));
9032   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
9033   ffestw_set_state (b, FFESTV_stateIF);
9034   ffestw_set_blocknum (b, ffestc_blocknum_++);
9035   ffestw_set_shriek (b, ffestc_shriek_if_lost_);
9036
9037   ffestd_R807 (expr);
9038
9039   /* Do the label finishing in the next statement. */
9040
9041 }
9042
9043 /* ffestc_R809 -- SELECT CASE statement
9044
9045    ffestc_R809(construct_name,expr,expr_token);
9046
9047    Make sure statement is valid here; implement.  */
9048
9049 void
9050 ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
9051 {
9052   ffestw b;
9053   mallocPool pool;
9054   ffestwSelect s;
9055   ffesymbol sym;
9056
9057   ffestc_check_simple_ ();
9058   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9059     return;
9060   ffestc_labeldef_notloop_ ();
9061
9062   b = ffestw_update (ffestw_push (NULL));
9063   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
9064   ffestw_set_state (b, FFESTV_stateSELECT0);
9065   ffestw_set_blocknum (b, ffestc_blocknum_++);
9066   ffestw_set_shriek (b, ffestc_shriek_select_);
9067   ffestw_set_substate (b, 0);   /* Haven't seen CASE DEFAULT yet. */
9068
9069   /* Init block to manage CASE list. */
9070
9071   pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
9072   s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
9073   s->first_rel = (ffestwCase) &s->first_rel;
9074   s->last_rel = (ffestwCase) &s->first_rel;
9075   s->first_stmt = (ffestwCase) &s->first_rel;
9076   s->last_stmt = (ffestwCase) &s->first_rel;
9077   s->pool = pool;
9078   s->cases = 1;
9079   s->t = ffelex_token_use (expr_token);
9080   s->type = ffeinfo_basictype (ffebld_info (expr));
9081   s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
9082   ffestw_set_select (b, s);
9083
9084   if (construct_name == NULL)
9085     ffestw_set_name (b, NULL);
9086   else
9087     {
9088       ffestw_set_name (b, ffelex_token_use (construct_name));
9089
9090       sym = ffesymbol_declare_local (construct_name, FALSE);
9091
9092       if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
9093         {
9094           ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
9095           ffesymbol_set_info (sym,
9096                               ffeinfo_new (FFEINFO_basictypeNONE,
9097                                            FFEINFO_kindtypeNONE, 0,
9098                                            FFEINFO_kindCONSTRUCT,
9099                                            FFEINFO_whereLOCAL,
9100                                            FFETARGET_charactersizeNONE));
9101           sym = ffecom_sym_learned (sym);
9102           ffesymbol_signal_unreported (sym);
9103         }
9104       else
9105         ffesymbol_error (sym, construct_name);
9106     }
9107
9108   ffestd_R809 (construct_name, expr);
9109 }
9110
9111 /* ffestc_R810 -- CASE statement
9112
9113    ffestc_R810(case_value_range_list,name);
9114
9115    If case_value_range_list is NULL, it's CASE DEFAULT.  name is the case-
9116    construct-name.  Make sure no more than one CASE DEFAULT is present for
9117    a given case-construct and that there aren't any overlapping ranges or
9118    duplicate case values.  */
9119
9120 void
9121 ffestc_R810 (ffesttCaseList cases, ffelexToken name)
9122 {
9123   ffesttCaseList caseobj;
9124   ffestwSelect s;
9125   ffestwCase c, nc;
9126   ffebldConstant expr1c, expr2c;
9127
9128   ffestc_check_simple_ ();
9129   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9130     return;
9131   ffestc_labeldef_useless_ ();
9132
9133   s = ffestw_select (ffestw_stack_top ());
9134
9135   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
9136     {
9137 #if 0                           /* Not sure we want to have msgs point here
9138                                    instead of SELECT CASE. */
9139       ffestw_update (NULL);     /* Update state line/col info. */
9140 #endif
9141       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
9142     }
9143
9144   if (name != NULL)
9145     {
9146       if (ffestw_name (ffestw_stack_top ()) == NULL)
9147         {
9148           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9149           ffebad_here (0, ffelex_token_where_line (name),
9150                        ffelex_token_where_column (name));
9151           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9152           ffebad_finish ();
9153         }
9154       else if (ffelex_token_strcmp (name,
9155                                     ffestw_name (ffestw_stack_top ()))
9156                != 0)
9157         {
9158           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9159           ffebad_here (0, ffelex_token_where_line (name),
9160                        ffelex_token_where_column (name));
9161           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9162              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9163           ffebad_finish ();
9164         }
9165     }
9166
9167   if (cases == NULL)
9168     {
9169       if (ffestw_substate (ffestw_stack_top ()) != 0)
9170         {
9171           ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
9172           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9173                        ffelex_token_where_column (ffesta_tokens[0]));
9174           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9175           ffebad_finish ();
9176         }
9177
9178       ffestw_set_substate (ffestw_stack_top (), 1);     /* Saw ELSE. */
9179     }
9180   else
9181     {                           /* For each case, try to fit into sorted list
9182                                    of ranges. */
9183       for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
9184         {
9185           if ((caseobj->expr1 == NULL)
9186               && (!caseobj->range
9187                   || (caseobj->expr2 == NULL)))
9188             {                   /* "CASE (:)". */
9189               ffebad_start (FFEBAD_CASE_BAD_RANGE);
9190               ffebad_here (0, ffelex_token_where_line (caseobj->t),
9191                            ffelex_token_where_column (caseobj->t));
9192               ffebad_finish ();
9193               continue;
9194             }
9195
9196           if (((caseobj->expr1 != NULL)
9197                && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
9198                     != s->type)
9199                    || (ffeinfo_kindtype (ffebld_info (caseobj->expr1))
9200                        != s->kindtype)))
9201               || ((caseobj->range)
9202                   && (caseobj->expr2 != NULL)
9203                   && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
9204                        != s->type)
9205                       || (ffeinfo_kindtype (ffebld_info (caseobj->expr2))
9206                           != s->kindtype))))
9207             {
9208               ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
9209               ffebad_here (0, ffelex_token_where_line (caseobj->t),
9210                            ffelex_token_where_column (caseobj->t));
9211               ffebad_here (1, ffelex_token_where_line (s->t),
9212                            ffelex_token_where_column (s->t));
9213               ffebad_finish ();
9214               continue;
9215             }
9216
9217           if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
9218             {
9219               ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
9220               ffebad_here (0, ffelex_token_where_line (caseobj->t),
9221                            ffelex_token_where_column (caseobj->t));
9222               ffebad_finish ();
9223               continue;
9224             }
9225
9226           if (caseobj->expr1 == NULL)
9227             expr1c = NULL;
9228           else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
9229             continue;           /* opANY. */
9230           else
9231             expr1c = ffebld_conter (caseobj->expr1);
9232
9233           if (!caseobj->range)
9234             expr2c = expr1c;    /* expr1c and expr2c are NOT NULL in this
9235                                    case. */
9236           else if (caseobj->expr2 == NULL)
9237             expr2c = NULL;
9238           else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
9239             continue;           /* opANY. */
9240           else
9241             expr2c = ffebld_conter (caseobj->expr2);
9242
9243           if (expr1c == NULL)
9244             {                   /* "CASE (:high)", must be first in list. */
9245               c = s->first_rel;
9246               if ((c != (ffestwCase) &s->first_rel)
9247                   && ((c->low == NULL)
9248                       || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
9249                 {               /* Other "CASE (:high)" or lowest "CASE
9250                                    (low[:high])" low. */
9251                   ffebad_start (FFEBAD_CASE_DUPLICATE);
9252                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9253                                ffelex_token_where_column (caseobj->t));
9254                   ffebad_here (1, ffelex_token_where_line (c->t),
9255                                ffelex_token_where_column (c->t));
9256                   ffebad_finish ();
9257                   continue;
9258                 }
9259             }
9260           else if (expr2c == NULL)
9261             {                   /* "CASE (low:)", must be last in list. */
9262               c = s->last_rel;
9263               if ((c != (ffestwCase) &s->first_rel)
9264                   && ((c->high == NULL)
9265                       || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
9266                 {               /* Other "CASE (low:)" or lowest "CASE
9267                                    ([low:]high)" high. */
9268                   ffebad_start (FFEBAD_CASE_DUPLICATE);
9269                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9270                                ffelex_token_where_column (caseobj->t));
9271                   ffebad_here (1, ffelex_token_where_line (c->t),
9272                                ffelex_token_where_column (c->t));
9273                   ffebad_finish ();
9274                   continue;
9275                 }
9276               c = c->next_rel;  /* Same as c = (ffestwCase) &s->first;. */
9277             }
9278           else
9279             {                   /* (expr1c != NULL) && (expr2c != NULL). */
9280               if (ffebld_constant_cmp (expr1c, expr2c) > 0)
9281                 {               /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
9282                   ffebad_start (FFEBAD_CASE_RANGE_USELESS);     /* Warn/inform only. */
9283                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9284                                ffelex_token_where_column (caseobj->t));
9285                   ffebad_finish ();
9286                   continue;
9287                 }
9288               for (c = s->first_rel;
9289                    (c != (ffestwCase) &s->first_rel)
9290                    && ((c->low == NULL)
9291                        || (ffebld_constant_cmp (expr1c, c->low) > 0));
9292                    c = c->next_rel)
9293                 ;
9294               nc = c;           /* Which one to report? */
9295               if (((c != (ffestwCase) &s->first_rel)
9296                    && (ffebld_constant_cmp (expr2c, c->low) >= 0))
9297                   || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
9298                       && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
9299                 {               /* Interference with range in case nc. */
9300                   ffebad_start (FFEBAD_CASE_DUPLICATE);
9301                   ffebad_here (0, ffelex_token_where_line (caseobj->t),
9302                                ffelex_token_where_column (caseobj->t));
9303                   ffebad_here (1, ffelex_token_where_line (nc->t),
9304                                ffelex_token_where_column (nc->t));
9305                   ffebad_finish ();
9306                   continue;
9307                 }
9308             }
9309
9310           /* If we reach here for this case range/value, it's ok (sorts into
9311              the list of ranges/values) so we give it its own case object
9312              sorted into the list of case statements. */
9313
9314           nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
9315           nc->next_rel = c;
9316           nc->previous_rel = c->previous_rel;
9317           nc->next_stmt = (ffestwCase) &s->first_rel;
9318           nc->previous_stmt = s->last_stmt;
9319           nc->low = expr1c;
9320           nc->high = expr2c;
9321           nc->casenum = s->cases;
9322           nc->t = ffelex_token_use (caseobj->t);
9323           nc->next_rel->previous_rel = nc;
9324           nc->previous_rel->next_rel = nc;
9325           nc->next_stmt->previous_stmt = nc;
9326           nc->previous_stmt->next_stmt = nc;
9327         }
9328     }
9329
9330   ffestd_R810 ((cases == NULL) ? 0 : s->cases);
9331
9332   s->cases++;                   /* Increment # of cases. */
9333 }
9334
9335 /* ffestc_R811 -- END SELECT statement
9336
9337    ffestc_R811(name_token);
9338
9339    Make sure ffestc_kind_ identifies a SELECT block.  If not
9340    NULL, make sure name_token gives the correct name.  Implement the end
9341    of the SELECT block.  */
9342
9343 void
9344 ffestc_R811 (ffelexToken name)
9345 {
9346   ffestc_check_simple_ ();
9347   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
9348     return;
9349   ffestc_labeldef_notloop_ ();
9350
9351   if (name == NULL)
9352     {
9353       if (ffestw_name (ffestw_stack_top ()) != NULL)
9354         {
9355           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9356           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9357                        ffelex_token_where_column (ffesta_tokens[0]));
9358           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9359           ffebad_finish ();
9360         }
9361     }
9362   else
9363     {
9364       if (ffestw_name (ffestw_stack_top ()) == NULL)
9365         {
9366           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9367           ffebad_here (0, ffelex_token_where_line (name),
9368                        ffelex_token_where_column (name));
9369           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9370           ffebad_finish ();
9371         }
9372       else if (ffelex_token_strcmp (name,
9373                                     ffestw_name (ffestw_stack_top ()))
9374                != 0)
9375         {
9376           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9377           ffebad_here (0, ffelex_token_where_line (name),
9378                        ffelex_token_where_column (name));
9379           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9380              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9381           ffebad_finish ();
9382         }
9383     }
9384
9385   ffestc_shriek_select_ (TRUE);
9386 }
9387
9388 /* ffestc_R819A -- Iterative labeled DO statement
9389
9390    ffestc_R819A(construct_name,label_token,expr,expr_token);
9391
9392    Make sure statement is valid here; implement.  */
9393
9394 void
9395 ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
9396    ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
9397               ffelexToken end_token, ffebld incr, ffelexToken incr_token)
9398 {
9399   ffestw b;
9400   ffelab label;
9401   ffesymbol s;
9402   ffesymbol varsym;
9403
9404   ffestc_check_simple_ ();
9405   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9406     return;
9407   ffestc_labeldef_notloop_ ();
9408
9409   if (!ffestc_labelref_is_loopend_ (label_token, &label))
9410     return;
9411
9412   b = ffestw_update (ffestw_push (NULL));
9413   ffestw_set_top_do (b, b);
9414   ffestw_set_state (b, FFESTV_stateDO);
9415   ffestw_set_blocknum (b, ffestc_blocknum_++);
9416   ffestw_set_shriek (b, ffestc_shriek_do_);
9417   ffestw_set_label (b, label);
9418   switch (ffebld_op (var))
9419     {
9420     case FFEBLD_opSYMTER:
9421       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9422           && ffe_is_warn_surprising ())
9423         {
9424           ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
9425           ffebad_here (0, ffelex_token_where_line (var_token),
9426                        ffelex_token_where_column (var_token));
9427           ffebad_string (ffesymbol_text (ffebld_symter (var)));
9428           ffebad_finish ();
9429         }
9430       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9431         {                       /* Presumably already complained about by
9432                                    ffeexpr_lhs_. */
9433           ffesymbol_set_is_doiter (varsym, TRUE);
9434           ffestw_set_do_iter_var (b, varsym);
9435           ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9436           break;
9437         }
9438       /* Fall through. */
9439     case FFEBLD_opANY:
9440       ffestw_set_do_iter_var (b, NULL);
9441       ffestw_set_do_iter_var_t (b, NULL);
9442       break;
9443
9444     default:
9445       assert ("bad iter var" == NULL);
9446       break;
9447     }
9448
9449   if (construct_name == NULL)
9450     ffestw_set_name (b, NULL);
9451   else
9452     {
9453       ffestw_set_name (b, ffelex_token_use (construct_name));
9454
9455       s = ffesymbol_declare_local (construct_name, FALSE);
9456
9457       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9458         {
9459           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9460           ffesymbol_set_info (s,
9461                               ffeinfo_new (FFEINFO_basictypeNONE,
9462                                            FFEINFO_kindtypeNONE,
9463                                            0,
9464                                            FFEINFO_kindCONSTRUCT,
9465                                            FFEINFO_whereLOCAL,
9466                                            FFETARGET_charactersizeNONE));
9467           s = ffecom_sym_learned (s);
9468           ffesymbol_signal_unreported (s);
9469         }
9470       else
9471         ffesymbol_error (s, construct_name);
9472     }
9473
9474   if (incr == NULL)
9475     {
9476       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9477       ffebld_set_info (incr, ffeinfo_new
9478                        (FFEINFO_basictypeINTEGER,
9479                         FFEINFO_kindtypeINTEGERDEFAULT,
9480                         0,
9481                         FFEINFO_kindENTITY,
9482                         FFEINFO_whereCONSTANT,
9483                         FFETARGET_charactersizeNONE));
9484     }
9485
9486   start = ffeexpr_convert_expr (start, start_token, var, var_token,
9487                                 FFEEXPR_contextLET);
9488   end = ffeexpr_convert_expr (end, end_token, var, var_token,
9489                               FFEEXPR_contextLET);
9490   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9491                                FFEEXPR_contextLET);
9492
9493   ffestd_R819A (construct_name, label, var,
9494                 start, start_token,
9495                 end, end_token,
9496                 incr, incr_token);
9497 }
9498
9499 /* ffestc_R819B -- Labeled DO WHILE statement
9500
9501    ffestc_R819B(construct_name,label_token,expr,expr_token);
9502
9503    Make sure statement is valid here; implement.  */
9504
9505 void
9506 ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
9507               ffebld expr, ffelexToken expr_token UNUSED)
9508 {
9509   ffestw b;
9510   ffelab label;
9511   ffesymbol s;
9512
9513   ffestc_check_simple_ ();
9514   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9515     return;
9516   ffestc_labeldef_notloop_ ();
9517
9518   if (!ffestc_labelref_is_loopend_ (label_token, &label))
9519     return;
9520
9521   b = ffestw_update (ffestw_push (NULL));
9522   ffestw_set_top_do (b, b);
9523   ffestw_set_state (b, FFESTV_stateDO);
9524   ffestw_set_blocknum (b, ffestc_blocknum_++);
9525   ffestw_set_shriek (b, ffestc_shriek_do_);
9526   ffestw_set_label (b, label);
9527   ffestw_set_do_iter_var (b, NULL);
9528   ffestw_set_do_iter_var_t (b, NULL);
9529
9530   if (construct_name == NULL)
9531     ffestw_set_name (b, NULL);
9532   else
9533     {
9534       ffestw_set_name (b, ffelex_token_use (construct_name));
9535
9536       s = ffesymbol_declare_local (construct_name, FALSE);
9537
9538       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9539         {
9540           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9541           ffesymbol_set_info (s,
9542                               ffeinfo_new (FFEINFO_basictypeNONE,
9543                                            FFEINFO_kindtypeNONE,
9544                                            0,
9545                                            FFEINFO_kindCONSTRUCT,
9546                                            FFEINFO_whereLOCAL,
9547                                            FFETARGET_charactersizeNONE));
9548           s = ffecom_sym_learned (s);
9549           ffesymbol_signal_unreported (s);
9550         }
9551       else
9552         ffesymbol_error (s, construct_name);
9553     }
9554
9555   ffestd_R819B (construct_name, label, expr);
9556 }
9557
9558 /* ffestc_R820A -- Iterative nonlabeled DO statement
9559
9560    ffestc_R820A(construct_name,expr,expr_token);
9561
9562    Make sure statement is valid here; implement.  */
9563
9564 void
9565 ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
9566    ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
9567               ffebld incr, ffelexToken incr_token)
9568 {
9569   ffestw b;
9570   ffesymbol s;
9571   ffesymbol varsym;
9572
9573   ffestc_check_simple_ ();
9574   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9575     return;
9576   ffestc_labeldef_notloop_ ();
9577
9578   b = ffestw_update (ffestw_push (NULL));
9579   ffestw_set_top_do (b, b);
9580   ffestw_set_state (b, FFESTV_stateDO);
9581   ffestw_set_blocknum (b, ffestc_blocknum_++);
9582   ffestw_set_shriek (b, ffestc_shriek_do_);
9583   ffestw_set_label (b, NULL);
9584   switch (ffebld_op (var))
9585     {
9586     case FFEBLD_opSYMTER:
9587       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
9588           && ffe_is_warn_surprising ())
9589         {
9590           ffebad_start (FFEBAD_DO_REAL);        /* See error message!!! */
9591           ffebad_here (0, ffelex_token_where_line (var_token),
9592                        ffelex_token_where_column (var_token));
9593           ffebad_string (ffesymbol_text (ffebld_symter (var)));
9594           ffebad_finish ();
9595         }
9596       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
9597         {                       /* Presumably already complained about by
9598                                    ffeexpr_lhs_. */
9599           ffesymbol_set_is_doiter (varsym, TRUE);
9600           ffestw_set_do_iter_var (b, varsym);
9601           ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
9602           break;
9603         }
9604       /* Fall through. */
9605     case FFEBLD_opANY:
9606       ffestw_set_do_iter_var (b, NULL);
9607       ffestw_set_do_iter_var_t (b, NULL);
9608       break;
9609
9610     default:
9611       assert ("bad iter var" == NULL);
9612       break;
9613     }
9614
9615   if (construct_name == NULL)
9616     ffestw_set_name (b, NULL);
9617   else
9618     {
9619       ffestw_set_name (b, ffelex_token_use (construct_name));
9620
9621       s = ffesymbol_declare_local (construct_name, FALSE);
9622
9623       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9624         {
9625           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9626           ffesymbol_set_info (s,
9627                               ffeinfo_new (FFEINFO_basictypeNONE,
9628                                            FFEINFO_kindtypeNONE,
9629                                            0,
9630                                            FFEINFO_kindCONSTRUCT,
9631                                            FFEINFO_whereLOCAL,
9632                                            FFETARGET_charactersizeNONE));
9633           s = ffecom_sym_learned (s);
9634           ffesymbol_signal_unreported (s);
9635         }
9636       else
9637         ffesymbol_error (s, construct_name);
9638     }
9639
9640   if (incr == NULL)
9641     {
9642       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
9643       ffebld_set_info (incr, ffeinfo_new
9644                        (FFEINFO_basictypeINTEGER,
9645                         FFEINFO_kindtypeINTEGERDEFAULT,
9646                         0,
9647                         FFEINFO_kindENTITY,
9648                         FFEINFO_whereCONSTANT,
9649                         FFETARGET_charactersizeNONE));
9650     }
9651
9652   start = ffeexpr_convert_expr (start, start_token, var, var_token,
9653                                 FFEEXPR_contextLET);
9654   end = ffeexpr_convert_expr (end, end_token, var, var_token,
9655                               FFEEXPR_contextLET);
9656   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
9657                                FFEEXPR_contextLET);
9658
9659 #if 0
9660   if ((ffebld_op (incr) == FFEBLD_opCONTER)
9661       && (ffebld_constant_is_zero (ffebld_conter (incr))))
9662     {
9663       ffebad_start (FFEBAD_DO_STEP_ZERO);
9664       ffebad_here (0, ffelex_token_where_line (incr_token),
9665                    ffelex_token_where_column (incr_token));
9666       ffebad_string ("Iterative DO loop");
9667       ffebad_finish ();
9668     }
9669 #endif
9670
9671   ffestd_R819A (construct_name, NULL, var,
9672                 start, start_token,
9673                 end, end_token,
9674                 incr, incr_token);
9675 }
9676
9677 /* ffestc_R820B -- Nonlabeled DO WHILE statement
9678
9679    ffestc_R820B(construct_name,expr,expr_token);
9680
9681    Make sure statement is valid here; implement.  */
9682
9683 void
9684 ffestc_R820B (ffelexToken construct_name, ffebld expr,
9685               ffelexToken expr_token UNUSED)
9686 {
9687   ffestw b;
9688   ffesymbol s;
9689
9690   ffestc_check_simple_ ();
9691   if (ffestc_order_exec_ () != FFESTC_orderOK_)
9692     return;
9693   ffestc_labeldef_notloop_ ();
9694
9695   b = ffestw_update (ffestw_push (NULL));
9696   ffestw_set_top_do (b, b);
9697   ffestw_set_state (b, FFESTV_stateDO);
9698   ffestw_set_blocknum (b, ffestc_blocknum_++);
9699   ffestw_set_shriek (b, ffestc_shriek_do_);
9700   ffestw_set_label (b, NULL);
9701   ffestw_set_do_iter_var (b, NULL);
9702   ffestw_set_do_iter_var_t (b, NULL);
9703
9704   if (construct_name == NULL)
9705     ffestw_set_name (b, NULL);
9706   else
9707     {
9708       ffestw_set_name (b, ffelex_token_use (construct_name));
9709
9710       s = ffesymbol_declare_local (construct_name, FALSE);
9711
9712       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
9713         {
9714           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
9715           ffesymbol_set_info (s,
9716                               ffeinfo_new (FFEINFO_basictypeNONE,
9717                                            FFEINFO_kindtypeNONE,
9718                                            0,
9719                                            FFEINFO_kindCONSTRUCT,
9720                                            FFEINFO_whereLOCAL,
9721                                            FFETARGET_charactersizeNONE));
9722           s = ffecom_sym_learned (s);
9723           ffesymbol_signal_unreported (s);
9724         }
9725       else
9726         ffesymbol_error (s, construct_name);
9727     }
9728
9729   ffestd_R819B (construct_name, NULL, expr);
9730 }
9731
9732 /* ffestc_R825 -- END DO statement
9733
9734    ffestc_R825(name_token);
9735
9736    Make sure ffestc_kind_ identifies a DO block.  If not
9737    NULL, make sure name_token gives the correct name.  Implement the end
9738    of the DO block.  */
9739
9740 void
9741 ffestc_R825 (ffelexToken name)
9742 {
9743   ffestc_check_simple_ ();
9744   if (ffestc_order_do_ () != FFESTC_orderOK_)
9745     return;
9746   ffestc_labeldef_branch_begin_ ();
9747
9748   if (name == NULL)
9749     {
9750       if (ffestw_name (ffestw_stack_top ()) != NULL)
9751         {
9752           ffebad_start (FFEBAD_CONSTRUCT_NAMED);
9753           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9754                        ffelex_token_where_column (ffesta_tokens[0]));
9755           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9756           ffebad_finish ();
9757         }
9758     }
9759   else
9760     {
9761       if (ffestw_name (ffestw_stack_top ()) == NULL)
9762         {
9763           ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
9764           ffebad_here (0, ffelex_token_where_line (name),
9765                        ffelex_token_where_column (name));
9766           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9767           ffebad_finish ();
9768         }
9769       else if (ffelex_token_strcmp (name,
9770                                     ffestw_name (ffestw_stack_top ()))
9771                != 0)
9772         {
9773           ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
9774           ffebad_here (0, ffelex_token_where_line (name),
9775                        ffelex_token_where_column (name));
9776           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
9777              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
9778           ffebad_finish ();
9779         }
9780     }
9781
9782   if (ffesta_label_token == NULL)
9783     {                           /* If top of stack has label, its an error! */
9784       if (ffestw_label (ffestw_stack_top ()) != NULL)
9785         {
9786           ffebad_start (FFEBAD_DO_HAD_LABEL);
9787           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
9788                        ffelex_token_where_column (ffesta_tokens[0]));
9789           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
9790           ffebad_finish ();
9791         }
9792
9793       ffestc_shriek_do_ (TRUE);
9794
9795       ffestc_try_shriek_do_ ();
9796
9797       return;
9798     }
9799
9800   ffestd_R825 (name);
9801
9802   ffestc_labeldef_branch_end_ ();
9803 }
9804
9805 /* ffestc_R834 -- CYCLE statement
9806
9807    ffestc_R834(name_token);
9808
9809    Handle a CYCLE within a loop.  */
9810
9811 void
9812 ffestc_R834 (ffelexToken name)
9813 {
9814   ffestw block;
9815
9816   ffestc_check_simple_ ();
9817   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9818     return;
9819   ffestc_labeldef_notloop_begin_ ();
9820
9821   if (name == NULL)
9822     block = ffestw_top_do (ffestw_stack_top ());
9823   else
9824     {                           /* Search for name. */
9825       for (block = ffestw_top_do (ffestw_stack_top ());
9826            (block != NULL) && (ffestw_blocknum (block) != 0);
9827            block = ffestw_top_do (ffestw_previous (block)))
9828         {
9829           if ((ffestw_name (block) != NULL)
9830               && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9831             break;
9832         }
9833       if ((block == NULL) || (ffestw_blocknum (block) == 0))
9834         {
9835           block = ffestw_top_do (ffestw_stack_top ());
9836           ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9837           ffebad_here (0, ffelex_token_where_line (name),
9838                        ffelex_token_where_column (name));
9839           ffebad_finish ();
9840         }
9841     }
9842
9843   ffestd_R834 (block);
9844
9845   if (ffestc_shriek_after1_ != NULL)
9846     (*ffestc_shriek_after1_) (TRUE);
9847
9848   /* notloop's that are actionif's can be the target of a loop-end
9849      statement if they're in the "then" part of a logical IF, as
9850      in "DO 10", "10 IF (...) CYCLE".  */
9851
9852   ffestc_labeldef_branch_end_ ();
9853 }
9854
9855 /* ffestc_R835 -- EXIT statement
9856
9857    ffestc_R835(name_token);
9858
9859    Handle a EXIT within a loop.  */
9860
9861 void
9862 ffestc_R835 (ffelexToken name)
9863 {
9864   ffestw block;
9865
9866   ffestc_check_simple_ ();
9867   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
9868     return;
9869   ffestc_labeldef_notloop_begin_ ();
9870
9871   if (name == NULL)
9872     block = ffestw_top_do (ffestw_stack_top ());
9873   else
9874     {                           /* Search for name. */
9875       for (block = ffestw_top_do (ffestw_stack_top ());
9876            (block != NULL) && (ffestw_blocknum (block) != 0);
9877            block = ffestw_top_do (ffestw_previous (block)))
9878         {
9879           if ((ffestw_name (block) != NULL)
9880               && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
9881             break;
9882         }
9883       if ((block == NULL) || (ffestw_blocknum (block) == 0))
9884         {
9885           block = ffestw_top_do (ffestw_stack_top ());
9886           ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
9887           ffebad_here (0, ffelex_token_where_line (name),
9888                        ffelex_token_where_column (name));
9889           ffebad_finish ();
9890         }
9891     }
9892
9893   ffestd_R835 (block);
9894
9895   if (ffestc_shriek_after1_ != NULL)
9896     (*ffestc_shriek_after1_) (TRUE);
9897
9898   /* notloop's that are actionif's can be the target of a loop-end
9899      statement if they're in the "then" part of a logical IF, as
9900      in "DO 10", "10 IF (...) EXIT".  */
9901
9902   ffestc_labeldef_branch_end_ ();
9903 }
9904
9905 /* ffestc_R836 -- GOTO statement
9906
9907    ffestc_R836(label_token);
9908
9909    Make sure label_token identifies a valid label for a GOTO.  Update
9910    that label's info to indicate it is the target of a GOTO.  */
9911
9912 void
9913 ffestc_R836 (ffelexToken label_token)
9914 {
9915   ffelab label;
9916
9917   ffestc_check_simple_ ();
9918   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9919     return;
9920   ffestc_labeldef_notloop_begin_ ();
9921
9922   if (ffestc_labelref_is_branch_ (label_token, &label))
9923     ffestd_R836 (label);
9924
9925   if (ffestc_shriek_after1_ != NULL)
9926     (*ffestc_shriek_after1_) (TRUE);
9927
9928   /* notloop's that are actionif's can be the target of a loop-end
9929      statement if they're in the "then" part of a logical IF, as
9930      in "DO 10", "10 IF (...) GOTO 100".  */
9931
9932   ffestc_labeldef_branch_end_ ();
9933 }
9934
9935 /* ffestc_R837 -- Computed GOTO statement
9936
9937    ffestc_R837(label_list,expr,expr_token);
9938
9939    Make sure label_list identifies valid labels for a GOTO.  Update
9940    each label's info to indicate it is the target of a GOTO.  */
9941
9942 void
9943 ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
9944              ffelexToken expr_token UNUSED)
9945 {
9946   ffesttTokenItem ti;
9947   bool ok = TRUE;
9948   int i;
9949   ffelab *labels;
9950
9951   assert (label_toks != NULL);
9952
9953   ffestc_check_simple_ ();
9954   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9955     return;
9956   ffestc_labeldef_branch_begin_ ();
9957
9958   labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
9959                           sizeof (*labels)
9960                           * ffestt_tokenlist_count (label_toks));
9961
9962   for (ti = label_toks->first, i = 0;
9963        ti != (ffesttTokenItem) &label_toks->first;
9964        ti = ti->next, ++i)
9965     {
9966       if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
9967         {
9968           ok = FALSE;
9969           break;
9970         }
9971     }
9972
9973   if (ok)
9974     ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
9975
9976   if (ffestc_shriek_after1_ != NULL)
9977     (*ffestc_shriek_after1_) (TRUE);
9978   ffestc_labeldef_branch_end_ ();
9979 }
9980
9981 /* ffestc_R838 -- ASSIGN statement
9982
9983    ffestc_R838(label_token,target_variable,target_token);
9984
9985    Make sure label_token identifies a valid label for an assignment.  Update
9986    that label's info to indicate it is the source of an assignment.  Update
9987    target_variable's info to indicate it is the target the assignment of that
9988    label.  */
9989
9990 void
9991 ffestc_R838 (ffelexToken label_token, ffebld target,
9992              ffelexToken target_token UNUSED)
9993 {
9994   ffelab label;
9995
9996   ffestc_check_simple_ ();
9997   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
9998     return;
9999   ffestc_labeldef_branch_begin_ ();
10000
10001   if (ffestc_labelref_is_assignable_ (label_token, &label))
10002     ffestd_R838 (label, target);
10003
10004   if (ffestc_shriek_after1_ != NULL)
10005     (*ffestc_shriek_after1_) (TRUE);
10006   ffestc_labeldef_branch_end_ ();
10007 }
10008
10009 /* ffestc_R839 -- Assigned GOTO statement
10010
10011    ffestc_R839(target,target_token,label_list);
10012
10013    Make sure label_list identifies valid labels for a GOTO.  Update
10014    each label's info to indicate it is the target of a GOTO.  */
10015
10016 void
10017 ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
10018              ffesttTokenList label_toks)
10019 {
10020   ffesttTokenItem ti;
10021   bool ok = TRUE;
10022   int i;
10023   ffelab *labels;
10024
10025   ffestc_check_simple_ ();
10026   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10027     return;
10028   ffestc_labeldef_notloop_begin_ ();
10029
10030   if (label_toks == NULL)
10031     {
10032       labels = NULL;
10033       i = 0;
10034     }
10035   else
10036     {
10037       labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
10038                     sizeof (*labels) * ffestt_tokenlist_count (label_toks));
10039
10040       for (ti = label_toks->first, i = 0;
10041            ti != (ffesttTokenItem) &label_toks->first;
10042            ti = ti->next, ++i)
10043         {
10044           if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
10045             {
10046               ok = FALSE;
10047               break;
10048             }
10049         }
10050     }
10051
10052   if (ok)
10053     ffestd_R839 (target, labels, i);
10054
10055   if (ffestc_shriek_after1_ != NULL)
10056     (*ffestc_shriek_after1_) (TRUE);
10057
10058   /* notloop's that are actionif's can be the target of a loop-end
10059      statement if they're in the "then" part of a logical IF, as
10060      in "DO 10", "10 IF (...) GOTO I".  */
10061
10062   ffestc_labeldef_branch_end_ ();
10063 }
10064
10065 /* ffestc_R840 -- Arithmetic IF statement
10066
10067    ffestc_R840(expr,expr_token,neg,zero,pos);
10068
10069    Make sure the labels are valid; implement.  */
10070
10071 void
10072 ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
10073              ffelexToken neg_token, ffelexToken zero_token,
10074              ffelexToken pos_token)
10075 {
10076   ffelab neg;
10077   ffelab zero;
10078   ffelab pos;
10079
10080   ffestc_check_simple_ ();
10081   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10082     return;
10083   ffestc_labeldef_notloop_begin_ ();
10084
10085   if (ffestc_labelref_is_branch_ (neg_token, &neg)
10086       && ffestc_labelref_is_branch_ (zero_token, &zero)
10087       && ffestc_labelref_is_branch_ (pos_token, &pos))
10088     ffestd_R840 (expr, neg, zero, pos);
10089
10090   if (ffestc_shriek_after1_ != NULL)
10091     (*ffestc_shriek_after1_) (TRUE);
10092
10093   /* notloop's that are actionif's can be the target of a loop-end
10094      statement if they're in the "then" part of a logical IF, as
10095      in "DO 10", "10 IF (...) GOTO (100,200,300), I".  */
10096
10097   ffestc_labeldef_branch_end_ ();
10098 }
10099
10100 /* ffestc_R841 -- CONTINUE statement
10101
10102    ffestc_R841();  */
10103
10104 void
10105 ffestc_R841 ()
10106 {
10107   ffestc_check_simple_ ();
10108
10109   if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
10110     return;
10111
10112   switch (ffestw_state (ffestw_stack_top ()))
10113     {
10114 #if FFESTR_F90
10115     case FFESTV_stateWHERE:
10116     case FFESTV_stateWHERETHEN:
10117       ffestc_labeldef_useless_ ();
10118
10119       ffestd_R841 (TRUE);
10120
10121       /* It's okay that we call ffestc_labeldef_branch_end_ () below,
10122          since that will be a no-op after calling _useless_ () above.  */
10123       break;
10124 #endif
10125
10126     default:
10127       ffestc_labeldef_branch_begin_ ();
10128
10129       ffestd_R841 (FALSE);
10130
10131       break;
10132     }
10133
10134   if (ffestc_shriek_after1_ != NULL)
10135     (*ffestc_shriek_after1_) (TRUE);
10136   ffestc_labeldef_branch_end_ ();
10137 }
10138
10139 /* ffestc_R842 -- STOP statement
10140
10141    ffestc_R842(expr,expr_token);
10142
10143    Make sure statement is valid here; implement.  expr and expr_token are
10144    both NULL if there was no expression.  */
10145
10146 void
10147 ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
10148 {
10149   ffestc_check_simple_ ();
10150   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10151     return;
10152   ffestc_labeldef_notloop_begin_ ();
10153
10154   ffestd_R842 (expr);
10155
10156   if (ffestc_shriek_after1_ != NULL)
10157     (*ffestc_shriek_after1_) (TRUE);
10158
10159   /* notloop's that are actionif's can be the target of a loop-end
10160      statement if they're in the "then" part of a logical IF, as
10161      in "DO 10", "10 IF (...) STOP".  */
10162
10163   ffestc_labeldef_branch_end_ ();
10164 }
10165
10166 /* ffestc_R843 -- PAUSE statement
10167
10168    ffestc_R843(expr,expr_token);
10169
10170    Make sure statement is valid here; implement.  expr and expr_token are
10171    both NULL if there was no expression.  */
10172
10173 void
10174 ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
10175 {
10176   ffestc_check_simple_ ();
10177   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10178     return;
10179   ffestc_labeldef_branch_begin_ ();
10180
10181   ffestd_R843 (expr);
10182
10183   if (ffestc_shriek_after1_ != NULL)
10184     (*ffestc_shriek_after1_) (TRUE);
10185   ffestc_labeldef_branch_end_ ();
10186 }
10187
10188 /* ffestc_R904 -- OPEN statement
10189
10190    ffestc_R904();
10191
10192    Make sure an OPEN is valid in the current context, and implement it.  */
10193
10194 void
10195 ffestc_R904 ()
10196 {
10197   int i;
10198   int expect_file;
10199   char *status_strs[]
10200   =
10201   {
10202     "New",
10203     "Old",
10204     "Replace",
10205     "Scratch",
10206     "Unknown"
10207   };
10208   char *access_strs[]
10209   =
10210   {
10211     "Append",
10212     "Direct",
10213     "Keyed",
10214     "Sequential"
10215   };
10216   char *blank_strs[]
10217   =
10218   {
10219     "Null",
10220     "Zero"
10221   };
10222   char *carriagecontrol_strs[]
10223   =
10224   {
10225     "Fortran",
10226     "List",
10227     "None"
10228   };
10229   char *dispose_strs[]
10230   =
10231   {
10232     "Delete",
10233     "Keep",
10234     "Print",
10235     "Print/Delete",
10236     "Save",
10237     "Submit",
10238     "Submit/Delete"
10239   };
10240   char *form_strs[]
10241   =
10242   {
10243     "Formatted",
10244     "Unformatted"
10245   };
10246   char *organization_strs[]
10247   =
10248   {
10249     "Indexed",
10250     "Relative",
10251     "Sequential"
10252   };
10253   char *position_strs[]
10254   =
10255   {
10256     "Append",
10257     "AsIs",
10258     "Rewind"
10259   };
10260   char *action_strs[]
10261   =
10262   {
10263     "Read",
10264     "ReadWrite",
10265     "Write"
10266   };
10267   char *delim_strs[]
10268   =
10269   {
10270     "Apostrophe",
10271     "None",
10272     "Quote"
10273   };
10274   char *recordtype_strs[]
10275   =
10276   {
10277     "Fixed",
10278     "Segmented",
10279     "Stream",
10280     "Stream_CR",
10281     "Stream_LF",
10282     "Variable"
10283   };
10284   char *pad_strs[]
10285   =
10286   {
10287     "No",
10288     "Yes"
10289   };
10290
10291   ffestc_check_simple_ ();
10292   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10293     return;
10294   ffestc_labeldef_branch_begin_ ();
10295
10296   if (ffestc_subr_is_branch_
10297       (&ffestp_file.open.open_spec[FFESTP_openixERR])
10298       && ffestc_subr_is_present_ ("UNIT",
10299                             &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
10300     {
10301       i = ffestc_subr_binsrch_ (status_strs,
10302                                 ARRAY_SIZE (status_strs),
10303                            &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
10304                                 "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
10305       switch (i)
10306         {
10307         case 0:         /* Unknown. */
10308         case 5:         /* UNKNOWN. */
10309           expect_file = 2;      /* Unknown, don't care about FILE=. */
10310           break;
10311
10312         case 1:         /* NEW. */
10313         case 2:         /* OLD. */
10314           if (ffe_is_pedantic ())
10315             expect_file = 1;    /* Yes, need FILE=. */
10316           else
10317             expect_file = 2;    /* f2clib doesn't care about FILE=. */
10318           break;
10319
10320         case 3:         /* REPLACE. */
10321           expect_file = 1;      /* Yes, need FILE=. */
10322           break;
10323
10324         case 4:         /* SCRATCH. */
10325           expect_file = 0;      /* No, disallow FILE=. */
10326           break;
10327
10328         default:
10329           assert ("invalid _binsrch_ result" == NULL);
10330           expect_file = 0;
10331           break;
10332         }
10333       if ((expect_file == 0)
10334           && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10335         {
10336           ffebad_start (FFEBAD_CONFLICTING_SPECS);
10337           assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
10338           if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
10339             {
10340               ffebad_here (0, ffelex_token_where_line
10341                          (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
10342                            ffelex_token_where_column
10343                         (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
10344             }
10345           else
10346             {
10347               ffebad_here (0, ffelex_token_where_line
10348                       (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
10349                            ffelex_token_where_column
10350                      (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
10351             }
10352           assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10353           if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10354             {
10355               ffebad_here (1, ffelex_token_where_line
10356                        (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10357                            ffelex_token_where_column
10358                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10359             }
10360           else
10361             {
10362               ffebad_here (1, ffelex_token_where_line
10363                     (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10364                            ffelex_token_where_column
10365                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10366             }
10367           ffebad_finish ();
10368         }
10369       else if ((expect_file == 1)
10370         && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
10371         {
10372           ffebad_start (FFEBAD_MISSING_SPECIFIER);
10373           assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
10374           if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
10375             {
10376               ffebad_here (0, ffelex_token_where_line
10377                        (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
10378                            ffelex_token_where_column
10379                       (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
10380             }
10381           else
10382             {
10383               ffebad_here (0, ffelex_token_where_line
10384                     (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
10385                            ffelex_token_where_column
10386                    (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
10387             }
10388           ffebad_string ("FILE=");
10389           ffebad_finish ();
10390         }
10391
10392       ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
10393                             &ffestp_file.open.open_spec[FFESTP_openixACCESS],
10394                             "APPEND, DIRECT, KEYED, or SEQUENTIAL");
10395
10396       ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
10397                             &ffestp_file.open.open_spec[FFESTP_openixBLANK],
10398                             "NULL or ZERO");
10399
10400       ffestc_subr_binsrch_ (carriagecontrol_strs,
10401                             ARRAY_SIZE (carriagecontrol_strs),
10402                   &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
10403                             "FORTRAN, LIST, or NONE");
10404
10405       ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
10406                           &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
10407        "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10408
10409       ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
10410                             &ffestp_file.open.open_spec[FFESTP_openixFORM],
10411                             "FORMATTED or UNFORMATTED");
10412
10413       ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
10414                      &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
10415                             "INDEXED, RELATIVE, or SEQUENTIAL");
10416
10417       ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
10418                          &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
10419                             "APPEND, ASIS, or REWIND");
10420
10421       ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
10422                             &ffestp_file.open.open_spec[FFESTP_openixACTION],
10423                             "READ, READWRITE, or WRITE");
10424
10425       ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
10426                             &ffestp_file.open.open_spec[FFESTP_openixDELIM],
10427                             "APOSTROPHE, NONE, or QUOTE");
10428
10429       ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
10430                        &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
10431              "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
10432
10433       ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
10434                             &ffestp_file.open.open_spec[FFESTP_openixPAD],
10435                             "NO or YES");
10436
10437       ffestd_R904 ();
10438     }
10439
10440   if (ffestc_shriek_after1_ != NULL)
10441     (*ffestc_shriek_after1_) (TRUE);
10442   ffestc_labeldef_branch_end_ ();
10443 }
10444
10445 /* ffestc_R907 -- CLOSE statement
10446
10447    ffestc_R907();
10448
10449    Make sure a CLOSE is valid in the current context, and implement it.  */
10450
10451 void
10452 ffestc_R907 ()
10453 {
10454   char *status_strs[]
10455   =
10456   {
10457     "Delete",
10458     "Keep",
10459     "Print",
10460     "Print/Delete",
10461     "Save",
10462     "Submit",
10463     "Submit/Delete"
10464   };
10465
10466   ffestc_check_simple_ ();
10467   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10468     return;
10469   ffestc_labeldef_branch_begin_ ();
10470
10471   if (ffestc_subr_is_branch_
10472       (&ffestp_file.close.close_spec[FFESTP_closeixERR])
10473       && ffestc_subr_is_present_ ("UNIT",
10474                          &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
10475     {
10476       ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
10477                         &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
10478        "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
10479
10480       ffestd_R907 ();
10481     }
10482
10483   if (ffestc_shriek_after1_ != NULL)
10484     (*ffestc_shriek_after1_) (TRUE);
10485   ffestc_labeldef_branch_end_ ();
10486 }
10487
10488 /* ffestc_R909_start -- READ(...) statement list begin
10489
10490    ffestc_R909_start(FALSE);
10491
10492    Verify that READ is valid here, and begin accepting items in the
10493    list.  */
10494
10495 void
10496 ffestc_R909_start (bool only_format)
10497 {
10498   ffestvUnit unit;
10499   ffestvFormat format;
10500   bool rec;
10501   bool key;
10502   ffestpReadIx keyn;
10503   ffestpReadIx spec1;
10504   ffestpReadIx spec2;
10505
10506   ffestc_check_start_ ();
10507   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10508     {
10509       ffestc_ok_ = FALSE;
10510       return;
10511     }
10512   ffestc_labeldef_branch_begin_ ();
10513
10514   if (!ffestc_subr_is_format_
10515       (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
10516     {
10517       ffestc_ok_ = FALSE;
10518       return;
10519     }
10520
10521   format = ffestc_subr_format_
10522     (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
10523   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10524
10525   if (only_format)
10526     {
10527       ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
10528
10529       ffestc_ok_ = TRUE;
10530       return;
10531     }
10532
10533   if (!ffestc_subr_is_branch_
10534       (&ffestp_file.read.read_spec[FFESTP_readixEOR])
10535       || !ffestc_subr_is_branch_
10536       (&ffestp_file.read.read_spec[FFESTP_readixERR])
10537       || !ffestc_subr_is_branch_
10538       (&ffestp_file.read.read_spec[FFESTP_readixEND]))
10539     {
10540       ffestc_ok_ = FALSE;
10541       return;
10542     }
10543
10544   unit = ffestc_subr_unit_
10545     (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
10546   if (unit == FFESTV_unitNONE)
10547     {
10548       ffebad_start (FFEBAD_NO_UNIT_SPEC);
10549       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10550                    ffelex_token_where_column (ffesta_tokens[0]));
10551       ffebad_finish ();
10552       ffestc_ok_ = FALSE;
10553       return;
10554     }
10555
10556   rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
10557
10558   if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
10559     {
10560       key = TRUE;
10561       keyn = spec1 = FFESTP_readixKEYEQ;
10562     }
10563   else
10564     {
10565       key = FALSE;
10566       keyn = spec1 = FFESTP_readix;
10567     }
10568
10569   if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
10570     {
10571       if (key)
10572         {
10573           spec2 = FFESTP_readixKEYGT;
10574         whine:                  /* :::::::::::::::::::: */
10575           ffebad_start (FFEBAD_CONFLICTING_SPECS);
10576           assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
10577           if (ffestp_file.read.read_spec[spec1].kw_present)
10578             {
10579               ffebad_here (0, ffelex_token_where_line
10580                            (ffestp_file.read.read_spec[spec1].kw),
10581                            ffelex_token_where_column
10582                            (ffestp_file.read.read_spec[spec1].kw));
10583             }
10584           else
10585             {
10586               ffebad_here (0, ffelex_token_where_line
10587                            (ffestp_file.read.read_spec[spec1].value),
10588                            ffelex_token_where_column
10589                            (ffestp_file.read.read_spec[spec1].value));
10590             }
10591           assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
10592           if (ffestp_file.read.read_spec[spec2].kw_present)
10593             {
10594               ffebad_here (1, ffelex_token_where_line
10595                            (ffestp_file.read.read_spec[spec2].kw),
10596                            ffelex_token_where_column
10597                            (ffestp_file.read.read_spec[spec2].kw));
10598             }
10599           else
10600             {
10601               ffebad_here (1, ffelex_token_where_line
10602                            (ffestp_file.read.read_spec[spec2].value),
10603                            ffelex_token_where_column
10604                            (ffestp_file.read.read_spec[spec2].value));
10605             }
10606           ffebad_finish ();
10607           ffestc_ok_ = FALSE;
10608           return;
10609         }
10610       key = TRUE;
10611       keyn = spec1 = FFESTP_readixKEYGT;
10612     }
10613
10614   if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
10615     {
10616       if (key)
10617         {
10618           spec2 = FFESTP_readixKEYGT;
10619           goto whine;           /* :::::::::::::::::::: */
10620         }
10621       key = TRUE;
10622       keyn = FFESTP_readixKEYGT;
10623     }
10624
10625   if (rec)
10626     {
10627       spec1 = FFESTP_readixREC;
10628       if (key)
10629         {
10630           spec2 = keyn;
10631           goto whine;           /* :::::::::::::::::::: */
10632         }
10633       if (unit == FFESTV_unitCHAREXPR)
10634         {
10635           spec2 = FFESTP_readixUNIT;
10636           goto whine;           /* :::::::::::::::::::: */
10637         }
10638       if ((format == FFESTV_formatASTERISK)
10639           || (format == FFESTV_formatNAMELIST))
10640         {
10641           spec2 = FFESTP_readixFORMAT;
10642           goto whine;           /* :::::::::::::::::::: */
10643         }
10644       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10645         {
10646           spec2 = FFESTP_readixADVANCE;
10647           goto whine;           /* :::::::::::::::::::: */
10648         }
10649       if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10650         {
10651           spec2 = FFESTP_readixEND;
10652           goto whine;           /* :::::::::::::::::::: */
10653         }
10654       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10655         {
10656           spec2 = FFESTP_readixNULLS;
10657           goto whine;           /* :::::::::::::::::::: */
10658         }
10659     }
10660   else if (key)
10661     {
10662       spec1 = keyn;
10663       if (unit == FFESTV_unitCHAREXPR)
10664         {
10665           spec2 = FFESTP_readixUNIT;
10666           goto whine;           /* :::::::::::::::::::: */
10667         }
10668       if ((format == FFESTV_formatASTERISK)
10669           || (format == FFESTV_formatNAMELIST))
10670         {
10671           spec2 = FFESTP_readixFORMAT;
10672           goto whine;           /* :::::::::::::::::::: */
10673         }
10674       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10675         {
10676           spec2 = FFESTP_readixADVANCE;
10677           goto whine;           /* :::::::::::::::::::: */
10678         }
10679       if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
10680         {
10681           spec2 = FFESTP_readixEND;
10682           goto whine;           /* :::::::::::::::::::: */
10683         }
10684       if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10685         {
10686           spec2 = FFESTP_readixEOR;
10687           goto whine;           /* :::::::::::::::::::: */
10688         }
10689       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10690         {
10691           spec2 = FFESTP_readixNULLS;
10692           goto whine;           /* :::::::::::::::::::: */
10693         }
10694       if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
10695         {
10696           spec2 = FFESTP_readixREC;
10697           goto whine;           /* :::::::::::::::::::: */
10698         }
10699       if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10700         {
10701           spec2 = FFESTP_readixSIZE;
10702           goto whine;           /* :::::::::::::::::::: */
10703         }
10704     }
10705   else
10706     {                           /* Sequential/Internal. */
10707       if (unit == FFESTV_unitCHAREXPR)
10708         {                       /* Internal file. */
10709           spec1 = FFESTP_readixUNIT;
10710           if (format == FFESTV_formatNAMELIST)
10711             {
10712               spec2 = FFESTP_readixFORMAT;
10713               goto whine;       /* :::::::::::::::::::: */
10714             }
10715           if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10716             {
10717               spec2 = FFESTP_readixADVANCE;
10718               goto whine;       /* :::::::::::::::::::: */
10719             }
10720         }
10721       if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
10722         {                       /* ADVANCE= specified. */
10723           spec1 = FFESTP_readixADVANCE;
10724           if (format == FFESTV_formatNONE)
10725             {
10726               ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10727               ffebad_here (0, ffelex_token_where_line
10728                            (ffestp_file.read.read_spec[spec1].kw),
10729                            ffelex_token_where_column
10730                            (ffestp_file.read.read_spec[spec1].kw));
10731               ffebad_finish ();
10732
10733               ffestc_ok_ = FALSE;
10734               return;
10735             }
10736           if (format == FFESTV_formatNAMELIST)
10737             {
10738               spec2 = FFESTP_readixFORMAT;
10739               goto whine;       /* :::::::::::::::::::: */
10740             }
10741         }
10742       if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
10743         {                       /* EOR= specified. */
10744           spec1 = FFESTP_readixEOR;
10745           if (ffestc_subr_speccmp_ ("No",
10746                           &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10747                                     NULL, NULL) != 0)
10748             {
10749               goto whine_advance;       /* :::::::::::::::::::: */
10750             }
10751         }
10752       if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
10753         {                       /* NULLS= specified. */
10754           spec1 = FFESTP_readixNULLS;
10755           if (format != FFESTV_formatASTERISK)
10756             {
10757               spec2 = FFESTP_readixFORMAT;
10758               goto whine;       /* :::::::::::::::::::: */
10759             }
10760         }
10761       if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
10762         {                       /* SIZE= specified. */
10763           spec1 = FFESTP_readixSIZE;
10764           if (ffestc_subr_speccmp_ ("No",
10765                           &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
10766                                     NULL, NULL) != 0)
10767             {
10768             whine_advance:      /* :::::::::::::::::::: */
10769               if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
10770                   .kw_or_val_present)
10771                 {
10772                   ffebad_start (FFEBAD_CONFLICTING_SPECS);
10773                   ffebad_here (0, ffelex_token_where_line
10774                                (ffestp_file.read.read_spec[spec1].kw),
10775                                ffelex_token_where_column
10776                                (ffestp_file.read.read_spec[spec1].kw));
10777                   ffebad_here (1, ffelex_token_where_line
10778                       (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
10779                                ffelex_token_where_column
10780                      (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
10781                   ffebad_finish ();
10782                 }
10783               else
10784                 {
10785                   ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
10786                   ffebad_here (0, ffelex_token_where_line
10787                                (ffestp_file.read.read_spec[spec1].kw),
10788                                ffelex_token_where_column
10789                                (ffestp_file.read.read_spec[spec1].kw));
10790                   ffebad_finish ();
10791                 }
10792
10793               ffestc_ok_ = FALSE;
10794               return;
10795             }
10796         }
10797     }
10798
10799   if (unit == FFESTV_unitCHAREXPR)
10800     ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
10801   else
10802     ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
10803
10804   ffestd_R909_start (FALSE, unit, format, rec, key);
10805
10806   ffestc_ok_ = TRUE;
10807 }
10808
10809 /* ffestc_R909_item -- READ statement i/o item
10810
10811    ffestc_R909_item(expr,expr_token);
10812
10813    Implement output-list expression.  */
10814
10815 void
10816 ffestc_R909_item (ffebld expr, ffelexToken expr_token)
10817 {
10818   ffestc_check_item_ ();
10819   if (!ffestc_ok_)
10820     return;
10821
10822   if (ffestc_namelist_ != 0)
10823     {
10824       if (ffestc_namelist_ == 1)
10825         {
10826           ffestc_namelist_ = 2;
10827           ffebad_start (FFEBAD_NAMELIST_ITEMS);
10828           ffebad_here (0, ffelex_token_where_line (expr_token),
10829                        ffelex_token_where_column (expr_token));
10830           ffebad_finish ();
10831         }
10832       return;
10833     }
10834
10835   ffestd_R909_item (expr, expr_token);
10836 }
10837
10838 /* ffestc_R909_finish -- READ statement list complete
10839
10840    ffestc_R909_finish();
10841
10842    Just wrap up any local activities.  */
10843
10844 void
10845 ffestc_R909_finish ()
10846 {
10847   ffestc_check_finish_ ();
10848   if (!ffestc_ok_)
10849     return;
10850
10851   ffestd_R909_finish ();
10852
10853   if (ffestc_shriek_after1_ != NULL)
10854     (*ffestc_shriek_after1_) (TRUE);
10855   ffestc_labeldef_branch_end_ ();
10856 }
10857
10858 /* ffestc_R910_start -- WRITE(...) statement list begin
10859
10860    ffestc_R910_start();
10861
10862    Verify that WRITE is valid here, and begin accepting items in the
10863    list.  */
10864
10865 void
10866 ffestc_R910_start ()
10867 {
10868   ffestvUnit unit;
10869   ffestvFormat format;
10870   bool rec;
10871   ffestpWriteIx spec1;
10872   ffestpWriteIx spec2;
10873
10874   ffestc_check_start_ ();
10875   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
10876     {
10877       ffestc_ok_ = FALSE;
10878       return;
10879     }
10880   ffestc_labeldef_branch_begin_ ();
10881
10882   if (!ffestc_subr_is_branch_
10883       (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
10884       || !ffestc_subr_is_branch_
10885       (&ffestp_file.write.write_spec[FFESTP_writeixERR])
10886       || !ffestc_subr_is_format_
10887       (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
10888     {
10889       ffestc_ok_ = FALSE;
10890       return;
10891     }
10892
10893   format = ffestc_subr_format_
10894     (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
10895   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
10896
10897   unit = ffestc_subr_unit_
10898     (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
10899   if (unit == FFESTV_unitNONE)
10900     {
10901       ffebad_start (FFEBAD_NO_UNIT_SPEC);
10902       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
10903                    ffelex_token_where_column (ffesta_tokens[0]));
10904       ffebad_finish ();
10905       ffestc_ok_ = FALSE;
10906       return;
10907     }
10908
10909   rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
10910
10911   if (rec)
10912     {
10913       spec1 = FFESTP_writeixREC;
10914       if (unit == FFESTV_unitCHAREXPR)
10915         {
10916           spec2 = FFESTP_writeixUNIT;
10917         whine:                  /* :::::::::::::::::::: */
10918           ffebad_start (FFEBAD_CONFLICTING_SPECS);
10919           assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
10920           if (ffestp_file.write.write_spec[spec1].kw_present)
10921             {
10922               ffebad_here (0, ffelex_token_where_line
10923                            (ffestp_file.write.write_spec[spec1].kw),
10924                            ffelex_token_where_column
10925                            (ffestp_file.write.write_spec[spec1].kw));
10926             }
10927           else
10928             {
10929               ffebad_here (0, ffelex_token_where_line
10930                            (ffestp_file.write.write_spec[spec1].value),
10931                            ffelex_token_where_column
10932                            (ffestp_file.write.write_spec[spec1].value));
10933             }
10934           assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
10935           if (ffestp_file.write.write_spec[spec2].kw_present)
10936             {
10937               ffebad_here (1, ffelex_token_where_line
10938                            (ffestp_file.write.write_spec[spec2].kw),
10939                            ffelex_token_where_column
10940                            (ffestp_file.write.write_spec[spec2].kw));
10941             }
10942           else
10943             {
10944               ffebad_here (1, ffelex_token_where_line
10945                            (ffestp_file.write.write_spec[spec2].value),
10946                            ffelex_token_where_column
10947                            (ffestp_file.write.write_spec[spec2].value));
10948             }
10949           ffebad_finish ();
10950           ffestc_ok_ = FALSE;
10951           return;
10952         }
10953       if ((format == FFESTV_formatASTERISK)
10954           || (format == FFESTV_formatNAMELIST))
10955         {
10956           spec2 = FFESTP_writeixFORMAT;
10957           goto whine;           /* :::::::::::::::::::: */
10958         }
10959       if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10960         {
10961           spec2 = FFESTP_writeixADVANCE;
10962           goto whine;           /* :::::::::::::::::::: */
10963         }
10964     }
10965   else
10966     {                           /* Sequential/Indexed/Internal. */
10967       if (unit == FFESTV_unitCHAREXPR)
10968         {                       /* Internal file. */
10969           spec1 = FFESTP_writeixUNIT;
10970           if (format == FFESTV_formatNAMELIST)
10971             {
10972               spec2 = FFESTP_writeixFORMAT;
10973               goto whine;       /* :::::::::::::::::::: */
10974             }
10975           if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10976             {
10977               spec2 = FFESTP_writeixADVANCE;
10978               goto whine;       /* :::::::::::::::::::: */
10979             }
10980         }
10981       if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
10982         {                       /* ADVANCE= specified. */
10983           spec1 = FFESTP_writeixADVANCE;
10984           if (format == FFESTV_formatNONE)
10985             {
10986               ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
10987               ffebad_here (0, ffelex_token_where_line
10988                            (ffestp_file.write.write_spec[spec1].kw),
10989                            ffelex_token_where_column
10990                            (ffestp_file.write.write_spec[spec1].kw));
10991               ffebad_finish ();
10992
10993               ffestc_ok_ = FALSE;
10994               return;
10995             }
10996           if (format == FFESTV_formatNAMELIST)
10997             {
10998               spec2 = FFESTP_writeixFORMAT;
10999               goto whine;       /* :::::::::::::::::::: */
11000             }
11001         }
11002       if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
11003         {                       /* EOR= specified. */
11004           spec1 = FFESTP_writeixEOR;
11005           if (ffestc_subr_speccmp_ ("No",
11006                        &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
11007                                     NULL, NULL) != 0)
11008             {
11009               if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
11010                   .kw_or_val_present)
11011                 {
11012                   ffebad_start (FFEBAD_CONFLICTING_SPECS);
11013                   ffebad_here (0, ffelex_token_where_line
11014                                (ffestp_file.write.write_spec[spec1].kw),
11015                                ffelex_token_where_column
11016                                (ffestp_file.write.write_spec[spec1].kw));
11017                   ffebad_here (1, ffelex_token_where_line
11018                    (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
11019                                ffelex_token_where_column
11020                   (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
11021                   ffebad_finish ();
11022                 }
11023               else
11024                 {
11025                   ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
11026                   ffebad_here (0, ffelex_token_where_line
11027                                (ffestp_file.write.write_spec[spec1].kw),
11028                                ffelex_token_where_column
11029                                (ffestp_file.write.write_spec[spec1].kw));
11030                   ffebad_finish ();
11031                 }
11032
11033               ffestc_ok_ = FALSE;
11034               return;
11035             }
11036         }
11037     }
11038
11039   if (unit == FFESTV_unitCHAREXPR)
11040     ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
11041   else
11042     ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
11043
11044   ffestd_R910_start (unit, format, rec);
11045
11046   ffestc_ok_ = TRUE;
11047 }
11048
11049 /* ffestc_R910_item -- WRITE statement i/o item
11050
11051    ffestc_R910_item(expr,expr_token);
11052
11053    Implement output-list expression.  */
11054
11055 void
11056 ffestc_R910_item (ffebld expr, ffelexToken expr_token)
11057 {
11058   ffestc_check_item_ ();
11059   if (!ffestc_ok_)
11060     return;
11061
11062   if (ffestc_namelist_ != 0)
11063     {
11064       if (ffestc_namelist_ == 1)
11065         {
11066           ffestc_namelist_ = 2;
11067           ffebad_start (FFEBAD_NAMELIST_ITEMS);
11068           ffebad_here (0, ffelex_token_where_line (expr_token),
11069                        ffelex_token_where_column (expr_token));
11070           ffebad_finish ();
11071         }
11072       return;
11073     }
11074
11075   ffestd_R910_item (expr, expr_token);
11076 }
11077
11078 /* ffestc_R910_finish -- WRITE statement list complete
11079
11080    ffestc_R910_finish();
11081
11082    Just wrap up any local activities.  */
11083
11084 void
11085 ffestc_R910_finish ()
11086 {
11087   ffestc_check_finish_ ();
11088   if (!ffestc_ok_)
11089     return;
11090
11091   ffestd_R910_finish ();
11092
11093   if (ffestc_shriek_after1_ != NULL)
11094     (*ffestc_shriek_after1_) (TRUE);
11095   ffestc_labeldef_branch_end_ ();
11096 }
11097
11098 /* ffestc_R911_start -- PRINT(...) statement list begin
11099
11100    ffestc_R911_start();
11101
11102    Verify that PRINT is valid here, and begin accepting items in the
11103    list.  */
11104
11105 void
11106 ffestc_R911_start ()
11107 {
11108   ffestvFormat format;
11109
11110   ffestc_check_start_ ();
11111   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11112     {
11113       ffestc_ok_ = FALSE;
11114       return;
11115     }
11116   ffestc_labeldef_branch_begin_ ();
11117
11118   if (!ffestc_subr_is_format_
11119       (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
11120     {
11121       ffestc_ok_ = FALSE;
11122       return;
11123     }
11124
11125   format = ffestc_subr_format_
11126     (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
11127   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
11128
11129   ffestd_R911_start (format);
11130
11131   ffestc_ok_ = TRUE;
11132 }
11133
11134 /* ffestc_R911_item -- PRINT statement i/o item
11135
11136    ffestc_R911_item(expr,expr_token);
11137
11138    Implement output-list expression.  */
11139
11140 void
11141 ffestc_R911_item (ffebld expr, ffelexToken expr_token)
11142 {
11143   ffestc_check_item_ ();
11144   if (!ffestc_ok_)
11145     return;
11146
11147   if (ffestc_namelist_ != 0)
11148     {
11149       if (ffestc_namelist_ == 1)
11150         {
11151           ffestc_namelist_ = 2;
11152           ffebad_start (FFEBAD_NAMELIST_ITEMS);
11153           ffebad_here (0, ffelex_token_where_line (expr_token),
11154                        ffelex_token_where_column (expr_token));
11155           ffebad_finish ();
11156         }
11157       return;
11158     }
11159
11160   ffestd_R911_item (expr, expr_token);
11161 }
11162
11163 /* ffestc_R911_finish -- PRINT statement list complete
11164
11165    ffestc_R911_finish();
11166
11167    Just wrap up any local activities.  */
11168
11169 void
11170 ffestc_R911_finish ()
11171 {
11172   ffestc_check_finish_ ();
11173   if (!ffestc_ok_)
11174     return;
11175
11176   ffestd_R911_finish ();
11177
11178   if (ffestc_shriek_after1_ != NULL)
11179     (*ffestc_shriek_after1_) (TRUE);
11180   ffestc_labeldef_branch_end_ ();
11181 }
11182
11183 /* ffestc_R919 -- BACKSPACE statement
11184
11185    ffestc_R919();
11186
11187    Make sure a BACKSPACE is valid in the current context, and implement it.  */
11188
11189 void
11190 ffestc_R919 ()
11191 {
11192   ffestc_check_simple_ ();
11193   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11194     return;
11195   ffestc_labeldef_branch_begin_ ();
11196
11197   if (ffestc_subr_is_branch_
11198       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11199       && ffestc_subr_is_present_ ("UNIT",
11200                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11201     ffestd_R919 ();
11202
11203   if (ffestc_shriek_after1_ != NULL)
11204     (*ffestc_shriek_after1_) (TRUE);
11205   ffestc_labeldef_branch_end_ ();
11206 }
11207
11208 /* ffestc_R920 -- ENDFILE statement
11209
11210    ffestc_R920();
11211
11212    Make sure a ENDFILE is valid in the current context, and implement it.  */
11213
11214 void
11215 ffestc_R920 ()
11216 {
11217   ffestc_check_simple_ ();
11218   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11219     return;
11220   ffestc_labeldef_branch_begin_ ();
11221
11222   if (ffestc_subr_is_branch_
11223       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11224       && ffestc_subr_is_present_ ("UNIT",
11225                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11226     ffestd_R920 ();
11227
11228   if (ffestc_shriek_after1_ != NULL)
11229     (*ffestc_shriek_after1_) (TRUE);
11230   ffestc_labeldef_branch_end_ ();
11231 }
11232
11233 /* ffestc_R921 -- REWIND statement
11234
11235    ffestc_R921();
11236
11237    Make sure a REWIND is valid in the current context, and implement it.  */
11238
11239 void
11240 ffestc_R921 ()
11241 {
11242   ffestc_check_simple_ ();
11243   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11244     return;
11245   ffestc_labeldef_branch_begin_ ();
11246
11247   if (ffestc_subr_is_branch_
11248       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
11249       && ffestc_subr_is_present_ ("UNIT",
11250                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
11251     ffestd_R921 ();
11252
11253   if (ffestc_shriek_after1_ != NULL)
11254     (*ffestc_shriek_after1_) (TRUE);
11255   ffestc_labeldef_branch_end_ ();
11256 }
11257
11258 /* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
11259
11260    ffestc_R923A();
11261
11262    Make sure an INQUIRE is valid in the current context, and implement it.  */
11263
11264 void
11265 ffestc_R923A ()
11266 {
11267   bool by_file;
11268   bool by_unit;
11269
11270   ffestc_check_simple_ ();
11271   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11272     return;
11273   ffestc_labeldef_branch_begin_ ();
11274
11275   if (ffestc_subr_is_branch_
11276       (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
11277     {
11278       by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
11279         .kw_or_val_present;
11280       by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
11281         .kw_or_val_present;
11282       if (by_file && by_unit)
11283         {
11284           ffebad_start (FFEBAD_CONFLICTING_SPECS);
11285           assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
11286           if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
11287             {
11288               ffebad_here (0, ffelex_token_where_line
11289                 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
11290                            ffelex_token_where_column
11291                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
11292             }
11293           else
11294             {
11295               ffebad_here (0, ffelex_token_where_line
11296               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
11297                            ffelex_token_where_column
11298                            (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
11299             }
11300           assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
11301           if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
11302             {
11303               ffebad_here (1, ffelex_token_where_line
11304                 (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
11305                            ffelex_token_where_column
11306                (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
11307             }
11308           else
11309             {
11310               ffebad_here (1, ffelex_token_where_line
11311               (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
11312                            ffelex_token_where_column
11313                            (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
11314             }
11315           ffebad_finish ();
11316         }
11317       else if (!by_file && !by_unit)
11318         {
11319           ffebad_start (FFEBAD_MISSING_SPECIFIER);
11320           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11321                        ffelex_token_where_column (ffesta_tokens[0]));
11322           ffebad_string ("UNIT= or FILE=");
11323           ffebad_finish ();
11324         }
11325       else
11326         ffestd_R923A (by_file);
11327     }
11328
11329   if (ffestc_shriek_after1_ != NULL)
11330     (*ffestc_shriek_after1_) (TRUE);
11331   ffestc_labeldef_branch_end_ ();
11332 }
11333
11334 /* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
11335
11336    ffestc_R923B_start();
11337
11338    Verify that INQUIRE is valid here, and begin accepting items in the
11339    list.  */
11340
11341 void
11342 ffestc_R923B_start ()
11343 {
11344   ffestc_check_start_ ();
11345   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
11346     {
11347       ffestc_ok_ = FALSE;
11348       return;
11349     }
11350   ffestc_labeldef_branch_begin_ ();
11351
11352   ffestd_R923B_start ();
11353
11354   ffestc_ok_ = TRUE;
11355 }
11356
11357 /* ffestc_R923B_item -- INQUIRE statement i/o item
11358
11359    ffestc_R923B_item(expr,expr_token);
11360
11361    Implement output-list expression.  */
11362
11363 void
11364 ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
11365 {
11366   ffestc_check_item_ ();
11367   if (!ffestc_ok_)
11368     return;
11369
11370   ffestd_R923B_item (expr);
11371 }
11372
11373 /* ffestc_R923B_finish -- INQUIRE statement list complete
11374
11375    ffestc_R923B_finish();
11376
11377    Just wrap up any local activities.  */
11378
11379 void
11380 ffestc_R923B_finish ()
11381 {
11382   ffestc_check_finish_ ();
11383   if (!ffestc_ok_)
11384     return;
11385
11386   ffestd_R923B_finish ();
11387
11388   if (ffestc_shriek_after1_ != NULL)
11389     (*ffestc_shriek_after1_) (TRUE);
11390   ffestc_labeldef_branch_end_ ();
11391 }
11392
11393 /* ffestc_R1001 -- FORMAT statement
11394
11395    ffestc_R1001(format_list);
11396
11397    Make sure format_list is valid.  Update label's info to indicate it is a
11398    FORMAT label, and (perhaps) warn if there is no label!  */
11399
11400 void
11401 ffestc_R1001 (ffesttFormatList f)
11402 {
11403   ffestc_check_simple_ ();
11404   if (ffestc_order_format_ () != FFESTC_orderOK_)
11405     return;
11406   ffestc_labeldef_format_ ();
11407
11408   ffestd_R1001 (f);
11409 }
11410
11411 /* ffestc_R1102 -- PROGRAM statement
11412
11413    ffestc_R1102(name_token);
11414
11415    Make sure ffestc_kind_ identifies an empty block.  Make sure name_token
11416    gives a valid name.  Implement the beginning of a main program.  */
11417
11418 void
11419 ffestc_R1102 (ffelexToken name)
11420 {
11421   ffestw b;
11422   ffesymbol s;
11423
11424   assert (name != NULL);
11425
11426   ffestc_check_simple_ ();
11427   if (ffestc_order_unit_ () != FFESTC_orderOK_)
11428     return;
11429   ffestc_labeldef_useless_ ();
11430
11431   ffestc_blocknum_ = 0;
11432   b = ffestw_update (ffestw_push (NULL));
11433   ffestw_set_top_do (b, NULL);
11434   ffestw_set_state (b, FFESTV_statePROGRAM0);
11435   ffestw_set_blocknum (b, ffestc_blocknum_++);
11436   ffestw_set_shriek (b, ffestc_shriek_end_program_);
11437
11438   ffestw_set_name (b, ffelex_token_use (name));
11439
11440   s = ffesymbol_declare_programunit (name,
11441                                  ffelex_token_where_line (ffesta_tokens[0]),
11442                               ffelex_token_where_column (ffesta_tokens[0]));
11443
11444   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11445     {
11446       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11447       ffesymbol_set_info (s,
11448                           ffeinfo_new (FFEINFO_basictypeNONE,
11449                                        FFEINFO_kindtypeNONE,
11450                                        0,
11451                                        FFEINFO_kindPROGRAM,
11452                                        FFEINFO_whereLOCAL,
11453                                        FFETARGET_charactersizeNONE));
11454       ffesymbol_signal_unreported (s);
11455     }
11456   else
11457     ffesymbol_error (s, name);
11458
11459   ffestd_R1102 (s, name);
11460 }
11461
11462 /* ffestc_R1103 -- END PROGRAM statement
11463
11464    ffestc_R1103(name_token);
11465
11466    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
11467    NULL, make sure name_token gives the correct name.  Implement the end
11468    of the current program unit.  */
11469
11470 void
11471 ffestc_R1103 (ffelexToken name)
11472 {
11473   ffestc_check_simple_ ();
11474   if (ffestc_order_program_ () != FFESTC_orderOK_)
11475     return;
11476   ffestc_labeldef_notloop_ ();
11477
11478   if (name != NULL)
11479     {
11480       if (ffestw_name (ffestw_stack_top ()) == NULL)
11481         {
11482           ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
11483           ffebad_here (0, ffelex_token_where_line (name),
11484                        ffelex_token_where_column (name));
11485           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11486           ffebad_finish ();
11487         }
11488       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11489         {
11490           ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11491           ffebad_here (0, ffelex_token_where_line (name),
11492                        ffelex_token_where_column (name));
11493           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11494              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11495           ffebad_finish ();
11496         }
11497     }
11498
11499   ffestc_shriek_end_program_ (TRUE);
11500 }
11501
11502 /* ffestc_R1105 -- MODULE statement
11503
11504    ffestc_R1105(name_token);
11505
11506    Make sure ffestc_kind_ identifies an empty block.  Make sure name_token
11507    gives a valid name.  Implement the beginning of a module.  */
11508
11509 #if FFESTR_F90
11510 void
11511 ffestc_R1105 (ffelexToken name)
11512 {
11513   ffestw b;
11514
11515   assert (name != NULL);
11516
11517   ffestc_check_simple_ ();
11518   if (ffestc_order_unit_ () != FFESTC_orderOK_)
11519     return;
11520   ffestc_labeldef_useless_ ();
11521
11522   ffestc_blocknum_ = 0;
11523   b = ffestw_update (ffestw_push (NULL));
11524   ffestw_set_top_do (b, NULL);
11525   ffestw_set_state (b, FFESTV_stateMODULE0);
11526   ffestw_set_blocknum (b, ffestc_blocknum_++);
11527   ffestw_set_shriek (b, ffestc_shriek_module_);
11528   ffestw_set_name (b, ffelex_token_use (name));
11529
11530   ffestd_R1105 (name);
11531 }
11532
11533 /* ffestc_R1106 -- END MODULE statement
11534
11535    ffestc_R1106(name_token);
11536
11537    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
11538    NULL, make sure name_token gives the correct name.  Implement the end
11539    of the current program unit.  */
11540
11541 void
11542 ffestc_R1106 (ffelexToken name)
11543 {
11544   ffestc_check_simple_ ();
11545   if (ffestc_order_module_ () != FFESTC_orderOK_)
11546     return;
11547   ffestc_labeldef_useless_ ();
11548
11549   if ((name != NULL)
11550       && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
11551     {
11552       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11553       ffebad_here (0, ffelex_token_where_line (name),
11554                    ffelex_token_where_column (name));
11555       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11556              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11557       ffebad_finish ();
11558     }
11559
11560   ffestc_shriek_module_ (TRUE);
11561 }
11562
11563 /* ffestc_R1107_start -- USE statement list begin
11564
11565    ffestc_R1107_start();
11566
11567    Verify that USE is valid here, and begin accepting items in the list.  */
11568
11569 void
11570 ffestc_R1107_start (ffelexToken name, bool only)
11571 {
11572   ffestc_check_start_ ();
11573   if (ffestc_order_use_ () != FFESTC_orderOK_)
11574     {
11575       ffestc_ok_ = FALSE;
11576       return;
11577     }
11578   ffestc_labeldef_useless_ ();
11579
11580   ffestd_R1107_start (name, only);
11581
11582   ffestc_ok_ = TRUE;
11583 }
11584
11585 /* ffestc_R1107_item -- USE statement for name
11586
11587    ffestc_R1107_item(local_token,use_token);
11588
11589    Make sure name_token identifies a valid object to be USEed.  local_token
11590    may be NULL if _start_ was called with only==TRUE.  */
11591
11592 void
11593 ffestc_R1107_item (ffelexToken local, ffelexToken use)
11594 {
11595   ffestc_check_item_ ();
11596   assert (use != NULL);
11597   if (!ffestc_ok_)
11598     return;
11599
11600   ffestd_R1107_item (local, use);
11601 }
11602
11603 /* ffestc_R1107_finish -- USE statement list complete
11604
11605    ffestc_R1107_finish();
11606
11607    Just wrap up any local activities.  */
11608
11609 void
11610 ffestc_R1107_finish ()
11611 {
11612   ffestc_check_finish_ ();
11613   if (!ffestc_ok_)
11614     return;
11615
11616   ffestd_R1107_finish ();
11617 }
11618
11619 #endif
11620 /* ffestc_R1111 -- BLOCK DATA statement
11621
11622    ffestc_R1111(name_token);
11623
11624    Make sure ffestc_kind_ identifies no current program unit.  If not
11625    NULL, make sure name_token gives a valid name.  Implement the beginning
11626    of a block data program unit.  */
11627
11628 void
11629 ffestc_R1111 (ffelexToken name)
11630 {
11631   ffestw b;
11632   ffesymbol s;
11633
11634   ffestc_check_simple_ ();
11635   if (ffestc_order_unit_ () != FFESTC_orderOK_)
11636     return;
11637   ffestc_labeldef_useless_ ();
11638
11639   ffestc_blocknum_ = 0;
11640   b = ffestw_update (ffestw_push (NULL));
11641   ffestw_set_top_do (b, NULL);
11642   ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
11643   ffestw_set_blocknum (b, ffestc_blocknum_++);
11644   ffestw_set_shriek (b, ffestc_shriek_blockdata_);
11645
11646   if (name == NULL)
11647     ffestw_set_name (b, NULL);
11648   else
11649     ffestw_set_name (b, ffelex_token_use (name));
11650
11651   s = ffesymbol_declare_blockdataunit (name,
11652                                  ffelex_token_where_line (ffesta_tokens[0]),
11653                               ffelex_token_where_column (ffesta_tokens[0]));
11654
11655   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
11656     {
11657       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
11658       ffesymbol_set_info (s,
11659                           ffeinfo_new (FFEINFO_basictypeNONE,
11660                                        FFEINFO_kindtypeNONE,
11661                                        0,
11662                                        FFEINFO_kindBLOCKDATA,
11663                                        FFEINFO_whereLOCAL,
11664                                        FFETARGET_charactersizeNONE));
11665       ffesymbol_signal_unreported (s);
11666     }
11667   else
11668     ffesymbol_error (s, name);
11669
11670   ffestd_R1111 (s, name);
11671 }
11672
11673 /* ffestc_R1112 -- END BLOCK DATA statement
11674
11675    ffestc_R1112(name_token);
11676
11677    Make sure ffestc_kind_ identifies the current kind of program unit.  If not
11678    NULL, make sure name_token gives the correct name.  Implement the end
11679    of the current program unit.  */
11680
11681 void
11682 ffestc_R1112 (ffelexToken name)
11683 {
11684   ffestc_check_simple_ ();
11685   if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
11686     return;
11687   ffestc_labeldef_useless_ ();
11688
11689   if (name != NULL)
11690     {
11691       if (ffestw_name (ffestw_stack_top ()) == NULL)
11692         {
11693           ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
11694           ffebad_here (0, ffelex_token_where_line (name),
11695                        ffelex_token_where_column (name));
11696           ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11697           ffebad_finish ();
11698         }
11699       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
11700         {
11701           ffebad_start (FFEBAD_UNIT_WRONG_NAME);
11702           ffebad_here (0, ffelex_token_where_line (name),
11703                        ffelex_token_where_column (name));
11704           ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
11705              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
11706           ffebad_finish ();
11707         }
11708     }
11709
11710   ffestc_shriek_blockdata_ (TRUE);
11711 }
11712
11713 /* ffestc_R1202 -- INTERFACE statement
11714
11715    ffestc_R1202(operator,defined_name);
11716
11717    Make sure ffestc_kind_ identifies an INTERFACE block.
11718    Implement the end of the current interface.
11719
11720    15-May-90  JCB  1.1
11721       Allow no operator or name to mean INTERFACE by itself; missed this
11722       valid form when originally doing syntactic analysis code.  */
11723
11724 #if FFESTR_F90
11725 void
11726 ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name)
11727 {
11728   ffestw b;
11729
11730   ffestc_check_simple_ ();
11731   if (ffestc_order_interfacespec_ () != FFESTC_orderOK_)
11732     return;
11733   ffestc_labeldef_useless_ ();
11734
11735   b = ffestw_update (ffestw_push (NULL));
11736   ffestw_set_top_do (b, NULL);
11737   ffestw_set_state (b, FFESTV_stateINTERFACE0);
11738   ffestw_set_blocknum (b, 0);
11739   ffestw_set_shriek (b, ffestc_shriek_interface_);
11740
11741   if ((operator == FFESTP_definedoperatorNone) && (name == NULL))
11742     ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE
11743                                    PROCEDURE. */
11744   else
11745     ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */
11746
11747   ffestd_R1202 (operator, name);
11748
11749   ffe_init_4 ();
11750 }
11751
11752 /* ffestc_R1203 -- END INTERFACE statement
11753
11754    ffestc_R1203();
11755
11756    Make sure ffestc_kind_ identifies an INTERFACE block.
11757    Implement the end of the current interface.  */
11758
11759 void
11760 ffestc_R1203 ()
11761 {
11762   ffestc_check_simple_ ();
11763   if (ffestc_order_interface_ () != FFESTC_orderOK_)
11764     return;
11765   ffestc_labeldef_useless_ ();
11766
11767   ffestc_shriek_interface_ (TRUE);
11768
11769   ffe_terminate_4 ();
11770 }
11771
11772 /* ffestc_R1205_start -- MODULE PROCEDURE statement list begin
11773
11774    ffestc_R1205_start();
11775
11776    Verify that MODULE PROCEDURE is valid here, and begin accepting items in
11777    the list.  */
11778
11779 void
11780 ffestc_R1205_start ()
11781 {
11782   ffestc_check_start_ ();
11783   if (ffestc_order_interface_ () != FFESTC_orderOK_)
11784     {
11785       ffestc_ok_ = FALSE;
11786       return;
11787     }
11788   ffestc_labeldef_useless_ ();
11789
11790   if (ffestw_substate (ffestw_stack_top ()) == 0)
11791     {
11792       ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE);
11793       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
11794                    ffelex_token_where_column (ffesta_tokens[0]));
11795       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
11796       ffebad_finish ();
11797       ffestc_ok_ = FALSE;
11798       return;
11799     }
11800
11801   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0)
11802     {
11803       ffestw_update (NULL);     /* Update state line/col info. */
11804       ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1);
11805     }
11806
11807   ffestd_R1205_start ();
11808
11809   ffestc_ok_ = TRUE;
11810 }
11811
11812 /* ffestc_R1205_item -- MODULE PROCEDURE statement for name
11813
11814    ffestc_R1205_item(name_token);
11815
11816    Make sure name_token identifies a valid object to be MODULE PROCEDUREed.  */
11817
11818 void
11819 ffestc_R1205_item (ffelexToken name)
11820 {
11821   ffestc_check_item_ ();
11822   assert (name != NULL);
11823   if (!ffestc_ok_)
11824     return;
11825
11826   ffestd_R1205_item (name);
11827 }
11828
11829 /* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete
11830
11831    ffestc_R1205_finish();
11832
11833    Just wrap up any local activities.  */
11834
11835 void
11836 ffestc_R1205_finish ()
11837 {
11838   ffestc_check_finish_ ();
11839   if (!ffestc_ok_)
11840     return;
11841
11842   ffestd_R1205_finish ();
11843 }
11844
11845 #endif
11846 /* ffestc_R1207_start -- EXTERNAL statement list begin
11847
11848    ffestc_R1207_start();
11849
11850    Verify that EXTERNAL is valid here, and begin accepting items in the list.  */
11851
11852 void
11853 ffestc_R1207_start ()
11854 {
11855   ffestc_check_start_ ();
11856   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11857     {
11858       ffestc_ok_ = FALSE;
11859       return;
11860     }
11861   ffestc_labeldef_useless_ ();
11862
11863   ffestd_R1207_start ();
11864
11865   ffestc_ok_ = TRUE;
11866 }
11867
11868 /* ffestc_R1207_item -- EXTERNAL statement for name
11869
11870    ffestc_R1207_item(name_token);
11871
11872    Make sure name_token identifies a valid object to be EXTERNALd.  */
11873
11874 void
11875 ffestc_R1207_item (ffelexToken name)
11876 {
11877   ffesymbol s;
11878   ffesymbolAttrs sa;
11879   ffesymbolAttrs na;
11880
11881   ffestc_check_item_ ();
11882   assert (name != NULL);
11883   if (!ffestc_ok_)
11884     return;
11885
11886   s = ffesymbol_declare_local (name, FALSE);
11887   sa = ffesymbol_attrs (s);
11888
11889   /* Figure out what kind of object we've got based on previous declarations
11890      of or references to the object. */
11891
11892   if (!ffesymbol_is_specable (s))
11893     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11894   else if (sa & FFESYMBOL_attrsANY)
11895     na = FFESYMBOL_attrsANY;
11896   else if (!(sa & ~(FFESYMBOL_attrsDUMMY
11897                     | FFESYMBOL_attrsTYPE)))
11898     na = sa | FFESYMBOL_attrsEXTERNAL;
11899   else
11900     na = FFESYMBOL_attrsetNONE;
11901
11902   /* Now see what we've got for a new object: NONE means a new error cropped
11903      up; ANY means an old error to be ignored; otherwise, everything's ok,
11904      update the object (symbol) and continue on. */
11905
11906   if (na == FFESYMBOL_attrsetNONE)
11907     ffesymbol_error (s, name);
11908   else if (!(na & FFESYMBOL_attrsANY))
11909     {
11910       ffesymbol_set_attrs (s, na);
11911       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
11912       ffesymbol_set_explicitwhere (s, TRUE);
11913       ffesymbol_reference (s, name, FALSE);
11914       ffesymbol_signal_unreported (s);
11915     }
11916
11917   ffestd_R1207_item (name);
11918 }
11919
11920 /* ffestc_R1207_finish -- EXTERNAL statement list complete
11921
11922    ffestc_R1207_finish();
11923
11924    Just wrap up any local activities.  */
11925
11926 void
11927 ffestc_R1207_finish ()
11928 {
11929   ffestc_check_finish_ ();
11930   if (!ffestc_ok_)
11931     return;
11932
11933   ffestd_R1207_finish ();
11934 }
11935
11936 /* ffestc_R1208_start -- INTRINSIC statement list begin
11937
11938    ffestc_R1208_start();
11939
11940    Verify that INTRINSIC is valid here, and begin accepting items in the list.  */
11941
11942 void
11943 ffestc_R1208_start ()
11944 {
11945   ffestc_check_start_ ();
11946   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
11947     {
11948       ffestc_ok_ = FALSE;
11949       return;
11950     }
11951   ffestc_labeldef_useless_ ();
11952
11953   ffestd_R1208_start ();
11954
11955   ffestc_ok_ = TRUE;
11956 }
11957
11958 /* ffestc_R1208_item -- INTRINSIC statement for name
11959
11960    ffestc_R1208_item(name_token);
11961
11962    Make sure name_token identifies a valid object to be INTRINSICd.  */
11963
11964 void
11965 ffestc_R1208_item (ffelexToken name)
11966 {
11967   ffesymbol s;
11968   ffesymbolAttrs sa;
11969   ffesymbolAttrs na;
11970   ffeintrinGen gen;
11971   ffeintrinSpec spec;
11972   ffeintrinImp imp;
11973
11974   ffestc_check_item_ ();
11975   assert (name != NULL);
11976   if (!ffestc_ok_)
11977     return;
11978
11979   s = ffesymbol_declare_local (name, TRUE);
11980   sa = ffesymbol_attrs (s);
11981
11982   /* Figure out what kind of object we've got based on previous declarations
11983      of or references to the object. */
11984
11985   if (!ffesymbol_is_specable (s))
11986     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
11987   else if (sa & FFESYMBOL_attrsANY)
11988     na = sa;
11989   else if (!(sa & ~FFESYMBOL_attrsTYPE))
11990     {
11991       if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
11992                                   &gen, &spec, &imp)
11993           && ((imp == FFEINTRIN_impNONE)
11994 #if 0   /* Don't bother with this for now. */
11995               || ((ffeintrin_basictype (spec)
11996                    == ffesymbol_basictype (s))
11997                   && (ffeintrin_kindtype (spec)
11998                       == ffesymbol_kindtype (s)))
11999 #else
12000               || 1
12001 #endif
12002               || !(sa & FFESYMBOL_attrsTYPE)))
12003         na = sa | FFESYMBOL_attrsINTRINSIC;
12004       else
12005         na = FFESYMBOL_attrsetNONE;
12006     }
12007   else
12008     na = FFESYMBOL_attrsetNONE;
12009
12010   /* Now see what we've got for a new object: NONE means a new error cropped
12011      up; ANY means an old error to be ignored; otherwise, everything's ok,
12012      update the object (symbol) and continue on. */
12013
12014   if (na == FFESYMBOL_attrsetNONE)
12015     ffesymbol_error (s, name);
12016   else if (!(na & FFESYMBOL_attrsANY))
12017     {
12018       ffesymbol_set_attrs (s, na);
12019       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12020       ffesymbol_set_generic (s, gen);
12021       ffesymbol_set_specific (s, spec);
12022       ffesymbol_set_implementation (s, imp);
12023       ffesymbol_set_info (s,
12024                           ffeinfo_new (ffesymbol_basictype (s),
12025                                        ffesymbol_kindtype (s),
12026                                        0,
12027                                        FFEINFO_kindNONE,
12028                                        FFEINFO_whereINTRINSIC,
12029                                        ffesymbol_size (s)));
12030       ffesymbol_set_explicitwhere (s, TRUE);
12031       ffesymbol_reference (s, name, TRUE);
12032     }
12033
12034   ffesymbol_signal_unreported (s);
12035
12036   ffestd_R1208_item (name);
12037 }
12038
12039 /* ffestc_R1208_finish -- INTRINSIC statement list complete
12040
12041    ffestc_R1208_finish();
12042
12043    Just wrap up any local activities.  */
12044
12045 void
12046 ffestc_R1208_finish ()
12047 {
12048   ffestc_check_finish_ ();
12049   if (!ffestc_ok_)
12050     return;
12051
12052   ffestd_R1208_finish ();
12053 }
12054
12055 /* ffestc_R1212 -- CALL statement
12056
12057    ffestc_R1212(expr,expr_token);
12058
12059    Make sure statement is valid here; implement.  */
12060
12061 void
12062 ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
12063 {
12064   ffebld item;                  /* ITEM. */
12065   ffebld labexpr;               /* LABTOK=>LABTER. */
12066   ffelab label;
12067   bool ok;                      /* TRUE if all LABTOKs were ok. */
12068   bool ok1;                     /* TRUE if a particular LABTOK is ok. */
12069
12070   ffestc_check_simple_ ();
12071   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12072     return;
12073   ffestc_labeldef_branch_begin_ ();
12074
12075   if (ffebld_op (expr) != FFEBLD_opSUBRREF)
12076     ffestd_R841 (FALSE);        /* CONTINUE. */
12077   else
12078     {
12079       ok = TRUE;
12080
12081       for (item = ffebld_right (expr);
12082            item != NULL;
12083            item = ffebld_trail (item))
12084         {
12085           if (((labexpr = ffebld_head (item)) != NULL)
12086               && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
12087             {
12088               ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
12089                                                 &label);
12090               ffelex_token_kill (ffebld_labtok (labexpr));
12091               if (!ok1)
12092                 {
12093                   label = NULL;
12094                   ok = FALSE;
12095                 }
12096               ffebld_set_op (labexpr, FFEBLD_opLABTER);
12097               ffebld_set_labter (labexpr, label);
12098             }
12099         }
12100
12101       if (ok)
12102         ffestd_R1212 (expr);
12103     }
12104
12105   if (ffestc_shriek_after1_ != NULL)
12106     (*ffestc_shriek_after1_) (TRUE);
12107   ffestc_labeldef_branch_end_ ();
12108 }
12109
12110 /* ffestc_R1213 -- Defined assignment statement
12111
12112    ffestc_R1213(dest_expr,source_expr,source_token);
12113
12114    Make sure the assignment is valid.  */
12115
12116 #if FFESTR_F90
12117 void
12118 ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token)
12119 {
12120   ffestc_check_simple_ ();
12121   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12122     return;
12123   ffestc_labeldef_branch_begin_ ();
12124
12125   ffestd_R1213 (dest, source);
12126
12127   if (ffestc_shriek_after1_ != NULL)
12128     (*ffestc_shriek_after1_) (TRUE);
12129   ffestc_labeldef_branch_end_ ();
12130 }
12131
12132 #endif
12133 /* ffestc_R1219 -- FUNCTION statement
12134
12135    ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
12136          recursive);
12137
12138    Make sure statement is valid here, register arguments for the
12139    function name, and so on.
12140
12141    06-Apr-90  JCB  2.0
12142       Added the kind, len, and recursive arguments.  */
12143
12144 void
12145 ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
12146               ffelexToken final UNUSED, ffestpType type, ffebld kind,
12147               ffelexToken kindt, ffebld len, ffelexToken lent,
12148               ffelexToken recursive, ffelexToken result)
12149 {
12150   ffestw b;
12151   ffesymbol s;
12152   ffesymbol fs;                 /* FUNCTION symbol when dealing with RESULT
12153                                    symbol. */
12154   ffesymbolAttrs sa;
12155   ffesymbolAttrs na;
12156   ffelexToken res;
12157   bool separate_result;
12158
12159   assert ((funcname != NULL)
12160           && (ffelex_token_type (funcname) == FFELEX_typeNAME));
12161
12162   ffestc_check_simple_ ();
12163   if (ffestc_order_iface_ () != FFESTC_orderOK_)
12164     return;
12165   ffestc_labeldef_useless_ ();
12166
12167   ffestc_blocknum_ = 0;
12168   ffesta_is_entry_valid =
12169     (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12170   b = ffestw_update (ffestw_push (NULL));
12171   ffestw_set_top_do (b, NULL);
12172   ffestw_set_state (b, FFESTV_stateFUNCTION0);
12173   ffestw_set_blocknum (b, ffestc_blocknum_++);
12174   ffestw_set_shriek (b, ffestc_shriek_function_);
12175   ffestw_set_name (b, ffelex_token_use (funcname));
12176
12177   if (type == FFESTP_typeNone)
12178     {
12179       ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
12180       ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
12181       ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
12182     }
12183   else
12184     {
12185       ffestc_establish_declstmt_ (type, ffesta_tokens[0],
12186                                   kind, kindt, len, lent);
12187       ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
12188     }
12189
12190   separate_result = (result != NULL)
12191     && (ffelex_token_strcmp (funcname, result) != 0);
12192
12193   if (separate_result)
12194     fs = ffesymbol_declare_funcnotresunit (funcname);   /* Global/local. */
12195   else
12196     fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
12197
12198   if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12199     {
12200       ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12201       ffesymbol_signal_unreported (fs);
12202
12203       /* Note that .basic_type and .kind_type might be NONE here. */
12204
12205       ffesymbol_set_info (fs,
12206                           ffeinfo_new (ffestc_local_.decl.basic_type,
12207                                        ffestc_local_.decl.kind_type,
12208                                        0,
12209                                        FFEINFO_kindFUNCTION,
12210                                        FFEINFO_whereLOCAL,
12211                                        ffestc_local_.decl.size));
12212
12213       /* Check whether the type info fits the filewide expectations;
12214          set ok flag accordingly.  */
12215
12216       ffesymbol_reference (fs, funcname, FALSE);
12217       if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
12218         ffestc_parent_ok_ = FALSE;
12219       else
12220         ffestc_parent_ok_ = TRUE;
12221     }
12222   else
12223     {
12224       if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12225         ffesymbol_error (fs, funcname);
12226       ffestc_parent_ok_ = FALSE;
12227     }
12228
12229   if (ffestc_parent_ok_)
12230     {
12231       ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12232       ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12233       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12234     }
12235
12236   if (result == NULL)
12237     res = funcname;
12238   else
12239     res = result;
12240
12241   s = ffesymbol_declare_funcresult (res);
12242   sa = ffesymbol_attrs (s);
12243
12244   /* Figure out what kind of object we've got based on previous declarations
12245      of or references to the object. */
12246
12247   if (sa & FFESYMBOL_attrsANY)
12248     na = FFESYMBOL_attrsANY;
12249   else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
12250     na = FFESYMBOL_attrsetNONE;
12251   else
12252     {
12253       na = FFESYMBOL_attrsRESULT;
12254       if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12255         {
12256           na |= FFESYMBOL_attrsTYPE;
12257           if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
12258               && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
12259             na |= FFESYMBOL_attrsANYLEN;
12260         }
12261     }
12262
12263   /* Now see what we've got for a new object: NONE means a new error cropped
12264      up; ANY means an old error to be ignored; otherwise, everything's ok,
12265      update the object (symbol) and continue on. */
12266
12267   if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
12268     {
12269       if (!(na & FFESYMBOL_attrsANY))
12270         ffesymbol_error (s, res);
12271       ffesymbol_set_funcresult (fs, NULL);
12272       ffesymbol_set_funcresult (s, NULL);
12273       ffestc_parent_ok_ = FALSE;
12274     }
12275   else
12276     {
12277       ffesymbol_set_attrs (s, na);
12278       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12279       ffesymbol_set_funcresult (fs, s);
12280       ffesymbol_set_funcresult (s, fs);
12281       if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
12282         {
12283           ffesymbol_set_info (s,
12284                               ffeinfo_new (ffestc_local_.decl.basic_type,
12285                                            ffestc_local_.decl.kind_type,
12286                                            0,
12287                                            FFEINFO_kindNONE,
12288                                            FFEINFO_whereNONE,
12289                                            ffestc_local_.decl.size));
12290         }
12291     }
12292
12293   ffesymbol_signal_unreported (fs);
12294
12295   ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
12296                 (recursive != NULL), result, separate_result);
12297 }
12298
12299 /* ffestc_R1221 -- END FUNCTION statement
12300
12301    ffestc_R1221(name_token);
12302
12303    Make sure ffestc_kind_ identifies the current kind of program unit.  If
12304    not NULL, make sure name_token gives the correct name.  Implement the end
12305    of the current program unit.  */
12306
12307 void
12308 ffestc_R1221 (ffelexToken name)
12309 {
12310   ffestc_check_simple_ ();
12311   if (ffestc_order_function_ () != FFESTC_orderOK_)
12312     return;
12313   ffestc_labeldef_notloop_ ();
12314
12315   if ((name != NULL)
12316     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12317     {
12318       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12319       ffebad_here (0, ffelex_token_where_line (name),
12320                    ffelex_token_where_column (name));
12321       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12322              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12323       ffebad_finish ();
12324     }
12325
12326   ffestc_shriek_function_ (TRUE);
12327 }
12328
12329 /* ffestc_R1223 -- SUBROUTINE statement
12330
12331    ffestc_R1223(subrname,arglist,ending_token,recursive_token);
12332
12333    Make sure statement is valid here, register arguments for the
12334    subroutine name, and so on.
12335
12336    06-Apr-90  JCB  2.0
12337       Added the recursive argument.  */
12338
12339 void
12340 ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
12341               ffelexToken final, ffelexToken recursive)
12342 {
12343   ffestw b;
12344   ffesymbol s;
12345
12346   assert ((subrname != NULL)
12347           && (ffelex_token_type (subrname) == FFELEX_typeNAME));
12348
12349   ffestc_check_simple_ ();
12350   if (ffestc_order_iface_ () != FFESTC_orderOK_)
12351     return;
12352   ffestc_labeldef_useless_ ();
12353
12354   ffestc_blocknum_ = 0;
12355   ffesta_is_entry_valid
12356     = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
12357   b = ffestw_update (ffestw_push (NULL));
12358   ffestw_set_top_do (b, NULL);
12359   ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
12360   ffestw_set_blocknum (b, ffestc_blocknum_++);
12361   ffestw_set_shriek (b, ffestc_shriek_subroutine_);
12362   ffestw_set_name (b, ffelex_token_use (subrname));
12363
12364   s = ffesymbol_declare_subrunit (subrname);
12365   if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12366     {
12367       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12368       ffesymbol_set_info (s,
12369                           ffeinfo_new (FFEINFO_basictypeNONE,
12370                                        FFEINFO_kindtypeNONE,
12371                                        0,
12372                                        FFEINFO_kindSUBROUTINE,
12373                                        FFEINFO_whereLOCAL,
12374                                        FFETARGET_charactersizeNONE));
12375       ffestc_parent_ok_ = TRUE;
12376     }
12377   else
12378     {
12379       if (ffesymbol_kind (s) != FFEINFO_kindANY)
12380         ffesymbol_error (s, subrname);
12381       ffestc_parent_ok_ = FALSE;
12382     }
12383
12384   if (ffestc_parent_ok_)
12385     {
12386       ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12387       ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12388       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12389     }
12390
12391   ffesymbol_signal_unreported (s);
12392
12393   ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
12394 }
12395
12396 /* ffestc_R1225 -- END SUBROUTINE statement
12397
12398    ffestc_R1225(name_token);
12399
12400    Make sure ffestc_kind_ identifies the current kind of program unit.  If
12401    not NULL, make sure name_token gives the correct name.  Implement the end
12402    of the current program unit.  */
12403
12404 void
12405 ffestc_R1225 (ffelexToken name)
12406 {
12407   ffestc_check_simple_ ();
12408   if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
12409     return;
12410   ffestc_labeldef_notloop_ ();
12411
12412   if ((name != NULL)
12413     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
12414     {
12415       ffebad_start (FFEBAD_UNIT_WRONG_NAME);
12416       ffebad_here (0, ffelex_token_where_line (name),
12417                    ffelex_token_where_column (name));
12418       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
12419              ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
12420       ffebad_finish ();
12421     }
12422
12423   ffestc_shriek_subroutine_ (TRUE);
12424 }
12425
12426 /* ffestc_R1226 -- ENTRY statement
12427
12428    ffestc_R1226(entryname,arglist,ending_token);
12429
12430    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
12431    entry point name, and so on.  */
12432
12433 void
12434 ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
12435               ffelexToken final UNUSED)
12436 {
12437   ffesymbol s;
12438   ffesymbol fs;
12439   ffesymbolAttrs sa;
12440   ffesymbolAttrs na;
12441   bool in_spec;                 /* TRUE if further specification statements
12442                                    may follow, FALSE if executable stmts. */
12443   bool in_func;                 /* TRUE if ENTRY is a FUNCTION, not
12444                                    SUBROUTINE. */
12445
12446   assert ((entryname != NULL)
12447           && (ffelex_token_type (entryname) == FFELEX_typeNAME));
12448
12449   ffestc_check_simple_ ();
12450   if (ffestc_order_entry_ () != FFESTC_orderOK_)
12451     return;
12452   ffestc_labeldef_useless_ ();
12453
12454   switch (ffestw_state (ffestw_stack_top ()))
12455     {
12456     case FFESTV_stateFUNCTION1:
12457     case FFESTV_stateFUNCTION2:
12458     case FFESTV_stateFUNCTION3:
12459       in_func = TRUE;
12460       in_spec = TRUE;
12461       break;
12462
12463     case FFESTV_stateFUNCTION4:
12464       in_func = TRUE;
12465       in_spec = FALSE;
12466       break;
12467
12468     case FFESTV_stateSUBROUTINE1:
12469     case FFESTV_stateSUBROUTINE2:
12470     case FFESTV_stateSUBROUTINE3:
12471       in_func = FALSE;
12472       in_spec = TRUE;
12473       break;
12474
12475     case FFESTV_stateSUBROUTINE4:
12476       in_func = FALSE;
12477       in_spec = FALSE;
12478       break;
12479
12480     default:
12481       assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
12482       in_func = FALSE;
12483       in_spec = FALSE;
12484       break;
12485     }
12486
12487   if (in_func)
12488     fs = ffesymbol_declare_funcunit (entryname);
12489   else
12490     fs = ffesymbol_declare_subrunit (entryname);
12491
12492   if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
12493     ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
12494   else
12495     {
12496       if (ffesymbol_kind (fs) != FFEINFO_kindANY)
12497         ffesymbol_error (fs, entryname);
12498     }
12499
12500   ++ffestc_entry_num_;
12501
12502   ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
12503   if (in_spec)
12504     ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
12505   else
12506     ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
12507   ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12508
12509   if (in_func)
12510     {
12511       s = ffesymbol_declare_funcresult (entryname);
12512       ffesymbol_set_funcresult (fs, s);
12513       ffesymbol_set_funcresult (s, fs);
12514       sa = ffesymbol_attrs (s);
12515
12516       /* Figure out what kind of object we've got based on previous
12517          declarations of or references to the object. */
12518
12519       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
12520         na = FFESYMBOL_attrsetNONE;
12521       else if (sa & FFESYMBOL_attrsANY)
12522         na = FFESYMBOL_attrsANY;
12523       else if (!(sa & ~(FFESYMBOL_attrsANYLEN
12524                         | FFESYMBOL_attrsTYPE)))
12525         na = sa | FFESYMBOL_attrsRESULT;
12526       else
12527         na = FFESYMBOL_attrsetNONE;
12528
12529       /* Now see what we've got for a new object: NONE means a new error
12530          cropped up; ANY means an old error to be ignored; otherwise,
12531          everything's ok, update the object (symbol) and continue on. */
12532
12533       if (na == FFESYMBOL_attrsetNONE)
12534         {
12535           ffesymbol_error (s, entryname);
12536           ffestc_parent_ok_ = FALSE;
12537         }
12538       else if (na & FFESYMBOL_attrsANY)
12539         {
12540           ffestc_parent_ok_ = FALSE;
12541         }
12542       else
12543         {
12544           ffesymbol_set_attrs (s, na);
12545           if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
12546             ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12547           else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
12548             {
12549               ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
12550               ffesymbol_set_info (s,
12551                                   ffeinfo_new (ffesymbol_basictype (s),
12552                                                ffesymbol_kindtype (s),
12553                                                0,
12554                                                FFEINFO_kindENTITY,
12555                                                FFEINFO_whereRESULT,
12556                                                ffesymbol_size (s)));
12557               ffesymbol_resolve_intrin (s);
12558               ffestorag_exec_layout (s);
12559             }
12560         }
12561
12562       /* Since ENTRY might appear after executable stmts, do what would have
12563          been done if it hadn't -- give symbol implicit type and
12564          exec-transition it.  */
12565
12566       if (!in_spec && ffesymbol_is_specable (s))
12567         {
12568           if (!ffeimplic_establish_symbol (s))  /* Do implicit typing. */
12569             ffesymbol_error (s, entryname);
12570           s = ffecom_sym_exec_transition (s);
12571         }
12572
12573       /* Use whatever type info is available for ENTRY to set up type for its
12574          global-name-space function symbol relative.  */
12575
12576       ffesymbol_set_info (fs,
12577                           ffeinfo_new (ffesymbol_basictype (s),
12578                                        ffesymbol_kindtype (s),
12579                                        0,
12580                                        FFEINFO_kindFUNCTION,
12581                                        FFEINFO_whereLOCAL,
12582                                        ffesymbol_size (s)));
12583
12584
12585       /* Check whether the type info fits the filewide expectations;
12586          set ok flag accordingly.  */
12587
12588       ffesymbol_reference (fs, entryname, FALSE);
12589
12590       /* ~~Question??:
12591          When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
12592          if FOO and IBAR would normally end up with different types?  I think
12593          the answer is that FOO is always given whatever type would be chosen
12594          for IBAR, rather than the other way around, and I think it ends up
12595          working that way for FUNCTION FOO() RESULT(IBAR), but this should be
12596          checked out in all its different combos. Related question is, is
12597          there any way that FOO in either case ends up without type info
12598          filled in?  Does anyone care?  */
12599
12600       ffesymbol_signal_unreported (s);
12601     }
12602   else
12603     {
12604       ffesymbol_set_info (fs,
12605                           ffeinfo_new (FFEINFO_basictypeNONE,
12606                                        FFEINFO_kindtypeNONE,
12607                                        0,
12608                                        FFEINFO_kindSUBROUTINE,
12609                                        FFEINFO_whereLOCAL,
12610                                        FFETARGET_charactersizeNONE));
12611     }
12612
12613   if (!in_spec)
12614     fs = ffecom_sym_exec_transition (fs);
12615
12616   ffesymbol_signal_unreported (fs);
12617
12618   ffestd_R1226 (fs);
12619 }
12620
12621 /* ffestc_R1227 -- RETURN statement
12622
12623    ffestc_R1227(expr,expr_token);
12624
12625    Make sure statement is valid here; implement.  expr and expr_token are
12626    both NULL if there was no expression.  */
12627
12628 void
12629 ffestc_R1227 (ffebld expr, ffelexToken expr_token)
12630 {
12631   ffestw b;
12632
12633   ffestc_check_simple_ ();
12634   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
12635     return;
12636   ffestc_labeldef_notloop_begin_ ();
12637
12638   for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
12639     {
12640       switch (ffestw_state (b))
12641         {
12642         case FFESTV_statePROGRAM4:
12643         case FFESTV_stateSUBROUTINE4:
12644         case FFESTV_stateFUNCTION4:
12645           goto base;            /* :::::::::::::::::::: */
12646
12647         case FFESTV_stateNIL:
12648           assert ("bad state" == NULL);
12649           break;
12650
12651         default:
12652           break;
12653         }
12654     }
12655
12656  base:
12657   switch (ffestw_state (b))
12658     {
12659     case FFESTV_statePROGRAM4:
12660       if (ffe_is_pedantic ())
12661         {
12662           ffebad_start (FFEBAD_RETURN_IN_MAIN);
12663           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12664                        ffelex_token_where_column (ffesta_tokens[0]));
12665           ffebad_finish ();
12666         }
12667       if (expr != NULL)
12668         {
12669           ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
12670           ffebad_here (0, ffelex_token_where_line (expr_token),
12671                        ffelex_token_where_column (expr_token));
12672           ffebad_finish ();
12673           expr = NULL;
12674         }
12675       break;
12676
12677     case FFESTV_stateSUBROUTINE4:
12678       break;
12679
12680     case FFESTV_stateFUNCTION4:
12681       if (expr != NULL)
12682         {
12683           ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
12684           ffebad_here (0, ffelex_token_where_line (expr_token),
12685                        ffelex_token_where_column (expr_token));
12686           ffebad_finish ();
12687           expr = NULL;
12688         }
12689       break;
12690
12691     default:
12692       assert ("bad state #2" == NULL);
12693       break;
12694     }
12695
12696   ffestd_R1227 (expr);
12697
12698   if (ffestc_shriek_after1_ != NULL)
12699     (*ffestc_shriek_after1_) (TRUE);
12700
12701   /* notloop's that are actionif's can be the target of a loop-end
12702      statement if they're in the "then" part of a logical IF, as
12703      in "DO 10", "10 IF (...) RETURN".  */
12704
12705   ffestc_labeldef_branch_end_ ();
12706 }
12707
12708 /* ffestc_R1228 -- CONTAINS statement
12709
12710    ffestc_R1228();  */
12711
12712 #if FFESTR_F90
12713 void
12714 ffestc_R1228 ()
12715 {
12716   ffestc_check_simple_ ();
12717   if (ffestc_order_contains_ () != FFESTC_orderOK_)
12718     return;
12719   ffestc_labeldef_useless_ ();
12720
12721   ffestd_R1228 ();
12722
12723   ffe_terminate_3 ();
12724   ffe_init_3 ();
12725 }
12726
12727 #endif
12728 /* ffestc_R1229_start -- STMTFUNCTION statement begin
12729
12730    ffestc_R1229_start(func_name,func_arg_list,close_paren);
12731
12732    Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
12733    "live" scope within the current scope, and expect the actual expression
12734    (or NULL) in ffestc_R1229_finish.  The reason there are two ffestc
12735    functions to handle this is so the scope can be established, allowing
12736    ffeexpr to assign proper characteristics to references to the dummy
12737    arguments.  */
12738
12739 void
12740 ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
12741                     ffelexToken final UNUSED)
12742 {
12743   ffesymbol s;
12744   ffesymbolAttrs sa;
12745   ffesymbolAttrs na;
12746
12747   ffestc_check_start_ ();
12748   if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
12749     {
12750       ffestc_ok_ = FALSE;
12751       return;
12752     }
12753   ffestc_labeldef_useless_ ();
12754
12755   assert (name != NULL);
12756   assert (args != NULL);
12757
12758   s = ffesymbol_declare_local (name, FALSE);
12759   sa = ffesymbol_attrs (s);
12760
12761   /* Figure out what kind of object we've got based on previous declarations
12762      of or references to the object. */
12763
12764   if (!ffesymbol_is_specable (s))
12765     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
12766   else if (sa & FFESYMBOL_attrsANY)
12767     na = FFESYMBOL_attrsANY;
12768   else if (!(sa & ~FFESYMBOL_attrsTYPE))
12769     na = sa | FFESYMBOL_attrsSFUNC;
12770   else
12771     na = FFESYMBOL_attrsetNONE;
12772
12773   /* Now see what we've got for a new object: NONE means a new error cropped
12774      up; ANY means an old error to be ignored; otherwise, everything's ok,
12775      update the object (symbol) and continue on. */
12776
12777   if (na == FFESYMBOL_attrsetNONE)
12778     {
12779       ffesymbol_error (s, name);
12780       ffestc_parent_ok_ = FALSE;
12781     }
12782   else if (na & FFESYMBOL_attrsANY)
12783     ffestc_parent_ok_ = FALSE;
12784   else
12785     {
12786       ffesymbol_set_attrs (s, na);
12787       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
12788       if (!ffeimplic_establish_symbol (s)
12789           || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
12790               && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
12791         {
12792           ffesymbol_error (s, ffesta_tokens[0]);
12793           ffestc_parent_ok_ = FALSE;
12794         }
12795       else
12796         {
12797           /* Tell ffeexpr that sfunc def is in progress.  */
12798           ffesymbol_set_sfexpr (s, ffebld_new_any ());
12799           ffestc_parent_ok_ = TRUE;
12800         }
12801     }
12802
12803   ffe_init_4 ();
12804
12805   if (ffestc_parent_ok_)
12806     {
12807       ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
12808       ffestc_sfdummy_argno_ = 0;
12809       ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
12810       ffebld_end_list (&ffestc_local_.dummy.list_bottom);
12811     }
12812
12813   ffestc_local_.sfunc.symbol = s;
12814
12815   ffestd_R1229_start (name, args);
12816
12817   ffestc_ok_ = TRUE;
12818 }
12819
12820 /* ffestc_R1229_finish -- STMTFUNCTION statement list complete
12821
12822    ffestc_R1229_finish(expr,expr_token);
12823
12824    If expr is NULL, an error occurred parsing the expansion expression, so
12825    just cancel the effects of ffestc_R1229_start and pretend nothing
12826    happened.  Otherwise, install the expression as the expansion for the
12827    statement function named in _start_, then clean up.  */
12828
12829 void
12830 ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
12831 {
12832   ffestc_check_finish_ ();
12833   if (!ffestc_ok_)
12834     return;
12835
12836   if (ffestc_parent_ok_ && (expr != NULL))
12837     ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
12838                           ffeexpr_convert_to_sym (expr,
12839                                                   expr_token,
12840                                                   ffestc_local_.sfunc.symbol,
12841                                                   ffesta_tokens[0]));
12842
12843   ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
12844
12845   ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
12846
12847   ffe_terminate_4 ();
12848 }
12849
12850 /* ffestc_S3P4 -- INCLUDE line
12851
12852    ffestc_S3P4(filename,filename_token);
12853
12854    Make sure INCLUDE not preceded by any semicolons or a label def; implement.  */
12855
12856 void
12857 ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
12858 {
12859   ffestc_check_simple_ ();
12860   ffestc_labeldef_invalid_ ();
12861
12862   ffestd_S3P4 (filename);
12863 }
12864
12865 /* ffestc_V003_start -- STRUCTURE statement list begin
12866
12867    ffestc_V003_start(structure_name);
12868
12869    Verify that STRUCTURE is valid here, and begin accepting items in the list.  */
12870
12871 #if FFESTR_VXT
12872 void
12873 ffestc_V003_start (ffelexToken structure_name)
12874 {
12875   ffestw b;
12876
12877   ffestc_check_start_ ();
12878   if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_)
12879     {
12880       ffestc_ok_ = FALSE;
12881       return;
12882     }
12883   ffestc_labeldef_useless_ ();
12884
12885   switch (ffestw_state (ffestw_stack_top ()))
12886     {
12887     case FFESTV_stateSTRUCTURE:
12888     case FFESTV_stateMAP:
12889       ffestc_local_.V003.list_state = 2;        /* Require at least one field
12890                                                    name. */
12891       ffestw_set_substate (ffestw_stack_top (), 1);     /* Seen at least one
12892                                                            member. */
12893       break;
12894
12895     default:
12896       ffestc_local_.V003.list_state = 0;        /* No field names required. */
12897       if (structure_name == NULL)
12898         {
12899           ffebad_start (FFEBAD_STRUCT_MISSING_NAME);
12900           ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12901                        ffelex_token_where_column (ffesta_tokens[0]));
12902           ffebad_finish ();
12903         }
12904       break;
12905     }
12906
12907   b = ffestw_update (ffestw_push (NULL));
12908   ffestw_set_top_do (b, NULL);
12909   ffestw_set_state (b, FFESTV_stateSTRUCTURE);
12910   ffestw_set_blocknum (b, 0);
12911   ffestw_set_shriek (b, ffestc_shriek_structure_);
12912   ffestw_set_substate (b, 0);   /* No field-declarations seen yet. */
12913
12914   ffestd_V003_start (structure_name);
12915
12916   ffestc_ok_ = TRUE;
12917 }
12918
12919 /* ffestc_V003_item -- STRUCTURE statement for object-name
12920
12921    ffestc_V003_item(name_token,dim_list);
12922
12923    Make sure name_token identifies a valid object to be STRUCTUREd.  */
12924
12925 void
12926 ffestc_V003_item (ffelexToken name, ffesttDimList dims)
12927 {
12928   ffestc_check_item_ ();
12929   assert (name != NULL);
12930   if (!ffestc_ok_)
12931     return;
12932
12933   if (ffestc_local_.V003.list_state < 2)
12934     {
12935       if (ffestc_local_.V003.list_state == 0)
12936         {
12937           ffestc_local_.V003.list_state = 1;
12938           ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD);
12939           ffebad_here (0, ffelex_token_where_line (name),
12940                        ffelex_token_where_column (name));
12941           ffebad_finish ();
12942         }
12943       return;
12944     }
12945   ffestc_local_.V003.list_state = 3;    /* Have at least one field name. */
12946
12947   if (dims != NULL)
12948     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
12949
12950   ffestd_V003_item (name, dims);
12951 }
12952
12953 /* ffestc_V003_finish -- STRUCTURE statement list complete
12954
12955    ffestc_V003_finish();
12956
12957    Just wrap up any local activities.  */
12958
12959 void
12960 ffestc_V003_finish ()
12961 {
12962   ffestc_check_finish_ ();
12963   if (!ffestc_ok_)
12964     return;
12965
12966   if (ffestc_local_.V003.list_state == 2)
12967     {
12968       ffebad_start (FFEBAD_STRUCT_MISSING_FIELD);
12969       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12970                    ffelex_token_where_column (ffesta_tokens[0]));
12971       ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())),
12972                    ffestw_col (ffestw_previous (ffestw_stack_top ())));
12973       ffebad_finish ();
12974     }
12975
12976   ffestd_V003_finish ();
12977 }
12978
12979 /* ffestc_V004 -- END STRUCTURE statement
12980
12981    ffestc_V004();
12982
12983    Make sure ffestc_kind_ identifies a STRUCTURE block.
12984    Implement the end of the current STRUCTURE block.  */
12985
12986 void
12987 ffestc_V004 ()
12988 {
12989   ffestc_check_simple_ ();
12990   if (ffestc_order_structure_ () != FFESTC_orderOK_)
12991     return;
12992   ffestc_labeldef_useless_ ();
12993
12994   if (ffestw_substate (ffestw_stack_top ()) != 1)
12995     {
12996       ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS);
12997       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
12998                    ffelex_token_where_column (ffesta_tokens[0]));
12999       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13000       ffebad_finish ();
13001     }
13002
13003   ffestc_shriek_structure_ (TRUE);
13004 }
13005
13006 /* ffestc_V009 -- UNION statement
13007
13008    ffestc_V009();  */
13009
13010 void
13011 ffestc_V009 ()
13012 {
13013   ffestw b;
13014
13015   ffestc_check_simple_ ();
13016   if (ffestc_order_structure_ () != FFESTC_orderOK_)
13017     return;
13018   ffestc_labeldef_useless_ ();
13019
13020   ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */
13021
13022   b = ffestw_update (ffestw_push (NULL));
13023   ffestw_set_top_do (b, NULL);
13024   ffestw_set_state (b, FFESTV_stateUNION);
13025   ffestw_set_blocknum (b, 0);
13026   ffestw_set_shriek (b, ffestc_shriek_union_);
13027   ffestw_set_substate (b, 0);   /* No map decls seen yet. */
13028
13029   ffestd_V009 ();
13030 }
13031
13032 /* ffestc_V010 -- END UNION statement
13033
13034    ffestc_V010();
13035
13036    Make sure ffestc_kind_ identifies a UNION block.
13037    Implement the end of the current UNION block.  */
13038
13039 void
13040 ffestc_V010 ()
13041 {
13042   ffestc_check_simple_ ();
13043   if (ffestc_order_union_ () != FFESTC_orderOK_)
13044     return;
13045   ffestc_labeldef_useless_ ();
13046
13047   if (ffestw_substate (ffestw_stack_top ()) != 2)
13048     {
13049       ffebad_start (FFEBAD_UNION_NO_TWO_MAPS);
13050       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13051                    ffelex_token_where_column (ffesta_tokens[0]));
13052       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13053       ffebad_finish ();
13054     }
13055
13056   ffestc_shriek_union_ (TRUE);
13057 }
13058
13059 /* ffestc_V012 -- MAP statement
13060
13061    ffestc_V012();  */
13062
13063 void
13064 ffestc_V012 ()
13065 {
13066   ffestw b;
13067
13068   ffestc_check_simple_ ();
13069   if (ffestc_order_union_ () != FFESTC_orderOK_)
13070     return;
13071   ffestc_labeldef_useless_ ();
13072
13073   if (ffestw_substate (ffestw_stack_top ()) != 2)
13074     ffestw_substate (ffestw_stack_top ())++;    /* 0=>1, 1=>2. */
13075
13076   b = ffestw_update (ffestw_push (NULL));
13077   ffestw_set_top_do (b, NULL);
13078   ffestw_set_state (b, FFESTV_stateMAP);
13079   ffestw_set_blocknum (b, 0);
13080   ffestw_set_shriek (b, ffestc_shriek_map_);
13081   ffestw_set_substate (b, 0);   /* No field-declarations seen yet. */
13082
13083   ffestd_V012 ();
13084 }
13085
13086 /* ffestc_V013 -- END MAP statement
13087
13088    ffestc_V013();
13089
13090    Make sure ffestc_kind_ identifies a MAP block.
13091    Implement the end of the current MAP block.  */
13092
13093 void
13094 ffestc_V013 ()
13095 {
13096   ffestc_check_simple_ ();
13097   if (ffestc_order_map_ () != FFESTC_orderOK_)
13098     return;
13099   ffestc_labeldef_useless_ ();
13100
13101   if (ffestw_substate (ffestw_stack_top ()) != 1)
13102     {
13103       ffebad_start (FFEBAD_MAP_NO_COMPONENTS);
13104       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13105                    ffelex_token_where_column (ffesta_tokens[0]));
13106       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
13107       ffebad_finish ();
13108     }
13109
13110   ffestc_shriek_map_ (TRUE);
13111 }
13112
13113 #endif
13114 /* ffestc_V014_start -- VOLATILE statement list begin
13115
13116    ffestc_V014_start();
13117
13118    Verify that VOLATILE is valid here, and begin accepting items in the
13119    list.  */
13120
13121 void
13122 ffestc_V014_start ()
13123 {
13124   ffestc_check_start_ ();
13125   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
13126     {
13127       ffestc_ok_ = FALSE;
13128       return;
13129     }
13130   ffestc_labeldef_useless_ ();
13131
13132   ffestd_V014_start ();
13133
13134   ffestc_ok_ = TRUE;
13135 }
13136
13137 /* ffestc_V014_item_object -- VOLATILE statement for object-name
13138
13139    ffestc_V014_item_object(name_token);
13140
13141    Make sure name_token identifies a valid object to be VOLATILEd.  */
13142
13143 void
13144 ffestc_V014_item_object (ffelexToken name)
13145 {
13146   ffestc_check_item_ ();
13147   assert (name != NULL);
13148   if (!ffestc_ok_)
13149     return;
13150
13151   ffestd_V014_item_object (name);
13152 }
13153
13154 /* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
13155
13156    ffestc_V014_item_cblock(name_token);
13157
13158    Make sure name_token identifies a valid common block to be VOLATILEd.  */
13159
13160 void
13161 ffestc_V014_item_cblock (ffelexToken name)
13162 {
13163   ffestc_check_item_ ();
13164   assert (name != NULL);
13165   if (!ffestc_ok_)
13166     return;
13167
13168   ffestd_V014_item_cblock (name);
13169 }
13170
13171 /* ffestc_V014_finish -- VOLATILE statement list complete
13172
13173    ffestc_V014_finish();
13174
13175    Just wrap up any local activities.  */
13176
13177 void
13178 ffestc_V014_finish ()
13179 {
13180   ffestc_check_finish_ ();
13181   if (!ffestc_ok_)
13182     return;
13183
13184   ffestd_V014_finish ();
13185 }
13186
13187 /* ffestc_V016_start -- RECORD statement list begin
13188
13189    ffestc_V016_start();
13190
13191    Verify that RECORD is valid here, and begin accepting items in the list.  */
13192
13193 #if FFESTR_VXT
13194 void
13195 ffestc_V016_start ()
13196 {
13197   ffestc_check_start_ ();
13198   if (ffestc_order_record_ () != FFESTC_orderOK_)
13199     {
13200       ffestc_ok_ = FALSE;
13201       return;
13202     }
13203   ffestc_labeldef_useless_ ();
13204
13205   switch (ffestw_state (ffestw_stack_top ()))
13206     {
13207     case FFESTV_stateSTRUCTURE:
13208     case FFESTV_stateMAP:
13209       ffestw_set_substate (ffestw_stack_top (), 1);     /* Seen at least one
13210                                                            member. */
13211       break;
13212
13213     default:
13214       break;
13215     }
13216
13217   ffestd_V016_start ();
13218
13219   ffestc_ok_ = TRUE;
13220 }
13221
13222 /* ffestc_V016_item_structure -- RECORD statement for common-block-name
13223
13224    ffestc_V016_item_structure(name_token);
13225
13226    Make sure name_token identifies a valid structure to be RECORDed.  */
13227
13228 void
13229 ffestc_V016_item_structure (ffelexToken name)
13230 {
13231   ffestc_check_item_ ();
13232   assert (name != NULL);
13233   if (!ffestc_ok_)
13234     return;
13235
13236   ffestd_V016_item_structure (name);
13237 }
13238
13239 /* ffestc_V016_item_object -- RECORD statement for object-name
13240
13241    ffestc_V016_item_object(name_token,dim_list);
13242
13243    Make sure name_token identifies a valid object to be RECORDd.  */
13244
13245 void
13246 ffestc_V016_item_object (ffelexToken name, ffesttDimList dims)
13247 {
13248   ffestc_check_item_ ();
13249   assert (name != NULL);
13250   if (!ffestc_ok_)
13251     return;
13252
13253   if (dims != NULL)
13254     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
13255
13256   ffestd_V016_item_object (name, dims);
13257 }
13258
13259 /* ffestc_V016_finish -- RECORD statement list complete
13260
13261    ffestc_V016_finish();
13262
13263    Just wrap up any local activities.  */
13264
13265 void
13266 ffestc_V016_finish ()
13267 {
13268   ffestc_check_finish_ ();
13269   if (!ffestc_ok_)
13270     return;
13271
13272   ffestd_V016_finish ();
13273 }
13274
13275 /* ffestc_V018_start -- REWRITE(...) statement list begin
13276
13277    ffestc_V018_start();
13278
13279    Verify that REWRITE is valid here, and begin accepting items in the
13280    list.  */
13281
13282 void
13283 ffestc_V018_start ()
13284 {
13285   ffestvFormat format;
13286
13287   ffestc_check_start_ ();
13288   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13289     {
13290       ffestc_ok_ = FALSE;
13291       return;
13292     }
13293   ffestc_labeldef_branch_begin_ ();
13294
13295   if (!ffestc_subr_is_branch_
13296       (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR])
13297       || !ffestc_subr_is_format_
13298       (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT])
13299       || !ffestc_subr_is_present_ ("UNIT",
13300                    &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT]))
13301     {
13302       ffestc_ok_ = FALSE;
13303       return;
13304     }
13305
13306   format = ffestc_subr_format_
13307     (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]);
13308   switch (format)
13309     {
13310     case FFESTV_formatNAMELIST:
13311     case FFESTV_formatASTERISK:
13312       ffebad_start (FFEBAD_CONFLICTING_SPECS);
13313       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
13314                    ffelex_token_where_column (ffesta_tokens[0]));
13315       assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present);
13316       if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present)
13317         {
13318           ffebad_here (0, ffelex_token_where_line
13319                  (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw),
13320                        ffelex_token_where_column
13321                 (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw));
13322         }
13323       else
13324         {
13325           ffebad_here (1, ffelex_token_where_line
13326               (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value),
13327                        ffelex_token_where_column
13328              (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value));
13329         }
13330       ffebad_finish ();
13331       ffestc_ok_ = FALSE;
13332       return;
13333
13334     default:
13335       break;
13336     }
13337
13338   ffestd_V018_start (format);
13339
13340   ffestc_ok_ = TRUE;
13341 }
13342
13343 /* ffestc_V018_item -- REWRITE statement i/o item
13344
13345    ffestc_V018_item(expr,expr_token);
13346
13347    Implement output-list expression.  */
13348
13349 void
13350 ffestc_V018_item (ffebld expr, ffelexToken expr_token)
13351 {
13352   ffestc_check_item_ ();
13353   if (!ffestc_ok_)
13354     return;
13355
13356   ffestd_V018_item (expr);
13357 }
13358
13359 /* ffestc_V018_finish -- REWRITE statement list complete
13360
13361    ffestc_V018_finish();
13362
13363    Just wrap up any local activities.  */
13364
13365 void
13366 ffestc_V018_finish ()
13367 {
13368   ffestc_check_finish_ ();
13369   if (!ffestc_ok_)
13370     return;
13371
13372   ffestd_V018_finish ();
13373
13374   if (ffestc_shriek_after1_ != NULL)
13375     (*ffestc_shriek_after1_) (TRUE);
13376   ffestc_labeldef_branch_end_ ();
13377 }
13378
13379 /* ffestc_V019_start -- ACCEPT statement list begin
13380
13381    ffestc_V019_start();
13382
13383    Verify that ACCEPT is valid here, and begin accepting items in the
13384    list.  */
13385
13386 void
13387 ffestc_V019_start ()
13388 {
13389   ffestvFormat format;
13390
13391   ffestc_check_start_ ();
13392   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13393     {
13394       ffestc_ok_ = FALSE;
13395       return;
13396     }
13397   ffestc_labeldef_branch_begin_ ();
13398
13399   if (!ffestc_subr_is_format_
13400       (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]))
13401     {
13402       ffestc_ok_ = FALSE;
13403       return;
13404     }
13405
13406   format = ffestc_subr_format_
13407     (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]);
13408   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13409
13410   ffestd_V019_start (format);
13411
13412   ffestc_ok_ = TRUE;
13413 }
13414
13415 /* ffestc_V019_item -- ACCEPT statement i/o item
13416
13417    ffestc_V019_item(expr,expr_token);
13418
13419    Implement output-list expression.  */
13420
13421 void
13422 ffestc_V019_item (ffebld expr, ffelexToken expr_token)
13423 {
13424   ffestc_check_item_ ();
13425   if (!ffestc_ok_)
13426     return;
13427
13428   if (ffestc_namelist_ != 0)
13429     {
13430       if (ffestc_namelist_ == 1)
13431         {
13432           ffestc_namelist_ = 2;
13433           ffebad_start (FFEBAD_NAMELIST_ITEMS);
13434           ffebad_here (0, ffelex_token_where_line (expr_token),
13435                        ffelex_token_where_column (expr_token));
13436           ffebad_finish ();
13437         }
13438       return;
13439     }
13440
13441   ffestd_V019_item (expr);
13442 }
13443
13444 /* ffestc_V019_finish -- ACCEPT statement list complete
13445
13446    ffestc_V019_finish();
13447
13448    Just wrap up any local activities.  */
13449
13450 void
13451 ffestc_V019_finish ()
13452 {
13453   ffestc_check_finish_ ();
13454   if (!ffestc_ok_)
13455     return;
13456
13457   ffestd_V019_finish ();
13458
13459   if (ffestc_shriek_after1_ != NULL)
13460     (*ffestc_shriek_after1_) (TRUE);
13461   ffestc_labeldef_branch_end_ ();
13462 }
13463
13464 #endif
13465 /* ffestc_V020_start -- TYPE statement list begin
13466
13467    ffestc_V020_start();
13468
13469    Verify that TYPE is valid here, and begin accepting items in the
13470    list.  */
13471
13472 void
13473 ffestc_V020_start ()
13474 {
13475   ffestvFormat format;
13476
13477   ffestc_check_start_ ();
13478   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13479     {
13480       ffestc_ok_ = FALSE;
13481       return;
13482     }
13483   ffestc_labeldef_branch_begin_ ();
13484
13485   if (!ffestc_subr_is_format_
13486       (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
13487     {
13488       ffestc_ok_ = FALSE;
13489       return;
13490     }
13491
13492   format = ffestc_subr_format_
13493     (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
13494   ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
13495
13496   ffestd_V020_start (format);
13497
13498   ffestc_ok_ = TRUE;
13499 }
13500
13501 /* ffestc_V020_item -- TYPE statement i/o item
13502
13503    ffestc_V020_item(expr,expr_token);
13504
13505    Implement output-list expression.  */
13506
13507 void
13508 ffestc_V020_item (ffebld expr, ffelexToken expr_token)
13509 {
13510   ffestc_check_item_ ();
13511   if (!ffestc_ok_)
13512     return;
13513
13514   if (ffestc_namelist_ != 0)
13515     {
13516       if (ffestc_namelist_ == 1)
13517         {
13518           ffestc_namelist_ = 2;
13519           ffebad_start (FFEBAD_NAMELIST_ITEMS);
13520           ffebad_here (0, ffelex_token_where_line (expr_token),
13521                        ffelex_token_where_column (expr_token));
13522           ffebad_finish ();
13523         }
13524       return;
13525     }
13526
13527   ffestd_V020_item (expr);
13528 }
13529
13530 /* ffestc_V020_finish -- TYPE statement list complete
13531
13532    ffestc_V020_finish();
13533
13534    Just wrap up any local activities.  */
13535
13536 void
13537 ffestc_V020_finish ()
13538 {
13539   ffestc_check_finish_ ();
13540   if (!ffestc_ok_)
13541     return;
13542
13543   ffestd_V020_finish ();
13544
13545   if (ffestc_shriek_after1_ != NULL)
13546     (*ffestc_shriek_after1_) (TRUE);
13547   ffestc_labeldef_branch_end_ ();
13548 }
13549
13550 /* ffestc_V021 -- DELETE statement
13551
13552    ffestc_V021();
13553
13554    Make sure a DELETE is valid in the current context, and implement it.  */
13555
13556 #if FFESTR_VXT
13557 void
13558 ffestc_V021 ()
13559 {
13560   ffestc_check_simple_ ();
13561   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13562     return;
13563   ffestc_labeldef_branch_begin_ ();
13564
13565   if (ffestc_subr_is_branch_
13566       (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR])
13567       && ffestc_subr_is_present_ ("UNIT",
13568                       &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT]))
13569     ffestd_V021 ();
13570
13571   if (ffestc_shriek_after1_ != NULL)
13572     (*ffestc_shriek_after1_) (TRUE);
13573   ffestc_labeldef_branch_end_ ();
13574 }
13575
13576 /* ffestc_V022 -- UNLOCK statement
13577
13578    ffestc_V022();
13579
13580    Make sure a UNLOCK is valid in the current context, and implement it.  */
13581
13582 void
13583 ffestc_V022 ()
13584 {
13585   ffestc_check_simple_ ();
13586   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13587     return;
13588   ffestc_labeldef_branch_begin_ ();
13589
13590   if (ffestc_subr_is_branch_
13591       (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
13592       && ffestc_subr_is_present_ ("UNIT",
13593                             &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
13594     ffestd_V022 ();
13595
13596   if (ffestc_shriek_after1_ != NULL)
13597     (*ffestc_shriek_after1_) (TRUE);
13598   ffestc_labeldef_branch_end_ ();
13599 }
13600
13601 /* ffestc_V023_start -- ENCODE(...) statement list begin
13602
13603    ffestc_V023_start();
13604
13605    Verify that ENCODE is valid here, and begin accepting items in the
13606    list.  */
13607
13608 void
13609 ffestc_V023_start ()
13610 {
13611   ffestc_check_start_ ();
13612   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13613     {
13614       ffestc_ok_ = FALSE;
13615       return;
13616     }
13617   ffestc_labeldef_branch_begin_ ();
13618
13619   if (!ffestc_subr_is_branch_
13620       (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13621     {
13622       ffestc_ok_ = FALSE;
13623       return;
13624     }
13625
13626   ffestd_V023_start ();
13627
13628   ffestc_ok_ = TRUE;
13629 }
13630
13631 /* ffestc_V023_item -- ENCODE statement i/o item
13632
13633    ffestc_V023_item(expr,expr_token);
13634
13635    Implement output-list expression.  */
13636
13637 void
13638 ffestc_V023_item (ffebld expr, ffelexToken expr_token)
13639 {
13640   ffestc_check_item_ ();
13641   if (!ffestc_ok_)
13642     return;
13643
13644   ffestd_V023_item (expr);
13645 }
13646
13647 /* ffestc_V023_finish -- ENCODE statement list complete
13648
13649    ffestc_V023_finish();
13650
13651    Just wrap up any local activities.  */
13652
13653 void
13654 ffestc_V023_finish ()
13655 {
13656   ffestc_check_finish_ ();
13657   if (!ffestc_ok_)
13658     return;
13659
13660   ffestd_V023_finish ();
13661
13662   if (ffestc_shriek_after1_ != NULL)
13663     (*ffestc_shriek_after1_) (TRUE);
13664   ffestc_labeldef_branch_end_ ();
13665 }
13666
13667 /* ffestc_V024_start -- DECODE(...) statement list begin
13668
13669    ffestc_V024_start();
13670
13671    Verify that DECODE is valid here, and begin accepting items in the
13672    list.  */
13673
13674 void
13675 ffestc_V024_start ()
13676 {
13677   ffestc_check_start_ ();
13678   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13679     {
13680       ffestc_ok_ = FALSE;
13681       return;
13682     }
13683   ffestc_labeldef_branch_begin_ ();
13684
13685   if (!ffestc_subr_is_branch_
13686       (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
13687     {
13688       ffestc_ok_ = FALSE;
13689       return;
13690     }
13691
13692   ffestd_V024_start ();
13693
13694   ffestc_ok_ = TRUE;
13695 }
13696
13697 /* ffestc_V024_item -- DECODE statement i/o item
13698
13699    ffestc_V024_item(expr,expr_token);
13700
13701    Implement output-list expression.  */
13702
13703 void
13704 ffestc_V024_item (ffebld expr, ffelexToken expr_token)
13705 {
13706   ffestc_check_item_ ();
13707   if (!ffestc_ok_)
13708     return;
13709
13710   ffestd_V024_item (expr);
13711 }
13712
13713 /* ffestc_V024_finish -- DECODE statement list complete
13714
13715    ffestc_V024_finish();
13716
13717    Just wrap up any local activities.  */
13718
13719 void
13720 ffestc_V024_finish ()
13721 {
13722   ffestc_check_finish_ ();
13723   if (!ffestc_ok_)
13724     return;
13725
13726   ffestd_V024_finish ();
13727
13728   if (ffestc_shriek_after1_ != NULL)
13729     (*ffestc_shriek_after1_) (TRUE);
13730   ffestc_labeldef_branch_end_ ();
13731 }
13732
13733 /* ffestc_V025_start -- DEFINEFILE statement list begin
13734
13735    ffestc_V025_start();
13736
13737    Verify that DEFINEFILE is valid here, and begin accepting items in the
13738    list.  */
13739
13740 void
13741 ffestc_V025_start ()
13742 {
13743   ffestc_check_start_ ();
13744   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13745     {
13746       ffestc_ok_ = FALSE;
13747       return;
13748     }
13749   ffestc_labeldef_branch_begin_ ();
13750
13751   ffestd_V025_start ();
13752
13753   ffestc_ok_ = TRUE;
13754 }
13755
13756 /* ffestc_V025_item -- DEFINE FILE statement item
13757
13758    ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt);
13759
13760    Implement item.  */
13761
13762 void
13763 ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt,
13764                   ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt)
13765 {
13766   ffestc_check_item_ ();
13767   if (!ffestc_ok_)
13768     return;
13769
13770   ffestd_V025_item (u, m, n, asv);
13771 }
13772
13773 /* ffestc_V025_finish -- DEFINE FILE statement list complete
13774
13775    ffestc_V025_finish();
13776
13777    Just wrap up any local activities.  */
13778
13779 void
13780 ffestc_V025_finish ()
13781 {
13782   ffestc_check_finish_ ();
13783   if (!ffestc_ok_)
13784     return;
13785
13786   ffestd_V025_finish ();
13787
13788   if (ffestc_shriek_after1_ != NULL)
13789     (*ffestc_shriek_after1_) (TRUE);
13790   ffestc_labeldef_branch_end_ ();
13791 }
13792
13793 /* ffestc_V026 -- FIND statement
13794
13795    ffestc_V026();
13796
13797    Make sure a FIND is valid in the current context, and implement it.  */
13798
13799 void
13800 ffestc_V026 ()
13801 {
13802   ffestc_check_simple_ ();
13803   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
13804     return;
13805   ffestc_labeldef_branch_begin_ ();
13806
13807   if (ffestc_subr_is_branch_
13808       (&ffestp_file.find.find_spec[FFESTP_findixERR])
13809       && ffestc_subr_is_present_ ("UNIT",
13810                              &ffestp_file.find.find_spec[FFESTP_findixUNIT])
13811       && ffestc_subr_is_present_ ("REC",
13812                              &ffestp_file.find.find_spec[FFESTP_findixREC]))
13813     ffestd_V026 ();
13814
13815   if (ffestc_shriek_after1_ != NULL)
13816     (*ffestc_shriek_after1_) (TRUE);
13817   ffestc_labeldef_branch_end_ ();
13818 }
13819
13820 #endif
13821 /* ffestc_V027_start -- VXT PARAMETER statement list begin
13822
13823    ffestc_V027_start();
13824
13825    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
13826
13827 void
13828 ffestc_V027_start ()
13829 {
13830   ffestc_check_start_ ();
13831   if (ffestc_order_parameter_ () != FFESTC_orderOK_)
13832     {
13833       ffestc_ok_ = FALSE;
13834       return;
13835     }
13836   ffestc_labeldef_useless_ ();
13837
13838   ffestd_V027_start ();
13839
13840   ffestc_ok_ = TRUE;
13841 }
13842
13843 /* ffestc_V027_item -- VXT PARAMETER statement assignment
13844
13845    ffestc_V027_item(dest,dest_token,source,source_token);
13846
13847    Make sure the source is a valid source for the destination; make the
13848    assignment.  */
13849
13850 void
13851 ffestc_V027_item (ffelexToken dest_token, ffebld source,
13852                   ffelexToken source_token UNUSED)
13853 {
13854   ffestc_check_item_ ();
13855   if (!ffestc_ok_)
13856     return;
13857
13858   ffestd_V027_item (dest_token, source);
13859 }
13860
13861 /* ffestc_V027_finish -- VXT PARAMETER statement list complete
13862
13863    ffestc_V027_finish();
13864
13865    Just wrap up any local activities.  */
13866
13867 void
13868 ffestc_V027_finish ()
13869 {
13870   ffestc_check_finish_ ();
13871   if (!ffestc_ok_)
13872     return;
13873
13874   ffestd_V027_finish ();
13875 }
13876
13877 /* Any executable statement.  Mainly make sure that one-shot things
13878    like the statement for a logical IF are reset.  */
13879
13880 void
13881 ffestc_any ()
13882 {
13883   ffestc_check_simple_ ();
13884
13885   ffestc_order_any_ ();
13886
13887   ffestc_labeldef_any_ ();
13888
13889   if (ffestc_shriek_after1_ == NULL)
13890     return;
13891
13892   ffestd_any ();
13893
13894   (*ffestc_shriek_after1_) (TRUE);
13895 }