gcc/f/stc.c

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