Open64: osprey/kgccfe/gnu/f/stc.c Source File

00001 /* stc.c -- Implementation File (module.c template V1.0)
00002    Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
00003    Contributed by James Craig Burley.
00004 
00005 This file is part of GNU Fortran.
00006 
00007 GNU Fortran is free software; you can redistribute it and/or modify
00008 it under the terms of the GNU General Public License as published by
00009 the Free Software Foundation; either version 2, or (at your option)
00010 any later version.
00011 
00012 GNU Fortran is distributed in the hope that it will be useful,
00013 but WITHOUT ANY WARRANTY; without even the implied warranty of
00014 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00015 GNU General Public License for more details.
00016 
00017 You should have received a copy of the GNU General Public License
00018 along with GNU Fortran; see the file COPYING.  If not, write to
00019 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
00020 02111-1307, USA.
00021 
00022    Related Modules:
00023       st.c
00024 
00025    Description:
00026       Verifies the proper semantics for statements, checking expressions already
00027       semantically analyzed individually, collectively, checking label defs and
00028       refs, and so on.  Uses ffebad to indicate errors in semantics.
00029 
00030       In many cases, both a token and a keyword (ffestrFirst, ffestrSecond,
00031       or ffestrOther) is provided.  ONLY USE THE TOKEN as a pointer to the
00032       source-code location for an error message or similar; use the keyword
00033       as the semantic matching for the token, since the token's text might
00034       not match the keyword's code.  For example, INTENT(IN OUT) A in free
00035       source form passes to ffestc_R519_start the token "IN" but the keyword
00036       FFESTR_otherINOUT, and the latter is correct.
00037 
00038       Generally, either a single ffestc function handles an entire statement,
00039       in which case its name is ffestc_xyz_, or more than one function is
00040       needed, in which case its names are ffestc_xyz_start_,
00041       ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_.
00042       The caller must call _start_ before calling any _item_ functions, and
00043       must call _finish_ afterwards.  If it is clearly a syntactic matter as
00044       to restrictions on the number and variety of _item_ calls, then the caller
00045       should report any errors and ffestc_ should presume it has been taken
00046       care of and handle any semantic problems with grace and no error messages.
00047       If the permitted number and variety of _item_ calls has some basis in
00048       semantics, then the caller should not generate any messages and ffestc
00049       should do all the checking.
00050 
00051       A few ffestc functions have names rather than grammar numbers, like
00052       ffestc_elsewhere and ffestc_end.  These are cases where the actual
00053       statement depends on its context rather than just its form; ELSE WHERE
00054       may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little
00055       more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE).  The actual
00056       ffestc functions do exist and do work, but may or may not be invoked
00057       by ffestb depending on whether some form of resolution is possible.
00058       For example, ffestc_R1103 end-program-stmt is reachable directly when
00059       END PROGRAM [name] is specified, or via ffestc_end when END is specified
00060       and the context is a main program.  So ffestc_xyz_ should make a quick
00061       determination of the context and pick the appropriate ffestc_Nxyz_
00062       function to invoke, without a lot of ceremony.
00063 
00064    Modifications:
00065 */
00066 
00067 /* Include files. */
00068 
00069 #include "proj.h"
00070 #include "stc.h"
00071 #include "bad.h"
00072 #include "bld.h"
00073 #include "data.h"
00074 #include "expr.h"
00075 #include "global.h"
00076 #include "implic.h"
00077 #include "lex.h"
00078 #include "malloc.h"
00079 #include "src.h"
00080 #include "sta.h"
00081 #include "std.h"
00082 #include "stp.h"
00083 #include "str.h"
00084 #include "stt.h"
00085 #include "stw.h"
00086 
00087 /* Externals defined here. */
00088 
00089 ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
00090 /* Valid only from READ/WRITE start to finish. */
00091 
00092 /* Simple definitions and enumerations. */
00093 
00094 typedef enum
00095   {
00096     FFESTC_orderOK_,    /* Statement ok in this context, process. */
00097     FFESTC_orderBAD_,   /* Statement not ok in this context, don't
00098            process. */
00099     FFESTC_orderBADOK_,   /* Don't process but push block if
00100            applicable. */
00101     FFESTC
00102   } ffestcOrder_;
00103 
00104 typedef enum
00105   {
00106     FFESTC_stateletSIMPLE_, /* Expecting simple/start. */
00107     FFESTC_stateletATTRIB_, /* Expecting attrib/item/itemstart. */
00108     FFESTC_stateletITEM_, /* Expecting item/itemstart/finish. */
00109     FFESTC_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */
00110     FFESTC_
00111   } ffestcStatelet_;
00112 
00113 /* Internal typedefs. */
00114 
00115 
00116 /* Private include files. */
00117 
00118 
00119 /* Internal structure definitions. */
00120 
00121 union ffestc_local_u_
00122   {
00123     struct
00124       {
00125   ffebld initlist;  /* For list of one sym in INTEGER I/3/ case. */
00126   ffetargetCharacterSize stmt_size;
00127   ffetargetCharacterSize size;
00128   ffeinfoBasictype basic_type;
00129   ffeinfoKindtype stmt_kind_type;
00130   ffeinfoKindtype kind_type;
00131   bool per_var_kind_ok;
00132   char is_R426;   /* 1=R426, 2=R501. */
00133       }
00134     decl;
00135     struct
00136       {
00137   ffebld objlist;   /* For list of target objects. */
00138   ffebldListBottom list_bottom; /* For building lists. */
00139       }
00140     data;
00141     struct
00142       {
00143   ffebldListBottom list_bottom; /* For building lists. */
00144   int entry_num;
00145       }
00146     dummy;
00147     struct
00148       {
00149   ffesymbol symbol; /* NML symbol. */
00150       }
00151     namelist;
00152     struct
00153       {
00154   ffelexToken t;    /* First token in list. */
00155   ffeequiv eq;    /* Current equivalence being built up. */
00156   ffebld list;    /* List of expressions in equivalence. */
00157   ffebldListBottom bottom;
00158   bool ok;    /* TRUE while current list still being
00159            processed. */
00160   bool save;    /* TRUE if any var in list is SAVEd. */
00161       }
00162     equiv;
00163     struct
00164       {
00165   ffesymbol symbol; /* BCB/NCB symbol. */
00166       }
00167     common;
00168     struct
00169       {
00170   ffesymbol symbol; /* SFN symbol. */
00171       }
00172     sfunc;
00173 #if FFESTR_VXT
00174     struct
00175       {
00176   char list_state;  /* 0=>no field names allowed, 1=>error
00177            reported already, 2=>field names req'd,
00178            3=>have a field name. */
00179       }
00180     V003;
00181 #endif
00182   };        /* Merge with the one in ffestc later. */
00183 
00184 /* Static objects accessed by functions in this module. */
00185 
00186 static bool ffestc_ok_;   /* _start_ fn's send this to _xyz_ fn's. */
00187 static bool ffestc_parent_ok_;  /* Parent sym for baby sym fn's ok. */
00188 static char ffestc_namelist_; /* 0=>not namelist, 1=>namelist, 2=>error. */
00189 static union ffestc_local_u_ ffestc_local_;
00190 static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_;
00191 static ffestwShriek ffestc_shriek_after1_ = NULL;
00192 static unsigned long ffestc_blocknum_ = 0;  /* Next block# to assign. */
00193 static int ffestc_entry_num_;
00194 static int ffestc_sfdummy_argno_;
00195 static int ffestc_saved_entry_num_;
00196 static ffelab ffestc_label_;
00197 
00198 /* Static functions (internal). */
00199 
00200 static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t);
00201 static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt,
00202           ffebld len, ffelexToken lent);
00203 static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet,
00204           ffebld kind, ffelexToken kindt,
00205           ffebld len, ffelexToken lent);
00206 static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last);
00207 static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt,
00208                 ffetargetCharacterSize val);
00209 static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt,
00210                 ffetargetCharacterSize val);
00211 static void ffestc_labeldef_any_ (void);
00212 static bool ffestc_labeldef_begin_ (void);
00213 static void ffestc_labeldef_branch_begin_ (void);
00214 static void ffestc_labeldef_branch_end_ (void);
00215 static void ffestc_labeldef_endif_ (void);
00216 static void ffestc_labeldef_format_ (void);
00217 static void ffestc_labeldef_invalid_ (void);
00218 static void ffestc_labeldef_notloop_ (void);
00219 static void ffestc_labeldef_notloop_begin_ (void);
00220 static void ffestc_labeldef_useless_ (void);
00221 static bool ffestc_labelref_is_assignable_ (ffelexToken label_token,
00222               ffelab *label);
00223 static bool ffestc_labelref_is_branch_ (ffelexToken label_token,
00224           ffelab *label);
00225 static bool ffestc_labelref_is_format_ (ffelexToken label_token,
00226           ffelab *label);
00227 static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
00228            ffelab *label);
00229 #if FFESTR_F90
00230 static ffestcOrder_ ffestc_order_access_ (void);
00231 #endif
00232 static ffestcOrder_ ffestc_order_actiondo_ (void);
00233 static ffestcOrder_ ffestc_order_actionif_ (void);
00234 static ffestcOrder_ ffestc_order_actionwhere_ (void);
00235 static void ffestc_order_any_ (void);
00236 static void ffestc_order_bad_ (void);
00237 static ffestcOrder_ ffestc_order_blockdata_ (void);
00238 static ffestcOrder_ ffestc_order_blockspec_ (void);
00239 #if FFESTR_F90
00240 static ffestcOrder_ ffestc_order_component_ (void);
00241 #endif
00242 #if FFESTR_F90
00243 static ffestcOrder_ ffestc_order_contains_ (void);
00244 #endif
00245 static ffestcOrder_ ffestc_order_data_ (void);
00246 static ffestcOrder_ ffestc_order_data77_ (void);
00247 #if FFESTR_F90
00248 static ffestcOrder_ ffestc_order_derivedtype_ (void);
00249 #endif
00250 static ffestcOrder_ ffestc_order_do_ (void);
00251 static ffestcOrder_ ffestc_order_entry_ (void);
00252 static ffestcOrder_ ffestc_order_exec_ (void);
00253 static ffestcOrder_ ffestc_order_format_ (void);
00254 static ffestcOrder_ ffestc_order_function_ (void);
00255 static ffestcOrder_ ffestc_order_iface_ (void);
00256 static ffestcOrder_ ffestc_order_ifthen_ (void);
00257 static ffestcOrder_ ffestc_order_implicit_ (void);
00258 static ffestcOrder_ ffestc_order_implicitnone_ (void);
00259 #if FFESTR_F90
00260 static ffestcOrder_ ffestc_order_interface_ (void);
00261 #endif
00262 #if FFESTR_F90
00263 static ffestcOrder_ ffestc_order_map_ (void);
00264 #endif
00265 #if FFESTR_F90
00266 static ffestcOrder_ ffestc_order_module_ (void);
00267 #endif
00268 static ffestcOrder_ ffestc_order_parameter_ (void);
00269 static ffestcOrder_ ffestc_order_program_ (void);
00270 static ffestcOrder_ ffestc_order_progspec_ (void);
00271 #if FFESTR_F90
00272 static ffestcOrder_ ffestc_order_record_ (void);
00273 #endif
00274 static ffestcOrder_ ffestc_order_selectcase_ (void);
00275 static ffestcOrder_ ffestc_order_sfunc_ (void);
00276 #if FFESTR_F90
00277 static ffestcOrder_ ffestc_order_spec_ (void);
00278 #endif
00279 #if FFESTR_VXT
00280 static ffestcOrder_ ffestc_order_structure_ (void);
00281 #endif
00282 static ffestcOrder_ ffestc_order_subroutine_ (void);
00283 #if FFESTR_F90
00284 static ffestcOrder_ ffestc_order_type_ (void);
00285 #endif
00286 static ffestcOrder_ ffestc_order_typedecl_ (void);
00287 #if FFESTR_VXT
00288 static ffestcOrder_ ffestc_order_union_ (void);
00289 #endif
00290 static ffestcOrder_ ffestc_order_unit_ (void);
00291 #if FFESTR_F90
00292 static ffestcOrder_ ffestc_order_use_ (void);
00293 #endif
00294 #if FFESTR_VXT
00295 static ffestcOrder_ ffestc_order_vxtstructure_ (void);
00296 #endif
00297 #if FFESTR_F90
00298 static ffestcOrder_ ffestc_order_where_ (void);
00299 #endif
00300 static void ffestc_promote_dummy_ (ffelexToken t);
00301 static void ffestc_promote_execdummy_ (ffelexToken t);
00302 static void ffestc_promote_sfdummy_ (ffelexToken t);
00303 static void ffestc_shriek_begin_program_ (void);
00304 #if FFESTR_F90
00305 static void ffestc_shriek_begin_uses_ (void);
00306 #endif
00307 static void ffestc_shriek_blockdata_ (bool ok);
00308 static void ffestc_shriek_do_ (bool ok);
00309 static void ffestc_shriek_end_program_ (bool ok);
00310 #if FFESTR_F90
00311 static void ffestc_shriek_end_uses_ (bool ok);
00312 #endif
00313 static void ffestc_shriek_function_ (bool ok);
00314 static void ffestc_shriek_if_ (bool ok);
00315 static void ffestc_shriek_ifthen_ (bool ok);
00316 #if FFESTR_F90
00317 static void ffestc_shriek_interface_ (bool ok);
00318 #endif
00319 #if FFESTR_F90
00320 static void ffestc_shriek_map_ (bool ok);
00321 #endif
00322 #if FFESTR_F90
00323 static void ffestc_shriek_module_ (bool ok);
00324 #endif
00325 static void ffestc_shriek_select_ (bool ok);
00326 #if FFESTR_VXT
00327 static void ffestc_shriek_structure_ (bool ok);
00328 #endif
00329 static void ffestc_shriek_subroutine_ (bool ok);
00330 #if FFESTR_F90
00331 static void ffestc_shriek_type_ (bool ok);
00332 #endif
00333 #if FFESTR_VXT
00334 static void ffestc_shriek_union_ (bool ok);
00335 #endif
00336 #if FFESTR_F90
00337 static void ffestc_shriek_where_ (bool ok);
00338 #endif
00339 #if FFESTR_F90
00340 static void ffestc_shriek_wherethen_ (bool ok);
00341 #endif
00342 static int ffestc_subr_binsrch_ (const char *const *list, int size,
00343          ffestpFile *spec, const char *whine);
00344 static ffestvFormat ffestc_subr_format_ (ffestpFile *spec);
00345 static bool ffestc_subr_is_branch_ (ffestpFile *spec);
00346 static bool ffestc_subr_is_format_ (ffestpFile *spec);
00347 static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec);
00348 static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec,
00349          const char **target, int *length);
00350 static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec);
00351 static void ffestc_try_shriek_do_ (void);
00352 
00353 /* Internal macros. */
00354 
00355 #define ffestc_check_simple_() \
00356       assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_)
00357 #define ffestc_check_start_() \
00358       assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \
00359       ffestc_statelet_ = FFESTC_stateletATTRIB_
00360 #define ffestc_check_attrib_() \
00361       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_)
00362 #define ffestc_check_item_() \
00363       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
00364       || ffestc_statelet_ == FFESTC_stateletITEM_); \
00365       ffestc_statelet_ = FFESTC_stateletITEM_
00366 #define ffestc_check_item_startvals_() \
00367       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
00368       || ffestc_statelet_ == FFESTC_stateletITEM_); \
00369       ffestc_statelet_ = FFESTC_stateletITEMVALS_
00370 #define ffestc_check_item_value_() \
00371       assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_)
00372 #define ffestc_check_item_endvals_() \
00373       assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \
00374       ffestc_statelet_ = FFESTC_stateletITEM_
00375 #define ffestc_check_finish_() \
00376       assert(ffestc_statelet_ == FFESTC_stateletATTRIB_  \
00377       || ffestc_statelet_ == FFESTC_stateletITEM_); \
00378       ffestc_statelet_ = FFESTC_stateletSIMPLE_
00379 #define ffestc_order_action_() ffestc_order_exec_()
00380 #if FFESTR_F90
00381 #define ffestc_order_interfacespec_() ffestc_order_derivedtype_()
00382 #endif
00383 #define ffestc_shriek_if_lost_ ffestc_shriek_if_
00384 #if FFESTR_F90
00385 #define ffestc_shriek_where_lost_ ffestc_shriek_where_
00386 #endif
00387 
00388 /* ffestc_establish_declinfo_ -- Determine specific type/params info for entity
00389 
00390    ffestc_establish_declinfo_(kind,kind_token,len,len_token);
00391 
00392    Must be called after _declstmt_ called to establish base type.  */
00393 
00394 static void
00395 ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len,
00396           ffelexToken lent)
00397 {
00398   ffeinfoBasictype bt = ffestc_local_.decl.basic_type;
00399   ffeinfoKindtype kt;
00400   ffetargetCharacterSize val;
00401 
00402   if (kindt == NULL)
00403     kt = ffestc_local_.decl.stmt_kind_type;
00404   else if (!ffestc_local_.decl.per_var_kind_ok)
00405     {
00406       ffebad_start (FFEBAD_KINDTYPE);
00407       ffebad_here (0, ffelex_token_where_line (kindt),
00408        ffelex_token_where_column (kindt));
00409       ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
00410        ffelex_token_where_column (ffesta_tokens[0]));
00411       ffebad_finish ();
00412       kt = ffestc_local_.decl.stmt_kind_type;
00413     }
00414   else
00415     {
00416       if (kind == NULL)
00417   {
00418     assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
00419     val = atol (ffelex_token_text (kindt));
00420     kt = ffestc_kindtype_star_ (bt, val);
00421   }
00422       else if (ffebld_op (kind) == FFEBLD_opANY)
00423   kt = ffestc_local_.decl.stmt_kind_type;
00424       else
00425   {
00426     assert (ffebld_op (kind) == FFEBLD_opCONTER);
00427     assert (ffeinfo_basictype (ffebld_info (kind))
00428       == FFEINFO_basictypeINTEGER);
00429     assert (ffeinfo_kindtype (ffebld_info (kind))
00430       == FFEINFO_kindtypeINTEGERDEFAULT);
00431     val = ffebld_constant_integerdefault (ffebld_conter (kind));
00432     kt = ffestc_kindtype_kind_ (bt, val);
00433   }
00434 
00435       if (kt == FFEINFO_kindtypeNONE)
00436   {     /* Not valid kind type. */
00437     ffebad_start (FFEBAD_KINDTYPE);
00438     ffebad_here (0, ffelex_token_where_line (kindt),
00439            ffelex_token_where_column (kindt));
00440     ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
00441            ffelex_token_where_column (ffesta_tokens[0]));
00442     ffebad_finish ();
00443     kt = ffestc_local_.decl.stmt_kind_type;
00444   }
00445     }
00446 
00447   ffestc_local_.decl.kind_type = kt;
00448 
00449   /* Now check length specification for CHARACTER data type. */
00450 
00451   if (((len == NULL) && (lent == NULL))
00452       || (bt != FFEINFO_basictypeCHARACTER))
00453     val = ffestc_local_.decl.stmt_size;
00454   else
00455     {
00456       if (len == NULL)
00457   {
00458     assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
00459     val = atol (ffelex_token_text (lent));
00460   }
00461       else if (ffebld_op (len) == FFEBLD_opSTAR)
00462   val = FFETARGET_charactersizeNONE;
00463       else if (ffebld_op (len) == FFEBLD_opANY)
00464   val = FFETARGET_charactersizeNONE;
00465       else
00466   {
00467     assert (ffebld_op (len) == FFEBLD_opCONTER);
00468     assert (ffeinfo_basictype (ffebld_info (len))
00469       == FFEINFO_basictypeINTEGER);
00470     assert (ffeinfo_kindtype (ffebld_info (len))
00471       == FFEINFO_kindtypeINTEGERDEFAULT);
00472     val = ffebld_constant_integerdefault (ffebld_conter (len));
00473   }
00474     }
00475 
00476   if ((val == 0) && !(0 && ffe_is_90 ()))
00477     {
00478       val = 1;
00479       ffebad_start (FFEBAD_ZERO_SIZE);
00480       ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
00481       ffebad_finish ();
00482     }
00483   ffestc_local_.decl.size = val;
00484 }
00485 
00486 /* ffestc_establish_declstmt_ -- Establish host-specific type/params info
00487 
00488    ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
00489    len_token);  */
00490 
00491 static void
00492 ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
00493           ffelexToken kindt, ffebld len, ffelexToken lent)
00494 {
00495   ffeinfoBasictype bt;
00496   ffeinfoKindtype ktd;    /* Default kindtype. */
00497   ffeinfoKindtype kt;
00498   ffetargetCharacterSize val;
00499   bool per_var_kind_ok = TRUE;
00500 
00501   /* Determine basictype and default kindtype. */
00502 
00503   switch (type)
00504     {
00505     case FFESTP_typeINTEGER:
00506       bt = FFEINFO_basictypeINTEGER;
00507       ktd = FFEINFO_kindtypeINTEGERDEFAULT;
00508       break;
00509 
00510     case FFESTP_typeBYTE:
00511       bt = FFEINFO_basictypeINTEGER;
00512       ktd = FFEINFO_kindtypeINTEGER2;
00513       break;
00514 
00515     case FFESTP_typeWORD:
00516       bt = FFEINFO_basictypeINTEGER;
00517       ktd = FFEINFO_kindtypeINTEGER3;
00518       break;
00519 
00520     case FFESTP_typeREAL:
00521       bt = FFEINFO_basictypeREAL;
00522       ktd = FFEINFO_kindtypeREALDEFAULT;
00523       break;
00524 
00525     case FFESTP_typeCOMPLEX:
00526       bt = FFEINFO_basictypeCOMPLEX;
00527       ktd = FFEINFO_kindtypeREALDEFAULT;
00528       break;
00529 
00530     case FFESTP_typeLOGICAL:
00531       bt = FFEINFO_basictypeLOGICAL;
00532       ktd = FFEINFO_kindtypeLOGICALDEFAULT;
00533       break;
00534 
00535     case FFESTP_typeCHARACTER:
00536       bt = FFEINFO_basictypeCHARACTER;
00537       ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
00538       break;
00539 
00540     case FFESTP_typeDBLPRCSN:
00541       bt = FFEINFO_basictypeREAL;
00542       ktd = FFEINFO_kindtypeREALDOUBLE;
00543       per_var_kind_ok = FALSE;
00544       break;
00545 
00546     case FFESTP_typeDBLCMPLX:
00547       bt = FFEINFO_basictypeCOMPLEX;
00548 #if FFETARGET_okCOMPLEX2
00549       ktd = FFEINFO_kindtypeREALDOUBLE;
00550 #else
00551       ktd = FFEINFO_kindtypeREALDEFAULT;
00552       ffebad_start (FFEBAD_BAD_DBLCMPLX);
00553       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
00554        ffelex_token_where_column (ffesta_tokens[0]));
00555       ffebad_finish ();
00556 #endif
00557       per_var_kind_ok = FALSE;
00558       break;
00559 
00560     default:
00561       assert ("Unexpected type (F90 TYPE?)!" == NULL);
00562       bt = FFEINFO_basictypeNONE;
00563       ktd = FFEINFO_kindtypeNONE;
00564       break;
00565     }
00566 
00567   if (kindt == NULL)
00568     kt = ktd;
00569   else
00570     {       /* Not necessarily default kind type. */
00571       if (kind == NULL)
00572   {     /* Shouldn't happen for CHARACTER. */
00573     assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
00574     val = atol (ffelex_token_text (kindt));
00575     kt = ffestc_kindtype_star_ (bt, val);
00576   }
00577       else if (ffebld_op (kind) == FFEBLD_opANY)
00578   kt = ktd;
00579       else
00580   {
00581     assert (ffebld_op (kind) == FFEBLD_opCONTER);
00582     assert (ffeinfo_basictype (ffebld_info (kind))
00583       == FFEINFO_basictypeINTEGER);
00584     assert (ffeinfo_kindtype (ffebld_info (kind))
00585       == FFEINFO_kindtypeINTEGERDEFAULT);
00586     val = ffebld_constant_integerdefault (ffebld_conter (kind));
00587     kt = ffestc_kindtype_kind_ (bt, val);
00588   }
00589 
00590       if (kt == FFEINFO_kindtypeNONE)
00591   {     /* Not valid kind type. */
00592     ffebad_start (FFEBAD_KINDTYPE);
00593     ffebad_here (0, ffelex_token_where_line (kindt),
00594            ffelex_token_where_column (kindt));
00595     ffebad_here (1, ffelex_token_where_line (typet),
00596            ffelex_token_where_column (typet));
00597     ffebad_finish ();
00598     kt = ktd;
00599   }
00600     }
00601 
00602   ffestc_local_.decl.basic_type = bt;
00603   ffestc_local_.decl.stmt_kind_type = kt;
00604   ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok;
00605 
00606   /* Now check length specification for CHARACTER data type. */
00607 
00608   if (((len == NULL) && (lent == NULL))
00609       || (type != FFESTP_typeCHARACTER))
00610     val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
00611   else
00612     {
00613       if (len == NULL)
00614   {
00615     assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
00616     val = atol (ffelex_token_text (lent));
00617   }
00618       else if (ffebld_op (len) == FFEBLD_opSTAR)
00619   val = FFETARGET_charactersizeNONE;
00620       else if (ffebld_op (len) == FFEBLD_opANY)
00621   val = FFETARGET_charactersizeNONE;
00622       else
00623   {
00624     assert (ffebld_op (len) == FFEBLD_opCONTER);
00625     assert (ffeinfo_basictype (ffebld_info (len))
00626       == FFEINFO_basictypeINTEGER);
00627     assert (ffeinfo_kindtype (ffebld_info (len))
00628       == FFEINFO_kindtypeINTEGERDEFAULT);
00629     val = ffebld_constant_integerdefault (ffebld_conter (len));
00630   }
00631     }
00632 
00633   if ((val == 0) && !(0 && ffe_is_90 ()))
00634     {
00635       val = 1;
00636       ffebad_start (FFEBAD_ZERO_SIZE);
00637       ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
00638       ffebad_finish ();
00639     }
00640   ffestc_local_.decl.stmt_size = val;
00641 }
00642 
00643 /* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)
00644 
00645    ffestc_establish_impletter_(first_letter_token,last_letter_token);  */
00646 
00647 static void
00648 ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
00649 {
00650   bool ok = FALSE;    /* Stays FALSE if first letter > last. */
00651   char c;
00652 
00653   if (last == NULL)
00654     ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)),
00655               ffestc_local_.decl.basic_type,
00656               ffestc_local_.decl.kind_type,
00657               ffestc_local_.decl.size);
00658   else
00659     {
00660       for (c = *(ffelex_token_text (first));
00661      c <= *(ffelex_token_text (last));
00662      c++)
00663   {
00664     ok = ffeimplic_establish_initial (c,
00665               ffestc_local_.decl.basic_type,
00666               ffestc_local_.decl.kind_type,
00667               ffestc_local_.decl.size);
00668     if (!ok)
00669       break;
00670   }
00671     }
00672 
00673   if (!ok)
00674     {
00675       char cs[2];
00676 
00677       cs[0] = c;
00678       cs[1] = '\0';
00679 
00680       ffebad_start (FFEBAD_BAD_IMPLICIT);
00681       ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
00682       ffebad_string (cs);
00683       ffebad_finish ();
00684     }
00685 }
00686 
00687 /* ffestc_init_3 -- Initialize ffestc for new program unit
00688 
00689    ffestc_init_3();  */
00690 
00691 void
00692 ffestc_init_3 ()
00693 {
00694   ffestv_save_state_ = FFESTV_savestateNONE;
00695   ffestc_entry_num_ = 0;
00696   ffestv_num_label_defines_ = 0;
00697 }
00698 
00699 /* ffestc_init_4 -- Initialize ffestc for new scoping unit
00700 
00701    ffestc_init_4();
00702 
00703    For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
00704    defs, and statement function defs.  */
00705 
00706 void
00707 ffestc_init_4 ()
00708 {
00709   ffestc_saved_entry_num_ = ffestc_entry_num_;
00710   ffestc_entry_num_ = 0;
00711 }
00712 
00713 /* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value
00714 
00715    ffeinfoKindtype kt;
00716    ffeinfoBasictype bt;
00717    ffetargetCharacterSize val;
00718    kt = ffestc_kindtype_kind_(bt,val);
00719    if (kt == FFEINFO_kindtypeNONE)
00720        // unsupported/invalid KIND= value for type  */
00721 
00722 static ffeinfoKindtype
00723 ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
00724 {
00725   ffetype type;
00726   ffetype base_type;
00727   ffeinfoKindtype kt;
00728 
00729   base_type = ffeinfo_type (bt, 1); /* ~~ */
00730   assert (base_type != NULL);
00731 
00732   type = ffetype_lookup_kind (base_type, (int) val);
00733   if (type == NULL)
00734     return FFEINFO_kindtypeNONE;
00735 
00736   for (kt = 1; kt < FFEINFO_kindtype; ++kt)
00737     if (ffeinfo_type (bt, kt) == type)
00738       return kt;
00739 
00740   return FFEINFO_kindtypeNONE;
00741 }
00742 
00743 /* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value
00744 
00745    ffeinfoKindtype kt;
00746    ffeinfoBasictype bt;
00747    ffetargetCharacterSize val;
00748    kt = ffestc_kindtype_star_(bt,val);
00749    if (kt == FFEINFO_kindtypeNONE)
00750        // unsupported/invalid * value for type  */
00751 
00752 static ffeinfoKindtype
00753 ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
00754 {
00755   ffetype type;
00756   ffetype base_type;
00757   ffeinfoKindtype kt;
00758 
00759   base_type = ffeinfo_type (bt, 1); /* ~~ */
00760   assert (base_type != NULL);
00761 
00762   type = ffetype_lookup_star (base_type, (int) val);
00763   if (type == NULL)
00764     return FFEINFO_kindtypeNONE;
00765 
00766   for (kt = 1; kt < FFEINFO_kindtype; ++kt)
00767     if (ffeinfo_type (bt, kt) == type)
00768       return kt;
00769 
00770   return FFEINFO_kindtypeNONE;
00771 }
00772 
00773 /* Define label as usable for anything without complaint.  */
00774 
00775 static void
00776 ffestc_labeldef_any_ ()
00777 {
00778   if ((ffesta_label_token == NULL)
00779       || !ffestc_labeldef_begin_ ())
00780     return;
00781 
00782   ffelab_set_type (ffestc_label_, FFELAB_typeANY);
00783   ffestd_labeldef_any (ffestc_label_);
00784 
00785   ffestc_labeldef_branch_end_ ();
00786 }
00787 
00788 /* ffestc_labeldef_begin_ -- Define label as unknown, initially
00789 
00790    ffestc_labeldef_begin_();  */
00791 
00792 static bool
00793 ffestc_labeldef_begin_ ()
00794 {
00795   ffelabValue label_value;
00796   ffelab label;
00797 
00798   label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
00799   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
00800     {
00801       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
00802       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
00803        ffelex_token_where_column (ffesta_label_token));
00804       ffebad_finish ();
00805     }
00806 
00807   label = ffelab_find (label_value);
00808   if (label == NULL)
00809     {
00810       label = ffestc_label_ = ffelab_new (label_value);
00811       ffestv_num_label_defines_++;
00812       ffelab_set_definition_line (label,
00813     ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
00814       ffelab_set_definition_column (label,
00815       ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
00816 
00817       return TRUE;
00818     }
00819 
00820   if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
00821     {
00822       ffestv_num_label_defines_++;
00823       ffestc_label_ = label;
00824       ffelab_set_definition_line (label,
00825     ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
00826       ffelab_set_definition_column (label,
00827       ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
00828 
00829       return TRUE;
00830     }
00831 
00832   ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED);
00833   ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
00834          ffelex_token_where_column (ffesta_label_token));
00835   ffebad_here (1, ffelab_definition_line (label),
00836          ffelab_definition_column (label));
00837   ffebad_string (ffelex_token_text (ffesta_label_token));
00838   ffebad_finish ();
00839 
00840   ffelex_token_kill (ffesta_label_token);
00841   ffesta_label_token = NULL;
00842   return FALSE;
00843 }
00844 
00845 /* ffestc_labeldef_branch_begin_ -- Define label as a branch target one
00846 
00847    ffestc_labeldef_branch_begin_();  */
00848 
00849 static void
00850 ffestc_labeldef_branch_begin_ ()
00851 {
00852   if ((ffesta_label_token == NULL)
00853       || (ffestc_shriek_after1_ != NULL)
00854       || !ffestc_labeldef_begin_ ())
00855     return;
00856 
00857   switch (ffelab_type (ffestc_label_))
00858     {
00859     case FFELAB_typeUNKNOWN:
00860     case FFELAB_typeASSIGNABLE:
00861       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
00862       ffelab_set_blocknum (ffestc_label_,
00863          ffestw_blocknum (ffestw_stack_top ()));
00864       ffestd_labeldef_branch (ffestc_label_);
00865       break;
00866 
00867     case FFELAB_typeNOTLOOP:
00868       if (ffelab_blocknum (ffestc_label_)
00869     < ffestw_blocknum (ffestw_stack_top ()))
00870   {
00871     ffebad_start (FFEBAD_LABEL_BLOCK);
00872     ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
00873            ffelex_token_where_column (ffesta_label_token));
00874     ffebad_here (1, ffelab_firstref_line (ffestc_label_),
00875            ffelab_firstref_column (ffestc_label_));
00876     ffebad_finish ();
00877   }
00878       ffelab_set_blocknum (ffestc_label_,
00879          ffestw_blocknum (ffestw_stack_top ()));
00880       ffestd_labeldef_branch (ffestc_label_);
00881       break;
00882 
00883     case FFELAB_typeLOOPEND:
00884       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
00885     || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
00886   {     /* Unterminated block. */
00887     ffelab_set_type (ffestc_label_, FFELAB_typeANY);
00888     ffestd_labeldef_any (ffestc_label_);
00889 
00890     ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
00891     ffebad_here (0, ffelab_doref_line (ffestc_label_),
00892            ffelab_doref_column (ffestc_label_));
00893     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
00894     ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
00895            ffelex_token_where_column (ffesta_label_token));
00896     ffebad_finish ();
00897     break;
00898   }
00899       ffestd_labeldef_branch (ffestc_label_);
00900       /* Leave something around for _branch_end_() to handle. */
00901       return;
00902 
00903     case FFELAB_typeFORMAT:
00904       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
00905       ffestd_labeldef_any (ffestc_label_);
00906 
00907       ffebad_start (FFEBAD_LABEL_USE_DEF);
00908       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
00909        ffelex_token_where_column (ffesta_label_token));
00910       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
00911        ffelab_firstref_column (ffestc_label_));
00912       ffebad_finish ();
00913       break;
00914 
00915     default:
00916       assert ("bad label" == NULL);
00917       /* Fall through.  */
00918     case FFELAB_typeANY:
00919       break;
00920     }
00921 
00922   ffestc_try_shriek_do_ ();
00923 
00924   ffelex_token_kill (ffesta_label_token);
00925   ffesta_label_token = NULL;
00926 }
00927 
00928 /* Define possible end of labeled-DO-loop.  Call only after calling
00929    ffestc_labeldef_branch_begin_, or when other branch_* functions
00930    recognize that a label might also be serving as a branch end (in
00931    which case they must issue a diagnostic).  */
00932 
00933 static void
00934 ffestc_labeldef_branch_end_ ()
00935 {
00936   if (ffesta_label_token == NULL)
00937     return;
00938 
00939   assert (ffestc_label_ != NULL);
00940   assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND)
00941     || (ffelab_type (ffestc_label_) == FFELAB_typeANY));
00942 
00943   while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
00944    && (ffestw_label (ffestw_stack_top ()) == ffestc_label_))
00945     ffestc_shriek_do_ (TRUE);
00946 
00947   ffestc_try_shriek_do_ ();
00948 
00949   ffelex_token_kill (ffesta_label_token);
00950   ffesta_label_token = NULL;
00951 }
00952 
00953 /* ffestc_labeldef_endif_ -- Define label as an END IF one
00954 
00955    ffestc_labeldef_endif_();  */
00956 
00957 static void
00958 ffestc_labeldef_endif_ ()
00959 {
00960   if ((ffesta_label_token == NULL)
00961       || (ffestc_shriek_after1_ != NULL)
00962       || !ffestc_labeldef_begin_ ())
00963     return;
00964 
00965   switch (ffelab_type (ffestc_label_))
00966     {
00967     case FFELAB_typeUNKNOWN:
00968     case FFELAB_typeASSIGNABLE:
00969       ffelab_set_type (ffestc_label_, FFELAB_typeENDIF);
00970       ffelab_set_blocknum (ffestc_label_,
00971        ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
00972       ffestd_labeldef_endif (ffestc_label_);
00973       break;
00974 
00975     case FFELAB_typeNOTLOOP:
00976       if (ffelab_blocknum (ffestc_label_)
00977     < ffestw_blocknum (ffestw_previous (ffestw_stack_top ())))
00978   {
00979     ffebad_start (FFEBAD_LABEL_BLOCK);
00980     ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
00981            ffelex_token_where_column (ffesta_label_token));
00982     ffebad_here (1, ffelab_firstref_line (ffestc_label_),
00983            ffelab_firstref_column (ffestc_label_));
00984     ffebad_finish ();
00985   }
00986       ffelab_set_blocknum (ffestc_label_,
00987        ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
00988       ffestd_labeldef_endif (ffestc_label_);
00989       break;
00990 
00991     case FFELAB_typeLOOPEND:
00992       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
00993     || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
00994   {     /* Unterminated block. */
00995     ffelab_set_type (ffestc_label_, FFELAB_typeANY);
00996     ffestd_labeldef_any (ffestc_label_);
00997 
00998     ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
00999     ffebad_here (0, ffelab_doref_line (ffestc_label_),
01000            ffelab_doref_column (ffestc_label_));
01001     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
01002     ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
01003            ffelex_token_where_column (ffesta_label_token));
01004     ffebad_finish ();
01005     break;
01006   }
01007       ffestd_labeldef_endif (ffestc_label_);
01008       ffebad_start (FFEBAD_LABEL_USE_DEF);
01009       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01010        ffelex_token_where_column (ffesta_label_token));
01011       ffebad_here (1, ffelab_doref_line (ffestc_label_),
01012        ffelab_doref_column (ffestc_label_));
01013       ffebad_finish ();
01014       ffestc_labeldef_branch_end_ ();
01015       return;
01016 
01017     case FFELAB_typeFORMAT:
01018       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01019       ffestd_labeldef_any (ffestc_label_);
01020 
01021       ffebad_start (FFEBAD_LABEL_USE_DEF);
01022       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01023        ffelex_token_where_column (ffesta_label_token));
01024       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
01025        ffelab_firstref_column (ffestc_label_));
01026       ffebad_finish ();
01027       break;
01028 
01029     default:
01030       assert ("bad label" == NULL);
01031       /* Fall through.  */
01032     case FFELAB_typeANY:
01033       break;
01034     }
01035 
01036   ffestc_try_shriek_do_ ();
01037 
01038   ffelex_token_kill (ffesta_label_token);
01039   ffesta_label_token = NULL;
01040 }
01041 
01042 /* ffestc_labeldef_format_ -- Define label as a FORMAT one
01043 
01044    ffestc_labeldef_format_();  */
01045 
01046 static void
01047 ffestc_labeldef_format_ ()
01048 {
01049   if ((ffesta_label_token == NULL)
01050       || (ffestc_shriek_after1_ != NULL))
01051     {
01052       ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF);
01053       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
01054        ffelex_token_where_column (ffesta_tokens[0]));
01055       ffebad_finish ();
01056       return;
01057     }
01058 
01059   if (!ffestc_labeldef_begin_ ())
01060     return;
01061 
01062   switch (ffelab_type (ffestc_label_))
01063     {
01064     case FFELAB_typeUNKNOWN:
01065     case FFELAB_typeASSIGNABLE:
01066       ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT);
01067       ffestd_labeldef_format (ffestc_label_);
01068       break;
01069 
01070     case FFELAB_typeFORMAT:
01071       ffestd_labeldef_format (ffestc_label_);
01072       break;
01073 
01074     case FFELAB_typeLOOPEND:
01075       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
01076     || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
01077   {     /* Unterminated block. */
01078     ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01079     ffestd_labeldef_any (ffestc_label_);
01080 
01081     ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
01082     ffebad_here (0, ffelab_doref_line (ffestc_label_),
01083            ffelab_doref_column (ffestc_label_));
01084     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
01085     ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
01086            ffelex_token_where_column (ffesta_label_token));
01087     ffebad_finish ();
01088     break;
01089   }
01090       ffestd_labeldef_format (ffestc_label_);
01091       ffebad_start (FFEBAD_LABEL_USE_DEF);
01092       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01093        ffelex_token_where_column (ffesta_label_token));
01094       ffebad_here (1, ffelab_doref_line (ffestc_label_),
01095        ffelab_doref_column (ffestc_label_));
01096       ffebad_finish ();
01097       ffestc_labeldef_branch_end_ ();
01098       return;
01099 
01100     case FFELAB_typeNOTLOOP:
01101       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01102       ffestd_labeldef_any (ffestc_label_);
01103 
01104       ffebad_start (FFEBAD_LABEL_USE_DEF);
01105       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01106        ffelex_token_where_column (ffesta_label_token));
01107       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
01108        ffelab_firstref_column (ffestc_label_));
01109       ffebad_finish ();
01110       break;
01111 
01112     default:
01113       assert ("bad label" == NULL);
01114       /* Fall through.  */
01115     case FFELAB_typeANY:
01116       break;
01117     }
01118 
01119   ffestc_try_shriek_do_ ();
01120 
01121   ffelex_token_kill (ffesta_label_token);
01122   ffesta_label_token = NULL;
01123 }
01124 
01125 /* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present
01126 
01127    ffestc_labeldef_invalid_();  */
01128 
01129 static void
01130 ffestc_labeldef_invalid_ ()
01131 {
01132   if ((ffesta_label_token == NULL)
01133       || (ffestc_shriek_after1_ != NULL)
01134       || !ffestc_labeldef_begin_ ())
01135     return;
01136 
01137   ffebad_start (FFEBAD_INVALID_LABEL_DEF);
01138   ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01139          ffelex_token_where_column (ffesta_label_token));
01140   ffebad_finish ();
01141 
01142   ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01143   ffestd_labeldef_any (ffestc_label_);
01144 
01145   ffestc_try_shriek_do_ ();
01146 
01147   ffelex_token_kill (ffesta_label_token);
01148   ffesta_label_token = NULL;
01149 }
01150 
01151 /* Define label as a non-loop-ending one on a statement that can't
01152    be in the "then" part of a logical IF, such as a block-IF statement.  */
01153 
01154 static void
01155 ffestc_labeldef_notloop_ ()
01156 {
01157   if (ffesta_label_token == NULL)
01158     return;
01159 
01160   assert (ffestc_shriek_after1_ == NULL);
01161 
01162   if (!ffestc_labeldef_begin_ ())
01163     return;
01164 
01165   switch (ffelab_type (ffestc_label_))
01166     {
01167     case FFELAB_typeUNKNOWN:
01168     case FFELAB_typeASSIGNABLE:
01169       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
01170       ffelab_set_blocknum (ffestc_label_,
01171          ffestw_blocknum (ffestw_stack_top ()));
01172       ffestd_labeldef_notloop (ffestc_label_);
01173       break;
01174 
01175     case FFELAB_typeNOTLOOP:
01176       if (ffelab_blocknum (ffestc_label_)
01177     < ffestw_blocknum (ffestw_stack_top ()))
01178   {
01179     ffebad_start (FFEBAD_LABEL_BLOCK);
01180     ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01181            ffelex_token_where_column (ffesta_label_token));
01182     ffebad_here (1, ffelab_firstref_line (ffestc_label_),
01183            ffelab_firstref_column (ffestc_label_));
01184     ffebad_finish ();
01185   }
01186       ffelab_set_blocknum (ffestc_label_,
01187          ffestw_blocknum (ffestw_stack_top ()));
01188       ffestd_labeldef_notloop (ffestc_label_);
01189       break;
01190 
01191     case FFELAB_typeLOOPEND:
01192       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
01193     || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
01194   {     /* Unterminated block. */
01195     ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01196     ffestd_labeldef_any (ffestc_label_);
01197 
01198     ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
01199     ffebad_here (0, ffelab_doref_line (ffestc_label_),
01200            ffelab_doref_column (ffestc_label_));
01201     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
01202     ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
01203            ffelex_token_where_column (ffesta_label_token));
01204     ffebad_finish ();
01205     break;
01206   }
01207       ffestd_labeldef_notloop (ffestc_label_);
01208       ffebad_start (FFEBAD_LABEL_USE_DEF);
01209       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01210        ffelex_token_where_column (ffesta_label_token));
01211       ffebad_here (1, ffelab_doref_line (ffestc_label_),
01212        ffelab_doref_column (ffestc_label_));
01213       ffebad_finish ();
01214       ffestc_labeldef_branch_end_ ();
01215       return;
01216 
01217     case FFELAB_typeFORMAT:
01218       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01219       ffestd_labeldef_any (ffestc_label_);
01220 
01221       ffebad_start (FFEBAD_LABEL_USE_DEF);
01222       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01223        ffelex_token_where_column (ffesta_label_token));
01224       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
01225        ffelab_firstref_column (ffestc_label_));
01226       ffebad_finish ();
01227       break;
01228 
01229     default:
01230       assert ("bad label" == NULL);
01231       /* Fall through.  */
01232     case FFELAB_typeANY:
01233       break;
01234     }
01235 
01236   ffestc_try_shriek_do_ ();
01237 
01238   ffelex_token_kill (ffesta_label_token);
01239   ffesta_label_token = NULL;
01240 }
01241 
01242 /* Define label as a non-loop-ending one.  Use this when it is
01243    possible that the pending label is inhibited because we're in
01244    the midst of a logical-IF, and thus _branch_end_ is going to
01245    be called after the current statement to resolve a potential
01246    loop-ending label.  */
01247 
01248 static void
01249 ffestc_labeldef_notloop_begin_ ()
01250 {
01251   if ((ffesta_label_token == NULL)
01252       || (ffestc_shriek_after1_ != NULL)
01253       || !ffestc_labeldef_begin_ ())
01254     return;
01255 
01256   switch (ffelab_type (ffestc_label_))
01257     {
01258     case FFELAB_typeUNKNOWN:
01259     case FFELAB_typeASSIGNABLE:
01260       ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
01261       ffelab_set_blocknum (ffestc_label_,
01262          ffestw_blocknum (ffestw_stack_top ()));
01263       ffestd_labeldef_notloop (ffestc_label_);
01264       break;
01265 
01266     case FFELAB_typeNOTLOOP:
01267       if (ffelab_blocknum (ffestc_label_)
01268     < ffestw_blocknum (ffestw_stack_top ()))
01269   {
01270     ffebad_start (FFEBAD_LABEL_BLOCK);
01271     ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01272            ffelex_token_where_column (ffesta_label_token));
01273     ffebad_here (1, ffelab_firstref_line (ffestc_label_),
01274            ffelab_firstref_column (ffestc_label_));
01275     ffebad_finish ();
01276   }
01277       ffelab_set_blocknum (ffestc_label_,
01278          ffestw_blocknum (ffestw_stack_top ()));
01279       ffestd_labeldef_notloop (ffestc_label_);
01280       break;
01281 
01282     case FFELAB_typeLOOPEND:
01283       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
01284     || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
01285   {     /* Unterminated block. */
01286     ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01287     ffestd_labeldef_any (ffestc_label_);
01288 
01289     ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
01290     ffebad_here (0, ffelab_doref_line (ffestc_label_),
01291            ffelab_doref_column (ffestc_label_));
01292     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
01293     ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
01294            ffelex_token_where_column (ffesta_label_token));
01295     ffebad_finish ();
01296     break;
01297   }
01298       ffestd_labeldef_branch (ffestc_label_);
01299       ffebad_start (FFEBAD_LABEL_USE_DEF);
01300       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01301        ffelex_token_where_column (ffesta_label_token));
01302       ffebad_here (1, ffelab_doref_line (ffestc_label_),
01303        ffelab_doref_column (ffestc_label_));
01304       ffebad_finish ();
01305       return;
01306 
01307     case FFELAB_typeFORMAT:
01308       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01309       ffestd_labeldef_any (ffestc_label_);
01310 
01311       ffebad_start (FFEBAD_LABEL_USE_DEF);
01312       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01313        ffelex_token_where_column (ffesta_label_token));
01314       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
01315        ffelab_firstref_column (ffestc_label_));
01316       ffebad_finish ();
01317       break;
01318 
01319     default:
01320       assert ("bad label" == NULL);
01321       /* Fall through.  */
01322     case FFELAB_typeANY:
01323       break;
01324     }
01325 
01326   ffestc_try_shriek_do_ ();
01327 
01328   ffelex_token_kill (ffesta_label_token);
01329   ffesta_label_token = NULL;
01330 }
01331 
01332 /* ffestc_labeldef_useless_ -- Define label as a useless one
01333 
01334    ffestc_labeldef_useless_();  */
01335 
01336 static void
01337 ffestc_labeldef_useless_ ()
01338 {
01339   if ((ffesta_label_token == NULL)
01340       || (ffestc_shriek_after1_ != NULL)
01341       || !ffestc_labeldef_begin_ ())
01342     return;
01343 
01344   switch (ffelab_type (ffestc_label_))
01345     {
01346     case FFELAB_typeUNKNOWN:
01347       ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS);
01348       ffestd_labeldef_useless (ffestc_label_);
01349       break;
01350 
01351     case FFELAB_typeLOOPEND:
01352       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01353       ffestd_labeldef_any (ffestc_label_);
01354 
01355       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
01356     || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
01357   {     /* Unterminated block. */
01358     ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
01359     ffebad_here (0, ffelab_doref_line (ffestc_label_),
01360            ffelab_doref_column (ffestc_label_));
01361     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
01362     ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
01363            ffelex_token_where_column (ffesta_label_token));
01364     ffebad_finish ();
01365     break;
01366   }
01367       ffebad_start (FFEBAD_LABEL_USE_DEF);
01368       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01369        ffelex_token_where_column (ffesta_label_token));
01370       ffebad_here (1, ffelab_doref_line (ffestc_label_),
01371        ffelab_doref_column (ffestc_label_));
01372       ffebad_finish ();
01373       ffestc_labeldef_branch_end_ ();
01374       return;
01375 
01376     case FFELAB_typeASSIGNABLE:
01377     case FFELAB_typeFORMAT:
01378     case FFELAB_typeNOTLOOP:
01379       ffelab_set_type (ffestc_label_, FFELAB_typeANY);
01380       ffestd_labeldef_any (ffestc_label_);
01381 
01382       ffebad_start (FFEBAD_LABEL_USE_DEF);
01383       ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
01384        ffelex_token_where_column (ffesta_label_token));
01385       ffebad_here (1, ffelab_firstref_line (ffestc_label_),
01386        ffelab_firstref_column (ffestc_label_));
01387       ffebad_finish ();
01388       break;
01389 
01390     default:
01391       assert ("bad label" == NULL);
01392       /* Fall through.  */
01393     case FFELAB_typeANY:
01394       break;
01395     }
01396 
01397   ffestc_try_shriek_do_ ();
01398 
01399   ffelex_token_kill (ffesta_label_token);
01400   ffesta_label_token = NULL;
01401 }
01402 
01403 /* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt
01404 
01405    if (ffestc_labelref_is_assignable_(label_token,&label))
01406        // label ref is ok, label is filled in with ffelab object  */
01407 
01408 static bool
01409 ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label)
01410 {
01411   ffelab label;
01412   ffelabValue label_value;
01413 
01414   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
01415   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
01416     {
01417       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
01418       ffebad_here (0, ffelex_token_where_line (label_token),
01419        ffelex_token_where_column (label_token));
01420       ffebad_finish ();
01421       return FALSE;
01422     }
01423 
01424   label = ffelab_find (label_value);
01425   if (label == NULL)
01426     {
01427       label = ffelab_new (label_value);
01428       ffelab_set_firstref_line (label,
01429      ffewhere_line_use (ffelex_token_where_line (label_token)));
01430       ffelab_set_firstref_column (label,
01431        ffewhere_column_use (ffelex_token_where_column (label_token)));
01432     }
01433 
01434   switch (ffelab_type (label))
01435     {
01436     case FFELAB_typeUNKNOWN:
01437       ffelab_set_type (label, FFELAB_typeASSIGNABLE);
01438       break;
01439 
01440     case FFELAB_typeASSIGNABLE:
01441     case FFELAB_typeLOOPEND:
01442     case FFELAB_typeFORMAT:
01443     case FFELAB_typeNOTLOOP:
01444     case FFELAB_typeENDIF:
01445       break;
01446 
01447     case FFELAB_typeUSELESS:
01448       ffelab_set_type (label, FFELAB_typeANY);
01449       ffestd_labeldef_any (label);
01450 
01451       ffebad_start (FFEBAD_LABEL_USE_DEF);
01452       ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
01453       ffebad_here (1, ffelex_token_where_line (label_token),
01454        ffelex_token_where_column (label_token));
01455       ffebad_finish ();
01456 
01457       ffestc_try_shriek_do_ ();
01458 
01459       return FALSE;
01460 
01461     default:
01462       assert ("bad label" == NULL);
01463       /* Fall through.  */
01464     case FFELAB_typeANY:
01465       break;
01466     }
01467 
01468   *x_label = label;
01469   return TRUE;
01470 }
01471 
01472 /* ffestc_labelref_is_branch_ -- Reference to label in branch stmt
01473 
01474    if (ffestc_labelref_is_branch_(label_token,&label))
01475        // label ref is ok, label is filled in with ffelab object  */
01476 
01477 static bool
01478 ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label)
01479 {
01480   ffelab label;
01481   ffelabValue label_value;
01482   ffestw block;
01483   unsigned long blocknum;
01484 
01485   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
01486   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
01487     {
01488       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
01489       ffebad_here (0, ffelex_token_where_line (label_token),
01490        ffelex_token_where_column (label_token));
01491       ffebad_finish ();
01492       return FALSE;
01493     }
01494 
01495   label = ffelab_find (label_value);
01496   if (label == NULL)
01497     {
01498       label = ffelab_new (label_value);
01499       ffelab_set_firstref_line (label,
01500      ffewhere_line_use (ffelex_token_where_line (label_token)));
01501       ffelab_set_firstref_column (label,
01502        ffewhere_column_use (ffelex_token_where_column (label_token)));
01503     }
01504 
01505   switch (ffelab_type (label))
01506     {
01507     case FFELAB_typeUNKNOWN:
01508     case FFELAB_typeASSIGNABLE:
01509       ffelab_set_type (label, FFELAB_typeNOTLOOP);
01510       ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ()));
01511       break;
01512 
01513     case FFELAB_typeLOOPEND:
01514       if (ffelab_blocknum (label) != 0)
01515   break;      /* Already taken care of. */
01516       for (block = ffestw_top_do (ffestw_stack_top ());
01517      (block != NULL) && (ffestw_label (block) != label);
01518      block = ffestw_top_do (ffestw_previous (block)))
01519   ;     /* Find most recent DO <label> ancestor. */
01520       if (block == NULL)
01521   {     /* Reference to within a (dead) block. */
01522     ffebad_start (FFEBAD_LABEL_BLOCK);
01523     ffebad_here (0, ffelab_definition_line (label),
01524            ffelab_definition_column (label));
01525     ffebad_here (1, ffelex_token_where_line (label_token),
01526            ffelex_token_where_column (label_token));
01527     ffebad_finish ();
01528     break;
01529   }
01530       ffelab_set_blocknum (label, ffestw_blocknum (block));
01531       ffelab_set_firstref_line (label,
01532      ffewhere_line_use (ffelex_token_where_line (label_token)));
01533       ffelab_set_firstref_column (label,
01534        ffewhere_column_use (ffelex_token_where_column (label_token)));
01535       break;
01536 
01537     case FFELAB_typeNOTLOOP:
01538     case FFELAB_typeENDIF:
01539       if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
01540   break;
01541       blocknum = ffelab_blocknum (label);
01542       for (block = ffestw_stack_top ();
01543      ffestw_blocknum (block) > blocknum;
01544      block = ffestw_previous (block))
01545   ;     /* Find most recent common ancestor. */
01546       if (ffelab_blocknum (label) == ffestw_blocknum (block))
01547   break;      /* Check again. */
01548       if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
01549   {     /* Reference to within a (dead) block. */
01550     ffebad_start (FFEBAD_LABEL_BLOCK);
01551     ffebad_here (0, ffelab_definition_line (label),
01552            ffelab_definition_column (label));
01553     ffebad_here (1, ffelex_token_where_line (label_token),
01554            ffelex_token_where_column (label_token));
01555     ffebad_finish ();
01556     break;
01557   }
01558       ffelab_set_blocknum (label, ffestw_blocknum (block));
01559       break;
01560 
01561     case FFELAB_typeFORMAT:
01562       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
01563   {
01564     ffelab_set_type (label, FFELAB_typeANY);
01565     ffestd_labeldef_any (label);
01566 
01567     ffebad_start (FFEBAD_LABEL_USE_USE);
01568     ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
01569     ffebad_here (1, ffelex_token_where_line (label_token),
01570            ffelex_token_where_column (label_token));
01571     ffebad_finish ();
01572 
01573     ffestc_try_shriek_do_ ();
01574 
01575     return FALSE;
01576   }
01577       /* Fall through. */
01578     case FFELAB_typeUSELESS:
01579       ffelab_set_type (label, FFELAB_typeANY);
01580       ffestd_labeldef_any (label);
01581 
01582       ffebad_start (FFEBAD_LABEL_USE_DEF);
01583       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
01584       ffebad_here (1, ffelex_token_where_line (label_token),
01585        ffelex_token_where_column (label_token));
01586       ffebad_finish ();
01587 
01588       ffestc_try_shriek_do_ ();
01589 
01590       return FALSE;
01591 
01592     default:
01593       assert ("bad label" == NULL);
01594       /* Fall through.  */
01595     case FFELAB_typeANY:
01596       break;
01597     }
01598 
01599   *x_label = label;
01600   return TRUE;
01601 }
01602 
01603 /* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification
01604 
01605    if (ffestc_labelref_is_format_(label_token,&label))
01606        // label ref is ok, label is filled in with ffelab object  */
01607 
01608 static bool
01609 ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
01610 {
01611   ffelab label;
01612   ffelabValue label_value;
01613 
01614   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
01615   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
01616     {
01617       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
01618       ffebad_here (0, ffelex_token_where_line (label_token),
01619        ffelex_token_where_column (label_token));
01620       ffebad_finish ();
01621       return FALSE;
01622     }
01623 
01624   label = ffelab_find (label_value);
01625   if (label == NULL)
01626     {
01627       label = ffelab_new (label_value);
01628       ffelab_set_firstref_line (label,
01629      ffewhere_line_use (ffelex_token_where_line (label_token)));
01630       ffelab_set_firstref_column (label,
01631        ffewhere_column_use (ffelex_token_where_column (label_token)));
01632     }
01633 
01634   switch (ffelab_type (label))
01635     {
01636     case FFELAB_typeUNKNOWN:
01637     case FFELAB_typeASSIGNABLE:
01638       ffelab_set_type (label, FFELAB_typeFORMAT);
01639       break;
01640 
01641     case FFELAB_typeFORMAT:
01642       break;
01643 
01644     case FFELAB_typeLOOPEND:
01645     case FFELAB_typeNOTLOOP:
01646       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
01647   {
01648     ffelab_set_type (label, FFELAB_typeANY);
01649     ffestd_labeldef_any (label);
01650 
01651     ffebad_start (FFEBAD_LABEL_USE_USE);
01652     ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
01653     ffebad_here (1, ffelex_token_where_line (label_token),
01654            ffelex_token_where_column (label_token));
01655     ffebad_finish ();
01656 
01657     ffestc_try_shriek_do_ ();
01658 
01659     return FALSE;
01660   }
01661       /* Fall through. */
01662     case FFELAB_typeUSELESS:
01663     case FFELAB_typeENDIF:
01664       ffelab_set_type (label, FFELAB_typeANY);
01665       ffestd_labeldef_any (label);
01666 
01667       ffebad_start (FFEBAD_LABEL_USE_DEF);
01668       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
01669       ffebad_here (1, ffelex_token_where_line (label_token),
01670        ffelex_token_where_column (label_token));
01671       ffebad_finish ();
01672 
01673       ffestc_try_shriek_do_ ();
01674 
01675       return FALSE;
01676 
01677     default:
01678       assert ("bad label" == NULL);
01679       /* Fall through.  */
01680     case FFELAB_typeANY:
01681       break;
01682     }
01683 
01684   ffestc_try_shriek_do_ ();
01685 
01686   *x_label = label;
01687   return TRUE;
01688 }
01689 
01690 /* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt
01691 
01692    if (ffestc_labelref_is_loopend_(label_token,&label))
01693        // label ref is ok, label is filled in with ffelab object  */
01694 
01695 static bool
01696 ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
01697 {
01698   ffelab label;
01699   ffelabValue label_value;
01700 
01701   label_value = (ffelabValue) atol (ffelex_token_text (label_token));
01702   if ((label_value == 0) || (label_value > FFELAB_valueMAX))
01703     {
01704       ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
01705       ffebad_here (0, ffelex_token_where_line (label_token),
01706        ffelex_token_where_column (label_token));
01707       ffebad_finish ();
01708       return FALSE;
01709     }
01710 
01711   label = ffelab_find (label_value);
01712   if (label == NULL)
01713     {
01714       label = ffelab_new (label_value);
01715       ffelab_set_doref_line (label,
01716      ffewhere_line_use (ffelex_token_where_line (label_token)));
01717       ffelab_set_doref_column (label,
01718        ffewhere_column_use (ffelex_token_where_column (label_token)));
01719     }
01720 
01721   switch (ffelab_type (label))
01722     {
01723     case FFELAB_typeASSIGNABLE:
01724       ffelab_set_doref_line (label,
01725      ffewhere_line_use (ffelex_token_where_line (label_token)));
01726       ffelab_set_doref_column (label,
01727        ffewhere_column_use (ffelex_token_where_column (label_token)));
01728       ffewhere_line_kill (ffelab_firstref_line (label));
01729       ffelab_set_firstref_line (label, ffewhere_line_unknown ());
01730       ffewhere_column_kill (ffelab_firstref_column (label));
01731       ffelab_set_firstref_column (label, ffewhere_column_unknown ());
01732       /* Fall through. */
01733     case FFELAB_typeUNKNOWN:
01734       ffelab_set_type (label, FFELAB_typeLOOPEND);
01735       ffelab_set_blocknum (label, 0);
01736       break;
01737 
01738     case FFELAB_typeLOOPEND:
01739       if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
01740   {     /* Def must follow all refs. */
01741     ffelab_set_type (label, FFELAB_typeANY);
01742     ffestd_labeldef_any (label);
01743 
01744     ffebad_start (FFEBAD_LABEL_DEF_DO);
01745     ffebad_here (0, ffelab_definition_line (label),
01746            ffelab_definition_column (label));
01747     ffebad_here (1, ffelex_token_where_line (label_token),
01748            ffelex_token_where_column (label_token));
01749     ffebad_finish ();
01750 
01751     ffestc_try_shriek_do_ ();
01752 
01753     return FALSE;
01754   }
01755       if (ffelab_blocknum (label) != 0)
01756   {     /* Had a branch ref earlier, can't go inside
01757            this new block! */
01758     ffelab_set_type (label, FFELAB_typeANY);
01759     ffestd_labeldef_any (label);
01760 
01761     ffebad_start (FFEBAD_LABEL_USE_USE);
01762     ffebad_here (0, ffelab_firstref_line (label),
01763            ffelab_firstref_column (label));
01764     ffebad_here (1, ffelex_token_where_line (label_token),
01765            ffelex_token_where_column (label_token));
01766     ffebad_finish ();
01767 
01768     ffestc_try_shriek_do_ ();
01769 
01770     return FALSE;
01771   }
01772       if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
01773     || (ffestw_label (ffestw_stack_top ()) != label))
01774   {     /* Top of stack interrupts flow between two
01775            DOs specifying label. */
01776     ffelab_set_type (label, FFELAB_typeANY);
01777     ffestd_labeldef_any (label);
01778 
01779     ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO);
01780     ffebad_here (0, ffelab_doref_line (label),
01781            ffelab_doref_column (label));
01782     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
01783     ffebad_here (2, ffelex_token_where_line (label_token),
01784            ffelex_token_where_column (label_token));
01785     ffebad_finish ();
01786 
01787     ffestc_try_shriek_do_ ();
01788 
01789     return FALSE;
01790   }
01791       break;
01792 
01793     case FFELAB_typeNOTLOOP:
01794     case FFELAB_typeFORMAT:
01795       if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
01796   {
01797     ffelab_set_type (label, FFELAB_typeANY);
01798     ffestd_labeldef_any (label);
01799 
01800     ffebad_start (FFEBAD_LABEL_USE_USE);
01801     ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
01802     ffebad_here (1, ffelex_token_where_line (label_token),
01803            ffelex_token_where_column (label_token));
01804     ffebad_finish ();
01805 
01806     ffestc_try_shriek_do_ ();
01807 
01808     return FALSE;
01809   }
01810       /* Fall through. */
01811     case FFELAB_typeUSELESS:
01812     case FFELAB_typeENDIF:
01813       ffelab_set_type (label, FFELAB_typeANY);
01814       ffestd_labeldef_any (label);
01815 
01816       ffebad_start (FFEBAD_LABEL_USE_DEF);
01817       ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
01818       ffebad_here (1, ffelex_token_where_line (label_token),
01819        ffelex_token_where_column (label_token));
01820       ffebad_finish ();
01821 
01822       ffestc_try_shriek_do_ ();
01823 
01824       return FALSE;
01825 
01826     default:
01827       assert ("bad label" == NULL);
01828       /* Fall through.  */
01829     case FFELAB_typeANY:
01830       break;
01831     }
01832 
01833   *x_label = label;
01834   return TRUE;
01835 }
01836 
01837 /* ffestc_order_access_ -- Check ordering on <access> statement
01838 
01839    if (ffestc_order_access_() != FFESTC_orderOK_)
01840        return;  */
01841 
01842 #if FFESTR_F90
01843 static ffestcOrder_
01844 ffestc_order_access_ ()
01845 {
01846   recurse:
01847 
01848   switch (ffestw_state (ffestw_stack_top ()))
01849     {
01850     case FFESTV_stateNIL:
01851       ffestc_shriek_begin_program_ ();
01852       goto recurse;   /* :::::::::::::::::::: */
01853 
01854     case FFESTV_stateMODULE0:
01855     case FFESTV_stateMODULE1:
01856     case FFESTV_stateMODULE2:
01857       ffestw_update (NULL);
01858       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
01859       return FFESTC_orderOK_;
01860 
01861     case FFESTV_stateMODULE3:
01862       return FFESTC_orderOK_;
01863 
01864     case FFESTV_stateUSE:
01865 #if FFESTR_F90
01866       ffestc_shriek_end_uses_ (TRUE);
01867 #endif
01868       goto recurse;   /* :::::::::::::::::::: */
01869 
01870     case FFESTV_stateWHERE:
01871       ffestc_order_bad_ ();
01872 #if FFESTR_F90
01873       ffestc_shriek_where_ (FALSE);
01874 #endif
01875       return FFESTC_orderBAD_;
01876 
01877     case FFESTV_stateIF:
01878       ffestc_order_bad_ ();
01879       ffestc_shriek_if_ (FALSE);
01880       return FFESTC_orderBAD_;
01881 
01882     default:
01883       ffestc_order_bad_ ();
01884       return FFESTC_orderBAD_;
01885     }
01886 }
01887 
01888 #endif
01889 /* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
01890 
01891    if (ffestc_order_actiondo_() != FFESTC_orderOK_)
01892        return;  */
01893 
01894 static ffestcOrder_
01895 ffestc_order_actiondo_ ()
01896 {
01897   recurse:
01898 
01899   switch (ffestw_state (ffestw_stack_top ()))
01900     {
01901     case FFESTV_stateNIL:
01902       ffestc_shriek_begin_program_ ();
01903       goto recurse;   /* :::::::::::::::::::: */
01904 
01905     case FFESTV_stateDO:
01906       return FFESTC_orderOK_;
01907 
01908     case FFESTV_stateIFTHEN:
01909     case FFESTV_stateSELECT1:
01910       if (ffestw_top_do (ffestw_stack_top ()) == NULL)
01911   break;
01912       return FFESTC_orderOK_;
01913 
01914     case FFESTV_stateIF:
01915       if (ffestw_top_do (ffestw_stack_top ()) == NULL)
01916   break;
01917       ffestc_shriek_after1_ = ffestc_shriek_if_;
01918       return FFESTC_orderOK_;
01919 
01920     case FFESTV_stateUSE:
01921 #if FFESTR_F90
01922       ffestc_shriek_end_uses_ (TRUE);
01923 #endif
01924       goto recurse;   /* :::::::::::::::::::: */
01925 
01926     case FFESTV_stateWHERE:
01927       ffestc_order_bad_ ();
01928 #if FFESTR_F90
01929       ffestc_shriek_where_ (FALSE);
01930 #endif
01931       return FFESTC_orderBAD_;
01932 
01933     default:
01934       break;
01935     }
01936   ffestc_order_bad_ ();
01937   return FFESTC_orderBAD_;
01938 }
01939 
01940 /* ffestc_order_actionif_ -- Check ordering on <actionif> statement
01941 
01942    if (ffestc_order_actionif_() != FFESTC_orderOK_)
01943        return;  */
01944 
01945 static ffestcOrder_
01946 ffestc_order_actionif_ ()
01947 {
01948   bool update;
01949 
01950 recurse:
01951 
01952   switch (ffestw_state (ffestw_stack_top ()))
01953     {
01954     case FFESTV_stateNIL:
01955       ffestc_shriek_begin_program_ ();
01956       goto recurse;   /* :::::::::::::::::::: */
01957 
01958     case FFESTV_statePROGRAM0:
01959     case FFESTV_statePROGRAM1:
01960     case FFESTV_statePROGRAM2:
01961     case FFESTV_statePROGRAM3:
01962       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
01963       update = TRUE;
01964       break;
01965 
01966     case FFESTV_stateSUBROUTINE0:
01967     case FFESTV_stateSUBROUTINE1:
01968     case FFESTV_stateSUBROUTINE2:
01969     case FFESTV_stateSUBROUTINE3:
01970       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
01971       update = TRUE;
01972       break;
01973 
01974     case FFESTV_stateFUNCTION0:
01975     case FFESTV_stateFUNCTION1:
01976     case FFESTV_stateFUNCTION2:
01977     case FFESTV_stateFUNCTION3:
01978       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
01979       update = TRUE;
01980       break;
01981 
01982     case FFESTV_statePROGRAM4:
01983     case FFESTV_stateSUBROUTINE4:
01984     case FFESTV_stateFUNCTION4:
01985       update = FALSE;
01986       break;
01987 
01988     case FFESTV_stateIFTHEN:
01989     case FFESTV_stateDO:
01990     case FFESTV_stateSELECT1:
01991       return FFESTC_orderOK_;
01992 
01993     case FFESTV_stateIF:
01994       ffestc_shriek_after1_ = ffestc_shriek_if_;
01995       return FFESTC_orderOK_;
01996 
01997     case FFESTV_stateUSE:
01998 #if FFESTR_F90
01999       ffestc_shriek_end_uses_ (TRUE);
02000 #endif
02001       goto recurse;   /* :::::::::::::::::::: */
02002 
02003     case FFESTV_stateWHERE:
02004       ffestc_order_bad_ ();
02005 #if FFESTR_F90
02006       ffestc_shriek_where_ (FALSE);
02007 #endif
02008       return FFESTC_orderBAD_;
02009 
02010     default:
02011       ffestc_order_bad_ ();
02012       return FFESTC_orderBAD_;
02013     }
02014 
02015   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
02016     {
02017     case FFESTV_stateINTERFACE0:
02018       ffestc_order_bad_ ();
02019       if (update)
02020   ffestw_update (NULL);
02021       return FFESTC_orderBAD_;
02022 
02023     default:
02024       if (update)
02025   ffestw_update (NULL);
02026       return FFESTC_orderOK_;
02027     }
02028 }
02029 
02030 /* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement
02031 
02032    if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
02033        return;  */
02034 
02035 static ffestcOrder_
02036 ffestc_order_actionwhere_ ()
02037 {
02038   bool update;
02039 
02040 recurse:
02041 
02042   switch (ffestw_state (ffestw_stack_top ()))
02043     {
02044     case FFESTV_stateNIL:
02045       ffestc_shriek_begin_program_ ();
02046       goto recurse;   /* :::::::::::::::::::: */
02047 
02048     case FFESTV_statePROGRAM0:
02049     case FFESTV_statePROGRAM1:
02050     case FFESTV_statePROGRAM2:
02051     case FFESTV_statePROGRAM3:
02052       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
02053       update = TRUE;
02054       break;
02055 
02056     case FFESTV_stateSUBROUTINE0:
02057     case FFESTV_stateSUBROUTINE1:
02058     case FFESTV_stateSUBROUTINE2:
02059     case FFESTV_stateSUBROUTINE3:
02060       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
02061       update = TRUE;
02062       break;
02063 
02064     case FFESTV_stateFUNCTION0:
02065     case FFESTV_stateFUNCTION1:
02066     case FFESTV_stateFUNCTION2:
02067     case FFESTV_stateFUNCTION3:
02068       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
02069       update = TRUE;
02070       break;
02071 
02072     case FFESTV_statePROGRAM4:
02073     case FFESTV_stateSUBROUTINE4:
02074     case FFESTV_stateFUNCTION4:
02075       update = FALSE;
02076       break;
02077 
02078     case FFESTV_stateWHERETHEN:
02079     case FFESTV_stateIFTHEN:
02080     case FFESTV_stateDO:
02081     case FFESTV_stateSELECT1:
02082       return FFESTC_orderOK_;
02083 
02084     case FFESTV_stateWHERE:
02085 #if FFESTR_F90
02086       ffestc_shriek_after1_ = ffestc_shriek_where_;
02087 #endif
02088       return FFESTC_orderOK_;
02089 
02090     case FFESTV_stateIF:
02091       ffestc_shriek_after1_ = ffestc_shriek_if_;
02092       return FFESTC_orderOK_;
02093 
02094     case FFESTV_stateUSE:
02095 #if FFESTR_F90
02096       ffestc_shriek_end_uses_ (TRUE);
02097 #endif
02098       goto recurse;   /* :::::::::::::::::::: */
02099 
02100     default:
02101       ffestc_order_bad_ ();
02102       return FFESTC_orderBAD_;
02103     }
02104 
02105   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
02106     {
02107     case FFESTV_stateINTERFACE0:
02108       ffestc_order_bad_ ();
02109       if (update)
02110   ffestw_update (NULL);
02111       return FFESTC_orderBAD_;
02112 
02113     default:
02114       if (update)
02115   ffestw_update (NULL);
02116       return FFESTC_orderOK_;
02117     }
02118 }
02119 
02120 /* Check ordering on "any" statement.  Like _actionwhere_, but
02121    doesn't produce any diagnostics.  */
02122 
02123 static void
02124 ffestc_order_any_ ()
02125 {
02126   bool update;
02127 
02128 recurse:
02129 
02130   switch (ffestw_state (ffestw_stack_top ()))
02131     {
02132     case FFESTV_stateNIL:
02133       ffestc_shriek_begin_program_ ();
02134       goto recurse;   /* :::::::::::::::::::: */
02135 
02136     case FFESTV_statePROGRAM0:
02137     case FFESTV_statePROGRAM1:
02138     case FFESTV_statePROGRAM2:
02139     case FFESTV_statePROGRAM3:
02140       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
02141       update = TRUE;
02142       break;
02143 
02144     case FFESTV_stateSUBROUTINE0:
02145     case FFESTV_stateSUBROUTINE1:
02146     case FFESTV_stateSUBROUTINE2:
02147     case FFESTV_stateSUBROUTINE3:
02148       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
02149       update = TRUE;
02150       break;
02151 
02152     case FFESTV_stateFUNCTION0:
02153     case FFESTV_stateFUNCTION1:
02154     case FFESTV_stateFUNCTION2:
02155     case FFESTV_stateFUNCTION3:
02156       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
02157       update = TRUE;
02158       break;
02159 
02160     case FFESTV_statePROGRAM4:
02161     case FFESTV_stateSUBROUTINE4:
02162     case FFESTV_stateFUNCTION4:
02163       update = FALSE;
02164       break;
02165 
02166     case FFESTV_stateWHERETHEN:
02167     case FFESTV_stateIFTHEN:
02168     case FFESTV_stateDO:
02169     case FFESTV_stateSELECT1:
02170       return;
02171 
02172     case FFESTV_stateWHERE:
02173 #if FFESTR_F90
02174       ffestc_shriek_after1_ = ffestc_shriek_where_;
02175 #endif
02176       return;
02177 
02178     case FFESTV_stateIF:
02179       ffestc_shriek_after1_ = ffestc_shriek_if_;
02180       return;
02181 
02182     case FFESTV_stateUSE:
02183 #if FFESTR_F90
02184       ffestc_shriek_end_uses_ (TRUE);
02185 #endif
02186       goto recurse;   /* :::::::::::::::::::: */
02187 
02188     default:
02189       return;
02190     }
02191 
02192   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
02193     {
02194     case FFESTV_stateINTERFACE0:
02195       if (update)
02196   ffestw_update (NULL);
02197       return;
02198 
02199     default:
02200       if (update)
02201   ffestw_update (NULL);
02202       return;
02203     }
02204 }
02205 
02206 /* ffestc_order_bad_ -- Whine about statement ordering violation
02207 
02208    ffestc_order_bad_();
02209 
02210    Uses current ffesta_tokens[0] and, if available, info on where current
02211    state started to produce generic message.  Someday we should do
02212    fancier things than this, but this just gets things creaking along for
02213    now.  */
02214 
02215 static void
02216 ffestc_order_bad_ ()
02217 {
02218   if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
02219     {
02220       ffebad_start (FFEBAD_ORDER_1);
02221       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
02222        ffelex_token_where_column (ffesta_tokens[0]));
02223       ffebad_finish ();
02224     }
02225   else
02226     {
02227       ffebad_start (FFEBAD_ORDER_2);
02228       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
02229        ffelex_token_where_column (ffesta_tokens[0]));
02230       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
02231       ffebad_finish ();
02232     }
02233   ffestc_labeldef_useless_ ();  /* Any label definition is useless. */
02234 }
02235 
02236 /* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement
02237 
02238    if (ffestc_order_blockdata_() != FFESTC_orderOK_)
02239        return;  */
02240 
02241 static ffestcOrder_
02242 ffestc_order_blockdata_ ()
02243 {
02244   recurse:
02245 
02246   switch (ffestw_state (ffestw_stack_top ()))
02247     {
02248     case FFESTV_stateBLOCKDATA0:
02249     case FFESTV_stateBLOCKDATA1:
02250     case FFESTV_stateBLOCKDATA2:
02251     case FFESTV_stateBLOCKDATA3:
02252     case FFESTV_stateBLOCKDATA4:
02253     case FFESTV_stateBLOCKDATA5:
02254       return FFESTC_orderOK_;
02255 
02256     case FFESTV_stateUSE:
02257 #if FFESTR_F90
02258       ffestc_shriek_end_uses_ (TRUE);
02259 #endif
02260       goto recurse;   /* :::::::::::::::::::: */
02261 
02262     case FFESTV_stateWHERE:
02263       ffestc_order_bad_ ();
02264 #if FFESTR_F90
02265       ffestc_shriek_where_ (FALSE);
02266 #endif
02267       return FFESTC_orderBAD_;
02268 
02269     case FFESTV_stateIF:
02270       ffestc_order_bad_ ();
02271       ffestc_shriek_if_ (FALSE);
02272       return FFESTC_orderBAD_;
02273 
02274     default:
02275       ffestc_order_bad_ ();
02276       return FFESTC_orderBAD_;
02277     }
02278 }
02279 
02280 /* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement
02281 
02282    if (ffestc_order_blockspec_() != FFESTC_orderOK_)
02283        return;  */
02284 
02285 static ffestcOrder_
02286 ffestc_order_blockspec_ ()
02287 {
02288   recurse:
02289 
02290   switch (ffestw_state (ffestw_stack_top ()))
02291     {
02292     case FFESTV_stateNIL:
02293       ffestc_shriek_begin_program_ ();
02294       goto recurse;   /* :::::::::::::::::::: */
02295 
02296     case FFESTV_statePROGRAM0:
02297     case FFESTV_statePROGRAM1:
02298     case FFESTV_statePROGRAM2:
02299       ffestw_update (NULL);
02300       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
02301       return FFESTC_orderOK_;
02302 
02303     case FFESTV_stateSUBROUTINE0:
02304     case FFESTV_stateSUBROUTINE1:
02305     case FFESTV_stateSUBROUTINE2:
02306       ffestw_update (NULL);
02307       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
02308       return FFESTC_orderOK_;
02309 
02310     case FFESTV_stateFUNCTION0:
02311     case FFESTV_stateFUNCTION1:
02312     case FFESTV_stateFUNCTION2:
02313       ffestw_update (NULL);
02314       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
02315       return FFESTC_orderOK_;
02316 
02317     case FFESTV_stateMODULE0:
02318     case FFESTV_stateMODULE1:
02319     case FFESTV_stateMODULE2:
02320       ffestw_update (NULL);
02321       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
02322       return FFESTC_orderOK_;
02323 
02324     case FFESTV_stateBLOCKDATA0:
02325     case FFESTV_stateBLOCKDATA1:
02326     case FFESTV_stateBLOCKDATA2:
02327       ffestw_update (NULL);
02328       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
02329       return FFESTC_orderOK_;
02330 
02331     case FFESTV_statePROGRAM3:
02332     case FFESTV_stateSUBROUTINE3:
02333     case FFESTV_stateFUNCTION3:
02334     case FFESTV_stateMODULE3:
02335     case FFESTV_stateBLOCKDATA3:
02336       return FFESTC_orderOK_;
02337 
02338     case FFESTV_stateUSE:
02339 #if FFESTR_F90
02340       ffestc_shriek_end_uses_ (TRUE);
02341 #endif
02342       goto recurse;   /* :::::::::::::::::::: */
02343 
02344     case FFESTV_stateWHERE:
02345       ffestc_order_bad_ ();
02346 #if FFESTR_F90
02347       ffestc_shriek_where_ (FALSE);
02348 #endif
02349       return FFESTC_orderBAD_;
02350 
02351     case FFESTV_stateIF:
02352       ffestc_order_bad_ ();
02353       ffestc_shriek_if_ (FALSE);
02354       return FFESTC_orderBAD_;
02355 
02356     default:
02357       ffestc_order_bad_ ();
02358       return FFESTC_orderBAD_;
02359     }
02360 }
02361 
02362 /* ffestc_order_component_ -- Check ordering on <component-decl> statement
02363 
02364    if (ffestc_order_component_() != FFESTC_orderOK_)
02365        return;  */
02366 
02367 #if FFESTR_F90
02368 static ffestcOrder_
02369 ffestc_order_component_ ()
02370 {
02371   switch (ffestw_state (ffestw_stack_top ()))
02372     {
02373     case FFESTV_stateTYPE:
02374     case FFESTV_stateSTRUCTURE:
02375     case FFESTV_stateMAP:
02376       return FFESTC_orderOK_;
02377 
02378     case FFESTV_stateWHERE:
02379       ffestc_order_bad_ ();
02380       ffestc_shriek_where_ (FALSE);
02381       return FFESTC_orderBAD_;
02382 
02383     case FFESTV_stateIF:
02384       ffestc_order_bad_ ();
02385       ffestc_shriek_if_ (FALSE);
02386       return FFESTC_orderBAD_;
02387 
02388     default:
02389       ffestc_order_bad_ ();
02390       return FFESTC_orderBAD_;
02391     }
02392 }
02393 
02394 #endif
02395 /* ffestc_order_contains_ -- Check ordering on CONTAINS statement
02396 
02397    if (ffestc_order_contains_() != FFESTC_orderOK_)
02398        return;  */
02399 
02400 #if FFESTR_F90
02401 static ffestcOrder_
02402 ffestc_order_contains_ ()
02403 {
02404   recurse:
02405 
02406   switch (ffestw_state (ffestw_stack_top ()))
02407     {
02408     case FFESTV_stateNIL:
02409       ffestc_shriek_begin_program_ ();
02410       goto recurse;   /* :::::::::::::::::::: */
02411 
02412     case FFESTV_statePROGRAM0:
02413     case FFESTV_statePROGRAM1:
02414     case FFESTV_statePROGRAM2:
02415     case FFESTV_statePROGRAM3:
02416     case FFESTV_statePROGRAM4:
02417       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5);
02418       break;
02419 
02420     case FFESTV_stateSUBROUTINE0:
02421     case FFESTV_stateSUBROUTINE1:
02422     case FFESTV_stateSUBROUTINE2:
02423     case FFESTV_stateSUBROUTINE3:
02424     case FFESTV_stateSUBROUTINE4:
02425       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5);
02426       break;
02427 
02428     case FFESTV_stateFUNCTION0:
02429     case FFESTV_stateFUNCTION1:
02430     case FFESTV_stateFUNCTION2:
02431     case FFESTV_stateFUNCTION3:
02432     case FFESTV_stateFUNCTION4:
02433       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5);
02434       break;
02435 
02436     case FFESTV_stateMODULE0:
02437     case FFESTV_stateMODULE1:
02438     case FFESTV_stateMODULE2:
02439     case FFESTV_stateMODULE3:
02440     case FFESTV_stateMODULE4:
02441       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5);
02442       break;
02443 
02444     case FFESTV_stateUSE:
02445       ffestc_shriek_end_uses_ (TRUE);
02446       goto recurse;   /* :::::::::::::::::::: */
02447 
02448     case FFESTV_stateWHERE:
02449       ffestc_order_bad_ ();
02450       ffestc_shriek_where_ (FALSE);
02451       return FFESTC_orderBAD_;
02452 
02453     case FFESTV_stateIF:
02454       ffestc_order_bad_ ();
02455       ffestc_shriek_if_ (FALSE);
02456       return FFESTC_orderBAD_;
02457 
02458     default:
02459       ffestc_order_bad_ ();
02460       return FFESTC_orderBAD_;
02461     }
02462 
02463   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
02464     {
02465     case FFESTV_stateNIL:
02466       ffestw_update (NULL);
02467       return FFESTC_orderOK_;
02468 
02469     default:
02470       ffestc_order_bad_ ();
02471       ffestw_update (NULL);
02472       return FFESTC_orderBAD_;
02473     }
02474 }
02475 
02476 #endif
02477 /* ffestc_order_data_ -- Check ordering on DATA statement
02478 
02479    if (ffestc_order_data_() != FFESTC_orderOK_)
02480        return;  */
02481 
02482 static ffestcOrder_
02483 ffestc_order_data_ ()
02484 {
02485   recurse:
02486 
02487   switch (ffestw_state (ffestw_stack_top ()))
02488     {
02489     case FFESTV_stateNIL:
02490       ffestc_shriek_begin_program_ ();
02491       goto recurse;   /* :::::::::::::::::::: */
02492 
02493     case FFESTV_statePROGRAM0:
02494     case FFESTV_statePROGRAM1:
02495       ffestw_update (NULL);
02496       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
02497       return FFESTC_orderOK_;
02498 
02499     case FFESTV_stateSUBROUTINE0:
02500     case FFESTV_stateSUBROUTINE1:
02501       ffestw_update (NULL);
02502       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
02503       return FFESTC_orderOK_;
02504 
02505     case FFESTV_stateFUNCTION0:
02506     case FFESTV_stateFUNCTION1:
02507       ffestw_update (NULL);
02508       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
02509       return FFESTC_orderOK_;
02510 
02511     case FFESTV_stateBLOCKDATA0:
02512     case FFESTV_stateBLOCKDATA1:
02513       ffestw_update (NULL);
02514       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
02515       return FFESTC_orderOK_;
02516 
02517     case FFESTV_statePROGRAM2:
02518     case FFESTV_stateSUBROUTINE2:
02519     case FFESTV_stateFUNCTION2:
02520     case FFESTV_stateBLOCKDATA2:
02521     case FFESTV_statePROGRAM3:
02522     case FFESTV_stateSUBROUTINE3:
02523     case FFESTV_stateFUNCTION3:
02524     case FFESTV_stateBLOCKDATA3:
02525     case FFESTV_statePROGRAM4:
02526     case FFESTV_stateSUBROUTINE4:
02527     case FFESTV_stateFUNCTION4:
02528     case FFESTV_stateBLOCKDATA4:
02529     case FFESTV_stateWHERETHEN:
02530     case FFESTV_stateIFTHEN:
02531     case FFESTV_stateDO:
02532     case FFESTV_stateSELECT0:
02533     case FFESTV_stateSELECT1:
02534       return FFESTC_orderOK_;
02535 
02536     case FFESTV_stateUSE:
02537 #if FFESTR_F90
02538       ffestc_shriek_end_uses_ (TRUE);
02539 #endif
02540       goto recurse;   /* :::::::::::::::::::: */
02541 
02542     case FFESTV_stateWHERE:
02543       ffestc_order_bad_ ();
02544 #if FFESTR_F90
02545       ffestc_shriek_where_ (FALSE);
02546 #endif
02547       return FFESTC_orderBAD_;
02548 
02549     case FFESTV_stateIF:
02550       ffestc_order_bad_ ();
02551       ffestc_shriek_if_ (FALSE);
02552       return FFESTC_orderBAD_;
02553 
02554     default:
02555       ffestc_order_bad_ ();
02556       return FFESTC_orderBAD_;
02557     }
02558 }
02559 
02560 /* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement
02561 
02562    if (ffestc_order_data77_() != FFESTC_orderOK_)
02563        return;  */
02564 
02565 static ffestcOrder_
02566 ffestc_order_data77_ ()
02567 {
02568   recurse:
02569 
02570   switch (ffestw_state (ffestw_stack_top ()))
02571     {
02572     case FFESTV_stateNIL:
02573       ffestc_shriek_begin_program_ ();
02574       goto recurse;   /* :::::::::::::::::::: */
02575 
02576     case FFESTV_statePROGRAM0:
02577     case FFESTV_statePROGRAM1:
02578     case FFESTV_statePROGRAM2:
02579     case FFESTV_statePROGRAM3:
02580       ffestw_update (NULL);
02581       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
02582       return FFESTC_orderOK_;
02583 
02584     case FFESTV_stateSUBROUTINE0:
02585     case FFESTV_stateSUBROUTINE1:
02586     case FFESTV_stateSUBROUTINE2:
02587     case FFESTV_stateSUBROUTINE3:
02588       ffestw_update (NULL);
02589       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
02590       return FFESTC_orderOK_;
02591 
02592     case FFESTV_stateFUNCTION0:
02593     case FFESTV_stateFUNCTION1:
02594     case FFESTV_stateFUNCTION2:
02595     case FFESTV_stateFUNCTION3:
02596       ffestw_update (NULL);
02597       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
02598       return FFESTC_orderOK_;
02599 
02600     case FFESTV_stateBLOCKDATA0:
02601     case FFESTV_stateBLOCKDATA1:
02602     case FFESTV_stateBLOCKDATA2:
02603     case FFESTV_stateBLOCKDATA3:
02604       ffestw_update (NULL);
02605       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4);
02606       return FFESTC_orderOK_;
02607 
02608     case FFESTV_statePROGRAM4:
02609     case FFESTV_stateSUBROUTINE4:
02610     case FFESTV_stateFUNCTION4:
02611     case FFESTV_stateBLOCKDATA4:
02612       return FFESTC_orderOK_;
02613 
02614     case FFESTV_stateWHERETHEN:
02615     case FFESTV_stateIFTHEN:
02616     case FFESTV_stateDO:
02617     case FFESTV_stateSELECT0:
02618     case FFESTV_stateSELECT1:
02619       return FFESTC_orderOK_;
02620 
02621     case FFESTV_stateUSE:
02622 #if FFESTR_F90
02623       ffestc_shriek_end_uses_ (TRUE);
02624 #endif
02625       goto recurse;   /* :::::::::::::::::::: */
02626 
02627     case FFESTV_stateWHERE:
02628       ffestc_order_bad_ ();
02629 #if FFESTR_F90
02630       ffestc_shriek_where_ (FALSE);
02631 #endif
02632       return FFESTC_orderBAD_;
02633 
02634     case FFESTV_stateIF:
02635       ffestc_order_bad_ ();
02636       ffestc_shriek_if_ (FALSE);
02637       return FFESTC_orderBAD_;
02638 
02639     default:
02640       ffestc_order_bad_ ();
02641       return FFESTC_orderBAD_;
02642     }
02643 }
02644 
02645 /* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement
02646 
02647    if (ffestc_order_derivedtype_() != FFESTC_orderOK_)
02648        return;  */
02649 
02650 #if FFESTR_F90
02651 static ffestcOrder_
02652 ffestc_order_derivedtype_ ()
02653 {
02654   recurse:
02655 
02656   switch (ffestw_state (ffestw_stack_top ()))
02657     {
02658     case FFESTV_stateNIL:
02659       ffestc_shriek_begin_program_ ();
02660       goto recurse;   /* :::::::::::::::::::: */
02661 
02662     case FFESTV_statePROGRAM0:
02663     case FFESTV_statePROGRAM1:
02664     case FFESTV_statePROGRAM2:
02665       ffestw_update (NULL);
02666       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
02667       return FFESTC_orderOK_;
02668 
02669     case FFESTV_stateSUBROUTINE0:
02670     case FFESTV_stateSUBROUTINE1:
02671     case FFESTV_stateSUBROUTINE2:
02672       ffestw_update (NULL);
02673       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
02674       return FFESTC_orderOK_;
02675 
02676     case FFESTV_stateFUNCTION0:
02677     case FFESTV_stateFUNCTION1:
02678     case FFESTV_stateFUNCTION2:
02679       ffestw_update (NULL);
02680       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
02681       return FFESTC_orderOK_;
02682 
02683     case FFESTV_stateMODULE0:
02684     case FFESTV_stateMODULE1:
02685     case FFESTV_stateMODULE2:
02686       ffestw_update (NULL);
02687       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
02688       return FFESTC_orderOK_;
02689 
02690     case FFESTV_statePROGRAM3:
02691     case FFESTV_stateSUBROUTINE3:
02692     case FFESTV_stateFUNCTION3:
02693     case FFESTV_stateMODULE3:
02694       return FFESTC_orderOK_;
02695 
02696     case FFESTV_stateUSE:
02697       ffestc_shriek_end_uses_ (TRUE);
02698       goto recurse;   /* :::::::::::::::::::: */
02699 
02700     case FFESTV_stateWHERE:
02701       ffestc_order_bad_ ();
02702       ffestc_shriek_where_ (FALSE);
02703       return FFESTC_orderBAD_;
02704 
02705     case FFESTV_stateIF:
02706       ffestc_order_bad_ ();
02707       ffestc_shriek_if_ (FALSE);
02708       return FFESTC_orderBAD_;
02709 
02710     default:
02711       ffestc_order_bad_ ();
02712       return FFESTC_orderBAD_;
02713     }
02714 }
02715 
02716 #endif
02717 /* ffestc_order_do_ -- Check ordering on <do> statement
02718 
02719    if (ffestc_order_do_() != FFESTC_orderOK_)
02720        return;  */
02721 
02722 static ffestcOrder_
02723 ffestc_order_do_ ()
02724 {
02725   switch (ffestw_state (ffestw_stack_top ()))
02726     {
02727     case FFESTV_stateDO:
02728       return FFESTC_orderOK_;
02729 
02730     case FFESTV_stateWHERE:
02731       ffestc_order_bad_ ();
02732 #if FFESTR_F90
02733       ffestc_shriek_where_ (FALSE);
02734 #endif
02735       return FFESTC_orderBAD_;
02736 
02737     case FFESTV_stateIF:
02738       ffestc_order_bad_ ();
02739       ffestc_shriek_if_ (FALSE);
02740       return FFESTC_orderBAD_;
02741 
02742     default:
02743       ffestc_order_bad_ ();
02744       return FFESTC_orderBAD_;
02745     }
02746 }
02747 
02748 /* ffestc_order_entry_ -- Check ordering on ENTRY statement
02749 
02750    if (ffestc_order_entry_() != FFESTC_orderOK_)
02751        return;  */
02752 
02753 static ffestcOrder_
02754 ffestc_order_entry_ ()
02755 {
02756   recurse:
02757 
02758   switch (ffestw_state (ffestw_stack_top ()))
02759     {
02760     case FFESTV_stateNIL:
02761       ffestc_shriek_begin_program_ ();
02762       goto recurse;   /* :::::::::::::::::::: */
02763 
02764     case FFESTV_stateSUBROUTINE0:
02765       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
02766       break;
02767 
02768     case FFESTV_stateFUNCTION0:
02769       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
02770       break;
02771 
02772     case FFESTV_stateSUBROUTINE1:
02773     case FFESTV_stateSUBROUTINE2:
02774     case FFESTV_stateFUNCTION1:
02775     case FFESTV_stateFUNCTION2:
02776     case FFESTV_stateSUBROUTINE3:
02777     case FFESTV_stateFUNCTION3:
02778     case FFESTV_stateSUBROUTINE4:
02779     case FFESTV_stateFUNCTION4:
02780       break;
02781 
02782     case FFESTV_stateUSE:
02783 #if FFESTR_F90
02784       ffestc_shriek_end_uses_ (TRUE);
02785 #endif
02786       goto recurse;   /* :::::::::::::::::::: */
02787 
02788     case FFESTV_stateWHERE:
02789       ffestc_order_bad_ ();
02790 #if FFESTR_F90
02791       ffestc_shriek_where_ (FALSE);
02792 #endif
02793       return FFESTC_orderBAD_;
02794 
02795     case FFESTV_stateIF:
02796       ffestc_order_bad_ ();
02797       ffestc_shriek_if_ (FALSE);
02798       return FFESTC_orderBAD_;
02799 
02800     default:
02801       ffestc_order_bad_ ();
02802       return FFESTC_orderBAD_;
02803     }
02804 
02805   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
02806     {
02807     case FFESTV_stateNIL:
02808     case FFESTV_stateMODULE5:
02809       ffestw_update (NULL);
02810       return FFESTC_orderOK_;
02811 
02812     default:
02813       ffestc_order_bad_ ();
02814       ffestw_update (NULL);
02815       return FFESTC_orderBAD_;
02816     }
02817 }
02818 
02819 /* ffestc_order_exec_ -- Check ordering on <exec> statement
02820 
02821    if (ffestc_order_exec_() != FFESTC_orderOK_)
02822        return;  */
02823 
02824 static ffestcOrder_
02825 ffestc_order_exec_ ()
02826 {
02827   bool update;
02828 
02829 recurse:
02830 
02831   switch (ffestw_state (ffestw_stack_top ()))
02832     {
02833     case FFESTV_stateNIL:
02834       ffestc_shriek_begin_program_ ();
02835       goto recurse;   /* :::::::::::::::::::: */
02836 
02837     case FFESTV_statePROGRAM0:
02838     case FFESTV_statePROGRAM1:
02839     case FFESTV_statePROGRAM2:
02840     case FFESTV_statePROGRAM3:
02841       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
02842       update = TRUE;
02843       break;
02844 
02845     case FFESTV_stateSUBROUTINE0:
02846     case FFESTV_stateSUBROUTINE1:
02847     case FFESTV_stateSUBROUTINE2:
02848     case FFESTV_stateSUBROUTINE3:
02849       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
02850       update = TRUE;
02851       break;
02852 
02853     case FFESTV_stateFUNCTION0:
02854     case FFESTV_stateFUNCTION1:
02855     case FFESTV_stateFUNCTION2:
02856     case FFESTV_stateFUNCTION3:
02857       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
02858       update = TRUE;
02859       break;
02860 
02861     case FFESTV_statePROGRAM4:
02862     case FFESTV_stateSUBROUTINE4:
02863     case FFESTV_stateFUNCTION4:
02864       update = FALSE;
02865       break;
02866 
02867     case FFESTV_stateIFTHEN:
02868     case FFESTV_stateDO:
02869     case FFESTV_stateSELECT1:
02870       return FFESTC_orderOK_;
02871 
02872     case FFESTV_stateUSE:
02873 #if FFESTR_F90
02874       ffestc_shriek_end_uses_ (TRUE);
02875 #endif
02876       goto recurse;   /* :::::::::::::::::::: */
02877 
02878     case FFESTV_stateWHERE:
02879       ffestc_order_bad_ ();
02880 #if FFESTR_F90
02881       ffestc_shriek_where_ (FALSE);
02882 #endif
02883       return FFESTC_orderBAD_;
02884 
02885     case FFESTV_stateIF:
02886       ffestc_order_bad_ ();
02887       ffestc_shriek_if_ (FALSE);
02888       return FFESTC_orderBAD_;
02889 
02890     default:
02891       ffestc_order_bad_ ();
02892       return FFESTC_orderBAD_;
02893     }
02894 
02895   switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
02896     {
02897     case FFESTV_stateINTERFACE0:
02898       ffestc_order_bad_ ();
02899       if (update)
02900   ffestw_update (NULL);
02901       return FFESTC_orderBAD_;
02902 
02903     default:
02904       if (update)
02905   ffestw_update (NULL);
02906       return FFESTC_orderOK_;
02907     }
02908 }
02909 
02910 /* ffestc_order_format_ -- Check ordering on FORMAT statement
02911 
02912    if (ffestc_order_format_() != FFESTC_orderOK_)
02913        return;  */
02914 
02915 static ffestcOrder_
02916 ffestc_order_format_ ()
02917 {
02918   recurse:
02919 
02920   switch (ffestw_state (ffestw_stack_top ()))
02921     {
02922     case FFESTV_stateNIL:
02923       ffestc_shriek_begin_program_ ();
02924       goto recurse;   /* :::::::::::::::::::: */
02925 
02926     case FFESTV_statePROGRAM0:
02927       ffestw_update (NULL);
02928       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
02929       return FFESTC_orderOK_;
02930 
02931     case FFESTV_stateSUBROUTINE0:
02932       ffestw_update (NULL);
02933       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
02934       return FFESTC_orderOK_;
02935 
02936     case FFESTV_stateFUNCTION0:
02937       ffestw_update (NULL);
02938       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
02939       return FFESTC_orderOK_;
02940 
02941     case FFESTV_statePROGRAM1:
02942     case FFESTV_statePROGRAM2:
02943     case FFESTV_stateSUBROUTINE1:
02944     case FFESTV_stateSUBROUTINE2:
02945     case FFESTV_stateFUNCTION1:
02946     case FFESTV_stateFUNCTION2:
02947     case FFESTV_statePROGRAM3:
02948     case FFESTV_stateSUBROUTINE3:
02949     case FFESTV_stateFUNCTION3:
02950     case FFESTV_statePROGRAM4:
02951     case FFESTV_stateSUBROUTINE4:
02952     case FFESTV_stateFUNCTION4:
02953     case FFESTV_stateWHERETHEN:
02954     case FFESTV_stateIFTHEN:
02955     case FFESTV_stateDO:
02956     case FFESTV_stateSELECT0:
02957     case FFESTV_stateSELECT1:
02958       return FFESTC_orderOK_;
02959 
02960     case FFESTV_stateUSE:
02961 #if FFESTR_F90
02962       ffestc_shriek_end_uses_ (TRUE);
02963 #endif
02964       goto recurse;   /* :::::::::::::::::::: */
02965 
02966     case FFESTV_stateWHERE:
02967       ffestc_order_bad_ ();
02968 #if FFESTR_F90
02969       ffestc_shriek_where_ (FALSE);
02970 #endif
02971       return FFESTC_orderBAD_;
02972 
02973     case FFESTV_stateIF:
02974       ffestc_order_bad_ ();
02975       ffestc_shriek_if_ (FALSE);
02976       return FFESTC_orderBAD_;
02977 
02978     default:
02979       ffestc_order_bad_ ();
02980       return FFESTC_orderBAD_;
02981     }
02982 }
02983 
02984 /* ffestc_order_function_ -- Check ordering on <function> statement
02985 
02986    if (ffestc_order_function_() != FFESTC_orderOK_)
02987        return;  */
02988 
02989 static ffestcOrder_
02990 ffestc_order_function_ ()
02991 {
02992   recurse:
02993 
02994   switch (ffestw_state (ffestw_stack_top ()))
02995     {
02996     case FFESTV_stateFUNCTION0:
02997     case FFESTV_stateFUNCTION1:
02998     case FFESTV_stateFUNCTION2:
02999     case FFESTV_stateFUNCTION3:
03000     case FFESTV_stateFUNCTION4:
03001     case FFESTV_stateFUNCTION5:
03002       return FFESTC_orderOK_;
03003 
03004     case FFESTV_stateUSE:
03005 #if FFESTR_F90
03006       ffestc_shriek_end_uses_ (TRUE);
03007 #endif
03008       goto recurse;   /* :::::::::::::::::::: */
03009 
03010     case FFESTV_stateWHERE:
03011       ffestc_order_bad_ ();
03012 #if FFESTR_F90
03013       ffestc_shriek_where_ (FALSE);
03014 #endif
03015       return FFESTC_orderBAD_;
03016 
03017     case FFESTV_stateIF:
03018       ffestc_order_bad_ ();
03019       ffestc_shriek_if_ (FALSE);
03020       return FFESTC_orderBAD_;
03021 
03022     default:
03023       ffestc_order_bad_ ();
03024       return FFESTC_orderBAD_;
03025     }
03026 }
03027 
03028 /* ffestc_order_iface_ -- Check ordering on <iface> statement
03029 
03030    if (ffestc_order_iface_() != FFESTC_orderOK_)
03031        return;  */
03032 
03033 static ffestcOrder_
03034 ffestc_order_iface_ ()
03035 {
03036   switch (ffestw_state (ffestw_stack_top ()))
03037     {
03038     case FFESTV_stateNIL:
03039     case FFESTV_statePROGRAM5:
03040     case FFESTV_stateSUBROUTINE5:
03041     case FFESTV_stateFUNCTION5:
03042     case FFESTV_stateMODULE5:
03043     case FFESTV_stateINTERFACE0:
03044       return FFESTC_orderOK_;
03045 
03046     case FFESTV_stateWHERE:
03047       ffestc_order_bad_ ();
03048 #if FFESTR_F90
03049       ffestc_shriek_where_ (FALSE);
03050 #endif
03051       return FFESTC_orderBAD_;
03052 
03053     case FFESTV_stateIF:
03054       ffestc_order_bad_ ();
03055       ffestc_shriek_if_ (FALSE);
03056       return FFESTC_orderBAD_;
03057 
03058     default:
03059       ffestc_order_bad_ ();
03060       return FFESTC_orderBAD_;
03061     }
03062 }
03063 
03064 /* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement
03065 
03066    if (ffestc_order_ifthen_() != FFESTC_orderOK_)
03067        return;  */
03068 
03069 static ffestcOrder_
03070 ffestc_order_ifthen_ ()
03071 {
03072   switch (ffestw_state (ffestw_stack_top ()))
03073     {
03074     case FFESTV_stateIFTHEN:
03075       return FFESTC_orderOK_;
03076 
03077     case FFESTV_stateWHERE:
03078       ffestc_order_bad_ ();
03079 #if FFESTR_F90
03080       ffestc_shriek_where_ (FALSE);
03081 #endif
03082       return FFESTC_orderBAD_;
03083 
03084     case FFESTV_stateIF:
03085       ffestc_order_bad_ ();
03086       ffestc_shriek_if_ (FALSE);
03087       return FFESTC_orderBAD_;
03088 
03089     default:
03090       ffestc_order_bad_ ();
03091       return FFESTC_orderBAD_;
03092     }
03093 }
03094 
03095 /* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement
03096 
03097    if (ffestc_order_implicit_() != FFESTC_orderOK_)
03098        return;  */
03099 
03100 static ffestcOrder_
03101 ffestc_order_implicit_ ()
03102 {
03103   recurse:
03104 
03105   switch (ffestw_state (ffestw_stack_top ()))
03106     {
03107     case FFESTV_stateNIL:
03108       ffestc_shriek_begin_program_ ();
03109       goto recurse;   /* :::::::::::::::::::: */
03110 
03111     case FFESTV_statePROGRAM0:
03112     case FFESTV_statePROGRAM1:
03113       ffestw_update (NULL);
03114       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
03115       return FFESTC_orderOK_;
03116 
03117     case FFESTV_stateSUBROUTINE0:
03118     case FFESTV_stateSUBROUTINE1:
03119       ffestw_update (NULL);
03120       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
03121       return FFESTC_orderOK_;
03122 
03123     case FFESTV_stateFUNCTION0:
03124     case FFESTV_stateFUNCTION1:
03125       ffestw_update (NULL);
03126       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
03127       return FFESTC_orderOK_;
03128 
03129     case FFESTV_stateMODULE0:
03130     case FFESTV_stateMODULE1:
03131       ffestw_update (NULL);
03132       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
03133       return FFESTC_orderOK_;
03134 
03135     case FFESTV_stateBLOCKDATA0:
03136     case FFESTV_stateBLOCKDATA1:
03137       ffestw_update (NULL);
03138       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
03139       return FFESTC_orderOK_;
03140 
03141     case FFESTV_statePROGRAM2:
03142     case FFESTV_stateSUBROUTINE2:
03143     case FFESTV_stateFUNCTION2:
03144     case FFESTV_stateMODULE2:
03145     case FFESTV_stateBLOCKDATA2:
03146       return FFESTC_orderOK_;
03147 
03148     case FFESTV_stateUSE:
03149 #if FFESTR_F90
03150       ffestc_shriek_end_uses_ (TRUE);
03151 #endif
03152       goto recurse;   /* :::::::::::::::::::: */
03153 
03154     case FFESTV_stateWHERE:
03155       ffestc_order_bad_ ();
03156 #if FFESTR_F90
03157       ffestc_shriek_where_ (FALSE);
03158 #endif
03159       return FFESTC_orderBAD_;
03160 
03161     case FFESTV_stateIF:
03162       ffestc_order_bad_ ();
03163       ffestc_shriek_if_ (FALSE);
03164       return FFESTC_orderBAD_;
03165 
03166     default:
03167       ffestc_order_bad_ ();
03168       return FFESTC_orderBAD_;
03169     }
03170 }
03171 
03172 /* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement
03173 
03174    if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
03175        return;  */
03176 
03177 static ffestcOrder_
03178 ffestc_order_implicitnone_ ()
03179 {
03180   recurse:
03181 
03182   switch (ffestw_state (ffestw_stack_top ()))
03183     {
03184     case FFESTV_stateNIL:
03185       ffestc_shriek_begin_program_ ();
03186       goto recurse;   /* :::::::::::::::::::: */
03187 
03188     case FFESTV_statePROGRAM0:
03189     case FFESTV_statePROGRAM1:
03190       ffestw_update (NULL);
03191       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
03192       return FFESTC_orderOK_;
03193 
03194     case FFESTV_stateSUBROUTINE0:
03195     case FFESTV_stateSUBROUTINE1:
03196       ffestw_update (NULL);
03197       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
03198       return FFESTC_orderOK_;
03199 
03200     case FFESTV_stateFUNCTION0:
03201     case FFESTV_stateFUNCTION1:
03202       ffestw_update (NULL);
03203       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
03204       return FFESTC_orderOK_;
03205 
03206     case FFESTV_stateMODULE0:
03207     case FFESTV_stateMODULE1:
03208       ffestw_update (NULL);
03209       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
03210       return FFESTC_orderOK_;
03211 
03212     case FFESTV_stateBLOCKDATA0:
03213     case FFESTV_stateBLOCKDATA1:
03214       ffestw_update (NULL);
03215       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
03216       return FFESTC_orderOK_;
03217 
03218     case FFESTV_stateUSE:
03219 #if FFESTR_F90
03220       ffestc_shriek_end_uses_ (TRUE);
03221 #endif
03222       goto recurse;   /* :::::::::::::::::::: */
03223 
03224     case FFESTV_stateWHERE:
03225       ffestc_order_bad_ ();
03226 #if FFESTR_F90
03227       ffestc_shriek_where_ (FALSE);
03228 #endif
03229       return FFESTC_orderBAD_;
03230 
03231     case FFESTV_stateIF:
03232       ffestc_order_bad_ ();
03233       ffestc_shriek_if_ (FALSE);
03234       return FFESTC_orderBAD_;
03235 
03236     default:
03237       ffestc_order_bad_ ();
03238       return FFESTC_orderBAD_;
03239     }
03240 }
03241 
03242 /* ffestc_order_interface_ -- Check ordering on <interface> statement
03243 
03244    if (ffestc_order_interface_() != FFESTC_orderOK_)
03245        return;  */
03246 
03247 #if FFESTR_F90
03248 static ffestcOrder_
03249 ffestc_order_interface_ ()
03250 {
03251   switch (ffestw_state (ffestw_stack_top ()))
03252     {
03253     case FFESTV_stateINTERFACE0:
03254     case FFESTV_stateINTERFACE1:
03255       return FFESTC_orderOK_;
03256 
03257     case FFESTV_stateWHERE:
03258       ffestc_order_bad_ ();
03259       ffestc_shriek_where_ (FALSE);
03260       return FFESTC_orderBAD_;
03261 
03262     case FFESTV_stateIF:
03263       ffestc_order_bad_ ();
03264       ffestc_shriek_if_ (FALSE);
03265       return FFESTC_orderBAD_;
03266 
03267     default:
03268       ffestc_order_bad_ ();
03269       return FFESTC_orderBAD_;
03270     }
03271 }
03272 
03273 #endif
03274 /* ffestc_order_map_ -- Check ordering on <map> statement
03275 
03276    if (ffestc_order_map_() != FFESTC_orderOK_)
03277        return;  */
03278 
03279 #if FFESTR_VXT
03280 static ffestcOrder_
03281 ffestc_order_map_ ()
03282 {
03283   switch (ffestw_state (ffestw_stack_top ()))
03284     {
03285     case FFESTV_stateMAP:
03286       return FFESTC_orderOK_;
03287 
03288     case FFESTV_stateWHERE:
03289       ffestc_order_bad_ ();
03290       ffestc_shriek_where_ (FALSE);
03291       return FFESTC_orderBAD_;
03292 
03293     case FFESTV_stateIF:
03294       ffestc_order_bad_ ();
03295       ffestc_shriek_if_ (FALSE);
03296       return FFESTC_orderBAD_;
03297 
03298     default:
03299       ffestc_order_bad_ ();
03300       return FFESTC_orderBAD_;
03301     }
03302 }
03303 
03304 #endif
03305 /* ffestc_order_module_ -- Check ordering on <module> statement
03306 
03307    if (ffestc_order_module_() != FFESTC_orderOK_)
03308        return;  */
03309 
03310 #if FFESTR_F90
03311 static ffestcOrder_
03312 ffestc_order_module_ ()
03313 {
03314   recurse:
03315 
03316   switch (ffestw_state (ffestw_stack_top ()))
03317     {
03318     case FFESTV_stateMODULE0:
03319     case FFESTV_stateMODULE1:
03320     case FFESTV_stateMODULE2:
03321     case FFESTV_stateMODULE3:
03322     case FFESTV_stateMODULE4:
03323     case FFESTV_stateMODULE5:
03324       return FFESTC_orderOK_;
03325 
03326     case FFESTV_stateUSE:
03327       ffestc_shriek_end_uses_ (TRUE);
03328       goto recurse;   /* :::::::::::::::::::: */
03329 
03330     case FFESTV_stateWHERE:
03331       ffestc_order_bad_ ();
03332       ffestc_shriek_where_ (FALSE);
03333       return FFESTC_orderBAD_;
03334 
03335     case FFESTV_stateIF:
03336       ffestc_order_bad_ ();
03337       ffestc_shriek_if_ (FALSE);
03338       return FFESTC_orderBAD_;
03339 
03340     default:
03341       ffestc_order_bad_ ();
03342       return FFESTC_orderBAD_;
03343     }
03344 }
03345 
03346 #endif
03347 /* ffestc_order_parameter_ -- Check ordering on <parameter> statement
03348 
03349    if (ffestc_order_parameter_() != FFESTC_orderOK_)
03350        return;  */
03351 
03352 static ffestcOrder_
03353 ffestc_order_parameter_ ()
03354 {
03355   recurse:
03356 
03357   switch (ffestw_state (ffestw_stack_top ()))
03358     {
03359     case FFESTV_stateNIL:
03360       ffestc_shriek_begin_program_ ();
03361       goto recurse;   /* :::::::::::::::::::: */
03362 
03363     case FFESTV_statePROGRAM0:
03364     case FFESTV_statePROGRAM1:
03365       ffestw_update (NULL);
03366       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
03367       return FFESTC_orderOK_;
03368 
03369     case FFESTV_stateSUBROUTINE0:
03370     case FFESTV_stateSUBROUTINE1:
03371       ffestw_update (NULL);
03372       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
03373       return FFESTC_orderOK_;
03374 
03375     case FFESTV_stateFUNCTION0:
03376     case FFESTV_stateFUNCTION1:
03377       ffestw_update (NULL);
03378       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
03379       return FFESTC_orderOK_;
03380 
03381     case FFESTV_stateMODULE0:
03382     case FFESTV_stateMODULE1:
03383       ffestw_update (NULL);
03384       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
03385       return FFESTC_orderOK_;
03386 
03387     case FFESTV_stateBLOCKDATA0:
03388     case FFESTV_stateBLOCKDATA1:
03389       ffestw_update (NULL);
03390       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
03391       return FFESTC_orderOK_;
03392 
03393     case FFESTV_statePROGRAM2:
03394     case FFESTV_stateSUBROUTINE2:
03395     case FFESTV_stateFUNCTION2:
03396     case FFESTV_stateMODULE2:
03397     case FFESTV_stateBLOCKDATA2:
03398     case FFESTV_statePROGRAM3:
03399     case FFESTV_stateSUBROUTINE3:
03400     case FFESTV_stateFUNCTION3:
03401     case FFESTV_stateMODULE3:
03402     case FFESTV_stateBLOCKDATA3:
03403     case FFESTV_stateTYPE:  /* GNU extension here! */
03404     case FFESTV_stateSTRUCTURE:
03405     case FFESTV_stateUNION:
03406     case FFESTV_stateMAP:
03407       return FFESTC_orderOK_;
03408 
03409     case FFESTV_stateUSE:
03410 #if FFESTR_F90
03411       ffestc_shriek_end_uses_ (TRUE);
03412 #endif
03413       goto recurse;   /* :::::::::::::::::::: */
03414 
03415     case FFESTV_stateWHERE:
03416       ffestc_order_bad_ ();
03417 #if FFESTR_F90
03418       ffestc_shriek_where_ (FALSE);
03419 #endif
03420       return FFESTC_orderBAD_;
03421 
03422     case FFESTV_stateIF:
03423       ffestc_order_bad_ ();
03424       ffestc_shriek_if_ (FALSE);
03425       return FFESTC_orderBAD_;
03426 
03427     default:
03428       ffestc_order_bad_ ();
03429       return FFESTC_orderBAD_;
03430     }
03431 }
03432 
03433 /* ffestc_order_program_ -- Check ordering on <program> statement
03434 
03435    if (ffestc_order_program_() != FFESTC_orderOK_)
03436        return;  */
03437 
03438 static ffestcOrder_
03439 ffestc_order_program_ ()
03440 {
03441   recurse:
03442 
03443   switch (ffestw_state (ffestw_stack_top ()))
03444     {
03445     case FFESTV_stateNIL:
03446       ffestc_shriek_begin_program_ ();
03447       goto recurse;   /* :::::::::::::::::::: */
03448 
03449     case FFESTV_statePROGRAM0:
03450     case FFESTV_statePROGRAM1:
03451     case FFESTV_statePROGRAM2:
03452     case FFESTV_statePROGRAM3:
03453     case FFESTV_statePROGRAM4:
03454     case FFESTV_statePROGRAM5:
03455       return FFESTC_orderOK_;
03456 
03457     case FFESTV_stateUSE:
03458 #if FFESTR_F90
03459       ffestc_shriek_end_uses_ (TRUE);
03460 #endif
03461       goto recurse;   /* :::::::::::::::::::: */
03462 
03463     case FFESTV_stateWHERE:
03464       ffestc_order_bad_ ();
03465 #if FFESTR_F90
03466       ffestc_shriek_where_ (FALSE);
03467 #endif
03468       return FFESTC_orderBAD_;
03469 
03470     case FFESTV_stateIF:
03471       ffestc_order_bad_ ();
03472       ffestc_shriek_if_ (FALSE);
03473       return FFESTC_orderBAD_;
03474 
03475     default:
03476       ffestc_order_bad_ ();
03477       return FFESTC_orderBAD_;
03478     }
03479 }
03480 
03481 /* ffestc_order_progspec_ -- Check ordering on <progspec> statement
03482 
03483    if (ffestc_order_progspec_() != FFESTC_orderOK_)
03484        return;  */
03485 
03486 static ffestcOrder_
03487 ffestc_order_progspec_ ()
03488 {
03489   recurse:
03490 
03491   switch (ffestw_state (ffestw_stack_top ()))
03492     {
03493     case FFESTV_stateNIL:
03494       ffestc_shriek_begin_program_ ();
03495       goto recurse;   /* :::::::::::::::::::: */
03496 
03497     case FFESTV_statePROGRAM0:
03498     case FFESTV_statePROGRAM1:
03499     case FFESTV_statePROGRAM2:
03500       ffestw_update (NULL);
03501       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
03502       return FFESTC_orderOK_;
03503 
03504     case FFESTV_stateSUBROUTINE0:
03505     case FFESTV_stateSUBROUTINE1:
03506     case FFESTV_stateSUBROUTINE2:
03507       ffestw_update (NULL);
03508       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
03509       return FFESTC_orderOK_;
03510 
03511     case FFESTV_stateFUNCTION0:
03512     case FFESTV_stateFUNCTION1:
03513     case FFESTV_stateFUNCTION2:
03514       ffestw_update (NULL);
03515       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
03516       return FFESTC_orderOK_;
03517 
03518     case FFESTV_stateMODULE0:
03519     case FFESTV_stateMODULE1:
03520     case FFESTV_stateMODULE2:
03521       ffestw_update (NULL);
03522       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
03523       return FFESTC_orderOK_;
03524 
03525     case FFESTV_statePROGRAM3:
03526     case FFESTV_stateSUBROUTINE3:
03527     case FFESTV_stateFUNCTION3:
03528     case FFESTV_stateMODULE3:
03529       return FFESTC_orderOK_;
03530 
03531     case FFESTV_stateBLOCKDATA0:
03532     case FFESTV_stateBLOCKDATA1:
03533     case FFESTV_stateBLOCKDATA2:
03534       ffestw_update (NULL);
03535       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
03536       if (ffe_is_pedantic ())
03537   {
03538     ffebad_start (FFEBAD_BLOCKDATA_STMT);
03539     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
03540            ffelex_token_where_column (ffesta_tokens[0]));
03541     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
03542     ffebad_finish ();
03543   }
03544       return FFESTC_orderOK_;
03545 
03546     case FFESTV_stateUSE:
03547 #if FFESTR_F90
03548       ffestc_shriek_end_uses_ (TRUE);
03549 #endif
03550       goto recurse;   /* :::::::::::::::::::: */
03551 
03552     case FFESTV_stateWHERE:
03553       ffestc_order_bad_ ();
03554 #if FFESTR_F90
03555       ffestc_shriek_where_ (FALSE);
03556 #endif
03557       return FFESTC_orderBAD_;
03558 
03559     case FFESTV_stateIF:
03560       ffestc_order_bad_ ();
03561       ffestc_shriek_if_ (FALSE);
03562       return FFESTC_orderBAD_;
03563 
03564     default:
03565       ffestc_order_bad_ ();
03566       return FFESTC_orderBAD_;
03567     }
03568 }
03569 
03570 /* ffestc_order_record_ -- Check ordering on RECORD statement
03571 
03572    if (ffestc_order_record_() != FFESTC_orderOK_)
03573        return;  */
03574 
03575 #if FFESTR_VXT
03576 static ffestcOrder_
03577 ffestc_order_record_ ()
03578 {
03579   recurse:
03580 
03581   switch (ffestw_state (ffestw_stack_top ()))
03582     {
03583     case FFESTV_stateNIL:
03584       ffestc_shriek_begin_program_ ();
03585       goto recurse;   /* :::::::::::::::::::: */
03586 
03587     case FFESTV_statePROGRAM0:
03588     case FFESTV_statePROGRAM1:
03589     case FFESTV_statePROGRAM2:
03590       ffestw_update (NULL);
03591       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
03592       return FFESTC_orderOK_;
03593 
03594     case FFESTV_stateSUBROUTINE0:
03595     case FFESTV_stateSUBROUTINE1:
03596     case FFESTV_stateSUBROUTINE2:
03597       ffestw_update (NULL);
03598       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
03599       return FFESTC_orderOK_;
03600 
03601     case FFESTV_stateFUNCTION0:
03602     case FFESTV_stateFUNCTION1:
03603     case FFESTV_stateFUNCTION2:
03604       ffestw_update (NULL);
03605       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
03606       return FFESTC_orderOK_;
03607 
03608     case FFESTV_stateMODULE0:
03609     case FFESTV_stateMODULE1:
03610     case FFESTV_stateMODULE2:
03611       ffestw_update (NULL);
03612       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
03613       return FFESTC_orderOK_;
03614 
03615     case FFESTV_stateBLOCKDATA0:
03616     case FFESTV_stateBLOCKDATA1:
03617     case FFESTV_stateBLOCKDATA2:
03618       ffestw_update (NULL);
03619       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
03620       return FFESTC_orderOK_;
03621 
03622     case FFESTV_statePROGRAM3:
03623     case FFESTV_stateSUBROUTINE3:
03624     case FFESTV_stateFUNCTION3:
03625     case FFESTV_stateMODULE3:
03626     case FFESTV_stateBLOCKDATA3:
03627     case FFESTV_stateSTRUCTURE:
03628     case FFESTV_stateMAP:
03629       return FFESTC_orderOK_;
03630 
03631     case FFESTV_stateUSE:
03632 #if FFESTR_F90
03633       ffestc_shriek_end_uses_ (TRUE);
03634 #endif
03635       goto recurse;   /* :::::::::::::::::::: */
03636 
03637     case FFESTV_stateWHERE:
03638       ffestc_order_bad_ ();
03639 #if FFESTR_F90
03640       ffestc_shriek_where_ (FALSE);
03641 #endif
03642       return FFESTC_orderBAD_;
03643 
03644     case FFESTV_stateIF:
03645       ffestc_order_bad_ ();
03646       ffestc_shriek_if_ (FALSE);
03647       return FFESTC_orderBAD_;
03648 
03649     default:
03650       ffestc_order_bad_ ();
03651       return FFESTC_orderBAD_;
03652     }
03653 }
03654 
03655 #endif
03656 /* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
03657 
03658    if (ffestc_order_selectcase_() != FFESTC_orderOK_)
03659        return;  */
03660 
03661 static ffestcOrder_
03662 ffestc_order_selectcase_ ()
03663 {
03664   switch (ffestw_state (ffestw_stack_top ()))
03665     {
03666     case FFESTV_stateSELECT0:
03667     case FFESTV_stateSELECT1:
03668       return FFESTC_orderOK_;
03669 
03670     case FFESTV_stateWHERE:
03671       ffestc_order_bad_ ();
03672 #if FFESTR_F90
03673       ffestc_shriek_where_ (FALSE);
03674 #endif
03675       return FFESTC_orderBAD_;
03676 
03677     case FFESTV_stateIF:
03678       ffestc_order_bad_ ();
03679       ffestc_shriek_if_ (FALSE);
03680       return FFESTC_orderBAD_;
03681 
03682     default:
03683       ffestc_order_bad_ ();
03684       return FFESTC_orderBAD_;
03685     }
03686 }
03687 
03688 /* ffestc_order_sfunc_ -- Check ordering on statement-function definition
03689 
03690    if (ffestc_order_sfunc_() != FFESTC_orderOK_)
03691        return;  */
03692 
03693 static ffestcOrder_
03694 ffestc_order_sfunc_ ()
03695 {
03696   recurse:
03697 
03698   switch (ffestw_state (ffestw_stack_top ()))
03699     {
03700     case FFESTV_stateNIL:
03701       ffestc_shriek_begin_program_ ();
03702       goto recurse;   /* :::::::::::::::::::: */
03703 
03704     case FFESTV_statePROGRAM0:
03705     case FFESTV_statePROGRAM1:
03706     case FFESTV_statePROGRAM2:
03707       ffestw_update (NULL);
03708       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
03709       return FFESTC_orderOK_;
03710 
03711     case FFESTV_stateSUBROUTINE0:
03712     case FFESTV_stateSUBROUTINE1:
03713     case FFESTV_stateSUBROUTINE2:
03714       ffestw_update (NULL);
03715       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
03716       return FFESTC_orderOK_;
03717 
03718     case FFESTV_stateFUNCTION0:
03719     case FFESTV_stateFUNCTION1:
03720     case FFESTV_stateFUNCTION2:
03721       ffestw_update (NULL);
03722       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
03723       return FFESTC_orderOK_;
03724 
03725     case FFESTV_statePROGRAM3:
03726     case FFESTV_stateSUBROUTINE3:
03727     case FFESTV_stateFUNCTION3:
03728       return FFESTC_orderOK_;
03729 
03730     case FFESTV_stateUSE:
03731 #if FFESTR_F90
03732       ffestc_shriek_end_uses_ (TRUE);
03733 #endif
03734       goto recurse;   /* :::::::::::::::::::: */
03735 
03736     case FFESTV_stateWHERE:
03737       ffestc_order_bad_ ();
03738 #if FFESTR_F90
03739       ffestc_shriek_where_ (FALSE);
03740 #endif
03741       return FFESTC_orderBAD_;
03742 
03743     case FFESTV_stateIF:
03744       ffestc_order_bad_ ();
03745       ffestc_shriek_if_ (FALSE);
03746       return FFESTC_orderBAD_;
03747 
03748     default:
03749       ffestc_order_bad_ ();
03750       return FFESTC_orderBAD_;
03751     }
03752 }
03753 
03754 /* ffestc_order_spec_ -- Check ordering on <spec> statement
03755 
03756    if (ffestc_order_spec_() != FFESTC_orderOK_)
03757        return;  */
03758 
03759 #if FFESTR_F90
03760 static ffestcOrder_
03761 ffestc_order_spec_ ()
03762 {
03763   recurse:
03764 
03765   switch (ffestw_state (ffestw_stack_top ()))
03766     {
03767     case FFESTV_stateNIL:
03768       ffestc_shriek_begin_program_ ();
03769       goto recurse;   /* :::::::::::::::::::: */
03770 
03771     case FFESTV_stateSUBROUTINE0:
03772     case FFESTV_stateSUBROUTINE1:
03773     case FFESTV_stateSUBROUTINE2:
03774       ffestw_update (NULL);
03775       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
03776       return FFESTC_orderOK_;
03777 
03778     case FFESTV_stateFUNCTION0:
03779     case FFESTV_stateFUNCTION1:
03780     case FFESTV_stateFUNCTION2:
03781       ffestw_update (NULL);
03782       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
03783       return FFESTC_orderOK_;
03784 
03785     case FFESTV_stateMODULE0:
03786     case FFESTV_stateMODULE1:
03787     case FFESTV_stateMODULE2:
03788       ffestw_update (NULL);
03789       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
03790       return FFESTC_orderOK_;
03791 
03792     case FFESTV_stateSUBROUTINE3:
03793     case FFESTV_stateFUNCTION3:
03794     case FFESTV_stateMODULE3:
03795       return FFESTC_orderOK_;
03796 
03797     case FFESTV_stateUSE:
03798 #if FFESTR_F90
03799       ffestc_shriek_end_uses_ (TRUE);
03800 #endif
03801       goto recurse;   /* :::::::::::::::::::: */
03802 
03803     case FFESTV_stateWHERE:
03804       ffestc_order_bad_ ();
03805 #if FFESTR_F90
03806       ffestc_shriek_where_ (FALSE);
03807 #endif
03808       return FFESTC_orderBAD_;
03809 
03810     case FFESTV_stateIF:
03811       ffestc_order_bad_ ();
03812       ffestc_shriek_if_ (FALSE);
03813       return FFESTC_orderBAD_;
03814 
03815     default:
03816       ffestc_order_bad_ ();
03817       return FFESTC_orderBAD_;
03818     }
03819 }
03820 
03821 #endif
03822 /* ffestc_order_structure_ -- Check ordering on <structure> statement
03823 
03824    if (ffestc_order_structure_() != FFESTC_orderOK_)
03825        return;  */
03826 
03827 #if FFESTR_VXT
03828 static ffestcOrder_
03829 ffestc_order_structure_ ()
03830 {
03831   switch (ffestw_state (ffestw_stack_top ()))
03832     {
03833     case FFESTV_stateSTRUCTURE:
03834       return FFESTC_orderOK_;
03835 
03836     case FFESTV_stateWHERE:
03837       ffestc_order_bad_ ();
03838 #if FFESTR_F90
03839       ffestc_shriek_where_ (FALSE);
03840 #endif
03841       return FFESTC_orderBAD_;
03842 
03843     case FFESTV_stateIF:
03844       ffestc_order_bad_ ();
03845       ffestc_shriek_if_ (FALSE);
03846       return FFESTC_orderBAD_;
03847 
03848     default:
03849       ffestc_order_bad_ ();
03850       return FFESTC_orderBAD_;
03851     }
03852 }
03853 
03854 #endif
03855 /* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
03856 
03857    if (ffestc_order_subroutine_() != FFESTC_orderOK_)
03858        return;  */
03859 
03860 static ffestcOrder_
03861 ffestc_order_subroutine_ ()
03862 {
03863   recurse:
03864 
03865   switch (ffestw_state (ffestw_stack_top ()))
03866     {
03867     case FFESTV_stateSUBROUTINE0:
03868     case FFESTV_stateSUBROUTINE1:
03869     case FFESTV_stateSUBROUTINE2:
03870     case FFESTV_stateSUBROUTINE3:
03871     case FFESTV_stateSUBROUTINE4:
03872     case FFESTV_stateSUBROUTINE5:
03873       return FFESTC_orderOK_;
03874 
03875     case FFESTV_stateUSE:
03876 #if FFESTR_F90
03877       ffestc_shriek_end_uses_ (TRUE);
03878 #endif
03879       goto recurse;   /* :::::::::::::::::::: */
03880 
03881     case FFESTV_stateWHERE:
03882       ffestc_order_bad_ ();
03883 #if FFESTR_F90
03884       ffestc_shriek_where_ (FALSE);
03885 #endif
03886       return FFESTC_orderBAD_;
03887 
03888     case FFESTV_stateIF:
03889       ffestc_order_bad_ ();
03890       ffestc_shriek_if_ (FALSE);
03891       return FFESTC_orderBAD_;
03892 
03893     default:
03894       ffestc_order_bad_ ();
03895       return FFESTC_orderBAD_;
03896     }
03897 }
03898 
03899 /* ffestc_order_type_ -- Check ordering on <type> statement
03900 
03901    if (ffestc_order_type_() != FFESTC_orderOK_)
03902        return;  */
03903 
03904 #if FFESTR_F90
03905 static ffestcOrder_
03906 ffestc_order_type_ ()
03907 {
03908   switch (ffestw_state (ffestw_stack_top ()))
03909     {
03910     case FFESTV_stateTYPE:
03911       return FFESTC_orderOK_;
03912 
03913     case FFESTV_stateWHERE:
03914       ffestc_order_bad_ ();
03915       ffestc_shriek_where_ (FALSE);
03916       return FFESTC_orderBAD_;
03917 
03918     case FFESTV_stateIF:
03919       ffestc_order_bad_ ();
03920       ffestc_shriek_if_ (FALSE);
03921       return FFESTC_orderBAD_;
03922 
03923     default:
03924       ffestc_order_bad_ ();
03925       return FFESTC_orderBAD_;
03926     }
03927 }
03928 
03929 #endif
03930 /* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
03931 
03932    if (ffestc_order_typedecl_() != FFESTC_orderOK_)
03933        return;  */
03934 
03935 static ffestcOrder_
03936 ffestc_order_typedecl_ ()
03937 {
03938   recurse:
03939 
03940   switch (ffestw_state (ffestw_stack_top ()))
03941     {
03942     case FFESTV_stateNIL:
03943       ffestc_shriek_begin_program_ ();
03944       goto recurse;   /* :::::::::::::::::::: */
03945 
03946     case FFESTV_statePROGRAM0:
03947     case FFESTV_statePROGRAM1:
03948     case FFESTV_statePROGRAM2:
03949       ffestw_update (NULL);
03950       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
03951       return FFESTC_orderOK_;
03952 
03953     case FFESTV_stateSUBROUTINE0:
03954     case FFESTV_stateSUBROUTINE1:
03955     case FFESTV_stateSUBROUTINE2:
03956       ffestw_update (NULL);
03957       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
03958       return FFESTC_orderOK_;
03959 
03960     case FFESTV_stateFUNCTION0:
03961     case FFESTV_stateFUNCTION1:
03962     case FFESTV_stateFUNCTION2:
03963       ffestw_update (NULL);
03964       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
03965       return FFESTC_orderOK_;
03966 
03967     case FFESTV_stateMODULE0:
03968     case FFESTV_stateMODULE1:
03969     case FFESTV_stateMODULE2:
03970       ffestw_update (NULL);
03971       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
03972       return FFESTC_orderOK_;
03973 
03974     case FFESTV_stateBLOCKDATA0:
03975     case FFESTV_stateBLOCKDATA1:
03976     case FFESTV_stateBLOCKDATA2:
03977       ffestw_update (NULL);
03978       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
03979       return FFESTC_orderOK_;
03980 
03981     case FFESTV_statePROGRAM3:
03982     case FFESTV_stateSUBROUTINE3:
03983     case FFESTV_stateFUNCTION3:
03984     case FFESTV_stateMODULE3:
03985     case FFESTV_stateBLOCKDATA3:
03986       return FFESTC_orderOK_;
03987 
03988     case FFESTV_stateUSE:
03989 #if FFESTR_F90
03990       ffestc_shriek_end_uses_ (TRUE);
03991 #endif
03992       goto recurse;   /* :::::::::::::::::::: */
03993 
03994     case FFESTV_stateWHERE:
03995       ffestc_order_bad_ ();
03996 #if FFESTR_F90
03997       ffestc_shriek_where_ (FALSE);
03998 #endif
03999       return FFESTC_orderBAD_;
04000 
04001     case FFESTV_stateIF:
04002       ffestc_order_bad_ ();
04003       ffestc_shriek_if_ (FALSE);
04004       return FFESTC_orderBAD_;
04005 
04006     default:
04007       ffestc_order_bad_ ();
04008       return FFESTC_orderBAD_;
04009     }
04010 }
04011 
04012 /* ffestc_order_union_ -- Check ordering on <union> statement
04013 
04014    if (ffestc_order_union_() != FFESTC_orderOK_)
04015        return;  */
04016 
04017 #if FFESTR_VXT
04018 static ffestcOrder_
04019 ffestc_order_union_ ()
04020 {
04021   switch (ffestw_state (ffestw_stack_top ()))
04022     {
04023     case FFESTV_stateUNION:
04024       return FFESTC_orderOK_;
04025 
04026     case FFESTV_stateWHERE:
04027       ffestc_order_bad_ ();
04028 #if FFESTR_F90
04029       ffestc_shriek_where_ (FALSE);
04030 #endif
04031       return FFESTC_orderBAD_;
04032 
04033     case FFESTV_stateIF:
04034       ffestc_order_bad_ ();
04035       ffestc_shriek_if_ (FALSE);
04036       return FFESTC_orderBAD_;
04037 
04038     default:
04039       ffestc_order_bad_ ();
04040       return FFESTC_orderBAD_;
04041     }
04042 }
04043 
04044 #endif
04045 /* ffestc_order_unit_ -- Check ordering on <unit> statement
04046 
04047    if (ffestc_order_unit_() != FFESTC_orderOK_)
04048        return;  */
04049 
04050 static ffestcOrder_
04051 ffestc_order_unit_ ()
04052 {
04053   switch (ffestw_state (ffestw_stack_top ()))
04054     {
04055     case FFESTV_stateNIL:
04056       return FFESTC_orderOK_;
04057 
04058     case FFESTV_stateWHERE:
04059       ffestc_order_bad_ ();
04060 #if FFESTR_F90
04061       ffestc_shriek_where_ (FALSE);
04062 #endif
04063       return FFESTC_orderBAD_;
04064 
04065     case FFESTV_stateIF:
04066       ffestc_order_bad_ ();
04067       ffestc_shriek_if_ (FALSE);
04068       return FFESTC_orderBAD_;
04069 
04070     default:
04071       ffestc_order_bad_ ();
04072       return FFESTC_orderBAD_;
04073     }
04074 }
04075 
04076 /* ffestc_order_use_ -- Check ordering on USE statement
04077 
04078    if (ffestc_order_use_() != FFESTC_orderOK_)
04079        return;  */
04080 
04081 #if FFESTR_F90
04082 static ffestcOrder_
04083 ffestc_order_use_ ()
04084 {
04085   recurse:
04086 
04087   switch (ffestw_state (ffestw_stack_top ()))
04088     {
04089     case FFESTV_stateNIL:
04090       ffestc_shriek_begin_program_ ();
04091       goto recurse;   /* :::::::::::::::::::: */
04092 
04093     case FFESTV_statePROGRAM0:
04094       ffestw_update (NULL);
04095       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
04096       ffestc_shriek_begin_uses_ ();
04097       goto recurse;   /* :::::::::::::::::::: */
04098 
04099     case FFESTV_stateSUBROUTINE0:
04100       ffestw_update (NULL);
04101       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
04102       ffestc_shriek_begin_uses_ ();
04103       goto recurse;   /* :::::::::::::::::::: */
04104 
04105     case FFESTV_stateFUNCTION0:
04106       ffestw_update (NULL);
04107       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
04108       ffestc_shriek_begin_uses_ ();
04109       goto recurse;   /* :::::::::::::::::::: */
04110 
04111     case FFESTV_stateMODULE0:
04112       ffestw_update (NULL);
04113       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1);
04114       ffestc_shriek_begin_uses_ ();
04115       goto recurse;   /* :::::::::::::::::::: */
04116 
04117     case FFESTV_stateUSE:
04118       return FFESTC_orderOK_;
04119 
04120     case FFESTV_stateWHERE:
04121       ffestc_order_bad_ ();
04122       ffestc_shriek_where_ (FALSE);
04123       return FFESTC_orderBAD_;
04124 
04125     case FFESTV_stateIF:
04126       ffestc_order_bad_ ();
04127       ffestc_shriek_if_ (FALSE);
04128       return FFESTC_orderBAD_;
04129 
04130     default:
04131       ffestc_order_bad_ ();
04132       return FFESTC_orderBAD_;
04133     }
04134 }
04135 
04136 #endif
04137 /* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement
04138 
04139    if (ffestc_order_vxtstructure_() != FFESTC_orderOK_)
04140        return;  */
04141 
04142 #if FFESTR_VXT
04143 static ffestcOrder_
04144 ffestc_order_vxtstructure_ ()
04145 {
04146   recurse:
04147 
04148   switch (ffestw_state (ffestw_stack_top ()))
04149     {
04150     case FFESTV_stateNIL:
04151       ffestc_shriek_begin_program_ ();
04152       goto recurse;   /* :::::::::::::::::::: */
04153 
04154     case FFESTV_statePROGRAM0:
04155     case FFESTV_statePROGRAM1:
04156     case FFESTV_statePROGRAM2:
04157       ffestw_update (NULL);
04158       ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
04159       return FFESTC_orderOK_;
04160 
04161     case FFESTV_stateSUBROUTINE0:
04162     case FFESTV_stateSUBROUTINE1:
04163     case FFESTV_stateSUBROUTINE2:
04164       ffestw_update (NULL);
04165       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
04166       return FFESTC_orderOK_;
04167 
04168     case FFESTV_stateFUNCTION0:
04169     case FFESTV_stateFUNCTION1:
04170     case FFESTV_stateFUNCTION2:
04171       ffestw_update (NULL);
04172       ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
04173       return FFESTC_orderOK_;
04174 
04175     case FFESTV_stateMODULE0:
04176     case FFESTV_stateMODULE1:
04177     case FFESTV_stateMODULE2:
04178       ffestw_update (NULL);
04179       ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
04180       return FFESTC_orderOK_;
04181 
04182     case FFESTV_stateBLOCKDATA0:
04183     case FFESTV_stateBLOCKDATA1:
04184     case FFESTV_stateBLOCKDATA2:
04185       ffestw_update (NULL);
04186       ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
04187       return FFESTC_orderOK_;
04188 
04189     case FFESTV_statePROGRAM3:
04190     case FFESTV_stateSUBROUTINE3:
04191     case FFESTV_stateFUNCTION3:
04192     case FFESTV_stateMODULE3:
04193     case FFESTV_stateBLOCKDATA3:
04194     case FFESTV_stateSTRUCTURE:
04195     case FFESTV_stateMAP:
04196       return FFESTC_orderOK_;
04197 
04198     case FFESTV_stateUSE:
04199 #if FFESTR_F90
04200       ffestc_shriek_end_uses_ (TRUE);
04201 #endif
04202       goto recurse;   /* :::::::::::::::::::: */
04203 
04204     case FFESTV_stateWHERE:
04205       ffestc_order_bad_ ();
04206 #if FFESTR_F90
04207       ffestc_shriek_where_ (FALSE);
04208 #endif
04209       return FFESTC_orderBAD_;
04210 
04211     case FFESTV_stateIF:
04212       ffestc_order_bad_ ();
04213       ffestc_shriek_if_ (FALSE);
04214       return FFESTC_orderBAD_;
04215 
04216     default:
04217       ffestc_order_bad_ ();
04218       return FFESTC_orderBAD_;
04219     }
04220 }
04221 
04222 #endif
04223 /* ffestc_order_where_ -- Check ordering on <where> statement
04224 
04225    if (ffestc_order_where_() != FFESTC_orderOK_)
04226        return;  */
04227 
04228 #if FFESTR_F90
04229 static ffestcOrder_
04230 ffestc_order_where_ ()
04231 {
04232   switch (ffestw_state (ffestw_stack_top ()))
04233     {
04234     case FFESTV_stateWHERETHEN:
04235       return FFESTC_orderOK_;
04236 
04237     case FFESTV_stateWHERE:
04238       ffestc_order_bad_ ();
04239       ffestc_shriek_where_ (FALSE);
04240       return FFESTC_orderBAD_;
04241 
04242     case FFESTV_stateIF:
04243       ffestc_order_bad_ ();
04244       ffestc_shriek_if_ (FALSE);
04245       return FFESTC_orderBAD_;
04246 
04247     default:
04248       ffestc_order_bad_ ();
04249       return FFESTC_orderBAD_;
04250     }
04251 }
04252 
04253 #endif
04254 /* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
04255    ENTRY (prior to the first executable statement).  */
04256 
04257 static void
04258 ffestc_promote_dummy_ (ffelexToken t)
04259 {
04260   ffesymbol s;
04261   ffesymbolAttrs sa;
04262   ffesymbolAttrs na;
04263   ffebld e;
04264   bool sfref_ok;
04265 
04266   assert (t != NULL);
04267 
04268   if (ffelex_token_type (t) == FFELEX_typeASTERISK)
04269     {
04270       ffebld_append_item (&ffestc_local_.dummy.list_bottom,
04271         ffebld_new_star ());
04272       return;     /* Don't bother with alternate returns! */
04273     }
04274 
04275   s = ffesymbol_declare_local (t, FALSE);
04276   sa = ffesymbol_attrs (s);
04277 
04278   /* Figure out what kind of object we've got based on previous declarations
04279      of or references to the object. */
04280 
04281   sfref_ok = FALSE;
04282 
04283   if (sa & FFESYMBOL_attrsANY)
04284     na = sa;
04285   else if (sa & FFESYMBOL_attrsDUMMY)
04286     {
04287       if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
04288   {     /* Seen this one twice in this list! */
04289     na = FFESYMBOL_attrsetNONE;
04290   }
04291       else
04292   na = sa;
04293       sfref_ok = TRUE;    /* Ok for sym to be ref'd in sfuncdef
04294            previously, since already declared as a
04295            dummy arg. */
04296     }
04297   else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
04298         | FFESYMBOL_attrsADJUSTS
04299         | FFESYMBOL_attrsANY
04300         | FFESYMBOL_attrsANYLEN
04301         | FFESYMBOL_attrsANYSIZE
04302         | FFESYMBOL_attrsARRAY
04303         | FFESYMBOL_attrsDUMMY
04304         | FFESYMBOL_attrsEXTERNAL
04305         | FFESYMBOL_attrsSFARG
04306         | FFESYMBOL_attrsTYPE)))
04307     na = sa | FFESYMBOL_attrsDUMMY;
04308   else
04309     na = FFESYMBOL_attrsetNONE;
04310 
04311   if (!ffesymbol_is_specable (s)
04312       && (!sfref_ok
04313     || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
04314     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
04315 
04316   /* Now see what we've got for a new object: NONE means a new error cropped
04317      up; ANY means an old error to be ignored; otherwise, everything's ok,
04318      update the object (symbol) and continue on. */
04319 
04320   if (na == FFESYMBOL_attrsetNONE)
04321     ffesymbol_error (s, t);
04322   else if (!(na & FFESYMBOL_attrsANY))
04323     {
04324       ffesymbol_set_attrs (s, na);
04325       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
04326   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
04327       ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
04328       ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
04329       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
04330            FFEINTRIN_impNONE);
04331       ffebld_set_info (e,
04332            ffeinfo_new (FFEINFO_basictypeNONE,
04333             FFEINFO_kindtypeNONE,
04334             0,
04335             FFEINFO_kindNONE,
04336             FFEINFO_whereNONE,
04337             FFETARGET_charactersizeNONE));
04338       ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
04339       ffesymbol_signal_unreported (s);
04340     }
04341 }
04342 
04343 /* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
04344 
04345    ffestc_promote_execdummy_(t);
04346 
04347    Invoked for each token in dummy arg list of ENTRY when the statement
04348    follows the first executable statement.  */
04349 
04350 static void
04351 ffestc_promote_execdummy_ (ffelexToken t)
04352 {
04353   ffesymbol s;
04354   ffesymbolAttrs sa;
04355   ffesymbolAttrs na;
04356   ffesymbolState ss;
04357   ffesymbolState ns;
04358   ffeinfoKind kind;
04359   ffeinfoWhere where;
04360   ffebld e;
04361 
04362   assert (t != NULL);
04363 
04364   if (ffelex_token_type (t) == FFELEX_typeASTERISK)
04365     {
04366       ffebld_append_item (&ffestc_local_.dummy.list_bottom,
04367         ffebld_new_star ());
04368       return;     /* Don't bother with alternate returns! */
04369     }
04370 
04371   s = ffesymbol_declare_local (t, FALSE);
04372   na = sa = ffesymbol_attrs (s);
04373   ss = ffesymbol_state (s);
04374   kind = ffesymbol_kind (s);
04375   where = ffesymbol_where (s);
04376 
04377   if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
04378     {       /* Seen this one twice in this list! */
04379       na = FFESYMBOL_attrsetNONE;
04380     }
04381 
04382   /* Figure out what kind of object we've got based on previous declarations
04383      of or references to the object. */
04384 
04385   ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */
04386 
04387   switch (kind)
04388     {
04389     case FFEINFO_kindENTITY:
04390     case FFEINFO_kindFUNCTION:
04391     case FFEINFO_kindSUBROUTINE:
04392       break;      /* These are fine, as far as we know. */
04393 
04394     case FFEINFO_kindNONE:
04395       if (sa & FFESYMBOL_attrsDUMMY)
04396   ns = FFESYMBOL_stateUNCERTAIN;  /* Learned nothing new. */
04397       else if (sa & FFESYMBOL_attrsANYLEN)
04398   {
04399     kind = FFEINFO_kindENTITY;
04400     where = FFEINFO_whereDUMMY;
04401   }
04402       else if (sa & FFESYMBOL_attrsACTUALARG)
04403   na = FFESYMBOL_attrsetNONE;
04404       else
04405   {
04406     na = sa | FFESYMBOL_attrsDUMMY;
04407     ns = FFESYMBOL_stateUNCERTAIN;
04408   }
04409       break;
04410 
04411     default:
04412       na = FFESYMBOL_attrsetNONE; /* Error. */
04413       break;
04414     }
04415 
04416   switch (where)
04417     {
04418     case FFEINFO_whereDUMMY:
04419       break;      /* This is fine. */
04420 
04421     case FFEINFO_whereNONE:
04422       where = FFEINFO_whereDUMMY;
04423       break;
04424 
04425     default:
04426       na = FFESYMBOL_attrsetNONE; /* Error. */
04427       break;
04428     }
04429 
04430   /* Now see what we've got for a new object: NONE means a new error cropped
04431      up; ANY means an old error to be ignored; otherwise, everything's ok,
04432      update the object (symbol) and continue on. */
04433 
04434   if (na == FFESYMBOL_attrsetNONE)
04435     ffesymbol_error (s, t);
04436   else if (!(na & FFESYMBOL_attrsANY))
04437     {
04438       ffesymbol_set_attrs (s, na);
04439       ffesymbol_set_state (s, ns);
04440       ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
04441       ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
04442       if ((ns == FFESYMBOL_stateUNDERSTOOD)
04443     && (kind != FFEINFO_kindSUBROUTINE)
04444     && !ffeimplic_establish_symbol (s))
04445   {
04446     ffesymbol_error (s, t);
04447     return;
04448   }
04449       ffesymbol_set_info (s,
04450         ffeinfo_new (ffesymbol_basictype (s),
04451                ffesymbol_kindtype (s),
04452                ffesymbol_rank (s),
04453                kind,
04454                where,
04455                ffesymbol_size (s)));
04456       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
04457            FFEINTRIN_impNONE);
04458       ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
04459       ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
04460       s = ffecom_sym_learned (s);
04461       ffesymbol_signal_unreported (s);
04462     }
04463 }
04464 
04465 /* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
04466 
04467    ffestc_promote_sfdummy_(t);
04468 
04469    Invoked for each token in dummy arg list of statement function.
04470 
04471    22-Oct-91  JCB  1.1
04472       Reject arg if CHARACTER*(*).  */
04473 
04474 static void
04475 ffestc_promote_sfdummy_ (ffelexToken t)
04476 {
04477   ffesymbol s;
04478   ffesymbol sp;     /* Parent symbol. */
04479   ffesymbolAttrs sa;
04480   ffesymbolAttrs na;
04481   ffebld e;
04482 
04483   assert (t != NULL);
04484 
04485   s = ffesymbol_declare_sfdummy (t);  /* Sets maxentrynum to 0 for new obj;
04486              also sets sfa_dummy_parent to
04487              parent symbol. */
04488   if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
04489     {
04490       ffesymbol_error (s, t); /* Dummy already in list. */
04491       return;
04492     }
04493 
04494   sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used
04495              for dummy. */
04496   sa = ffesymbol_attrs (sp);
04497 
04498   /* Figure out what kind of object we've got based on previous declarations
04499      of or references to the object. */
04500 
04501   if (!ffesymbol_is_specable (sp)
04502       && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
04503     || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
04504         && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
04505         && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
04506         && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
04507     na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
04508   else if (sa & FFESYMBOL_attrsANY)
04509     na = sa;
04510   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
04511         | FFESYMBOL_attrsCOMMON
04512         | FFESYMBOL_attrsDUMMY
04513         | FFESYMBOL_attrsEQUIV
04514         | FFESYMBOL_attrsINIT
04515         | FFESYMBOL_attrsNAMELIST
04516         | FFESYMBOL_attrsRESULT
04517         | FFESYMBOL_attrsSAVE
04518         | FFESYMBOL_attrsSFARG
04519         | FFESYMBOL_attrsTYPE)))
04520     na = sa | FFESYMBOL_attrsSFARG;
04521   else
04522     na = FFESYMBOL_attrsetNONE;
04523 
04524   /* Now see what we've got for a new object: NONE means a new error cropped
04525      up; ANY means an old error to be ignored; otherwise, everything's ok,
04526      update the object (symbol) and continue on. */
04527 
04528   if (na == FFESYMBOL_attrsetNONE)
04529     {
04530       ffesymbol_error (sp, t);
04531       ffesymbol_set_info (s, ffeinfo_new_any ());
04532     }
04533   else if (!(na & FFESYMBOL_attrsANY))
04534     {
04535       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
04536       ffesymbol_set_attrs (sp, na);
04537       if (!ffeimplic_establish_symbol (sp)
04538     || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
04539         && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
04540   ffesymbol_error (sp, t);
04541       else
04542   ffesymbol_set_info (s,
04543           ffeinfo_new (ffesymbol_basictype (sp),
04544            ffesymbol_kindtype (sp),
04545            0,
04546            FFEINFO_kindENTITY,
04547            FFEINFO_whereDUMMY,
04548            ffesymbol_size (sp)));
04549 
04550       ffesymbol_signal_unreported (sp);
04551     }
04552 
04553   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
04554   ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
04555   ffesymbol_signal_unreported (s);
04556   e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
04557        FFEINTRIN_impNONE);
04558   ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
04559   ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
04560 }
04561 
04562 /* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
04563 
04564    ffestc_shriek_begin_program_();
04565 
04566    Invoked only when a PROGRAM statement is NOT present at the beginning
04567    of a main program unit.  */
04568 
04569 static void
04570 ffestc_shriek_begin_program_ ()
04571 {
04572   ffestw b;
04573   ffesymbol s;
04574 
04575   ffestc_blocknum_ = 0;
04576   b = ffestw_update (ffestw_push (NULL));
04577   ffestw_set_top_do (b, NULL);
04578   ffestw_set_state (b, FFESTV_statePROGRAM0);
04579   ffestw_set_blocknum (b, ffestc_blocknum_++);
04580   ffestw_set_shriek (b, ffestc_shriek_end_program_);
04581   ffestw_set_name (b, NULL);
04582 
04583   s = ffesymbol_declare_programunit (NULL,
04584          ffelex_token_where_line (ffesta_tokens[0]),
04585             ffelex_token_where_column (ffesta_tokens[0]));
04586 
04587   /* Special case: this is one symbol that won't go through
04588      ffestu_exec_transition_ when the first statement in a main program is
04589      executable, because the transition happens in ffest before ffestc is
04590      reached and triggers the implicit generation of a main program.  So we
04591      do the exec transition for the implicit main program right here, just
04592      for cleanliness' sake (at the very least). */
04593 
04594   ffesymbol_set_info (s,
04595           ffeinfo_new (FFEINFO_basictypeNONE,
04596            FFEINFO_kindtypeNONE,
04597            0,
04598            FFEINFO_kindPROGRAM,
04599            FFEINFO_whereLOCAL,
04600            FFETARGET_charactersizeNONE));
04601   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
04602 
04603   ffesymbol_signal_unreported (s);
04604 
04605   ffestd_R1102 (s, NULL);
04606 }
04607 
04608 /* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements
04609 
04610    ffestc_shriek_begin_uses_();
04611 
04612    Invoked before handling the first USE statement in a block of one or
04613    more USE statements.  _end_uses_(bool ok) is invoked before handling
04614    the first statement after the block (there are no BEGIN USE and END USE
04615    statements, but the semantics of USE statements effectively requires
04616    handling them as a single block rather than one statement at a time).  */
04617 
04618 #if FFESTR_F90
04619 static void
04620 ffestc_shriek_begin_uses_ ()
04621 {
04622   ffestw b;
04623 
04624   b = ffestw_update (ffestw_push (NULL));
04625   ffestw_set_top_do (b, NULL);
04626   ffestw_set_state (b, FFESTV_stateUSE);
04627   ffestw_set_blocknum (b, 0);
04628   ffestw_set_shriek (b, ffestc_shriek_end_uses_);
04629 
04630   ffestd_begin_uses ();
04631 }
04632 
04633 #endif
04634 /* ffestc_shriek_blockdata_ -- End a BLOCK DATA
04635 
04636    ffestc_shriek_blockdata_(TRUE);  */
04637 
04638 static void
04639 ffestc_shriek_blockdata_ (bool ok)
04640 {
04641   if (!ffesta_seen_first_exec)
04642     {
04643       ffesta_seen_first_exec = TRUE;
04644       ffestd_exec_begin ();
04645     }
04646 
04647   ffestd_R1112 (ok);
04648 
04649   ffestd_exec_end ();
04650 
04651   if (ffestw_name (ffestw_stack_top ()) != NULL)
04652     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04653   ffestw_kill (ffestw_pop ());
04654 
04655   ffe_terminate_2 ();
04656   ffe_init_2 ();
04657 }
04658 
04659 /* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
04660 
04661    ffestc_shriek_do_(TRUE);
04662 
04663    Also invoked by _labeldef_branch_end_ (or, in cases
04664    of errors, other _labeldef_ functions) when the label definition is
04665    for a DO-target (LOOPEND) label, once per matching/outstanding DO
04666    block on the stack.  These cases invoke this function with ok==TRUE, so
04667    only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE.  */
04668 
04669 static void
04670 ffestc_shriek_do_ (bool ok)
04671 {
04672   ffelab l;
04673 
04674   if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
04675       && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
04676     {       /* DO target is label that is still
04677            undefined. */
04678       assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
04679         || (ffelab_type (l) == FFELAB_typeANY));
04680       if (ffelab_type (l) != FFELAB_typeANY)
04681   {
04682     ffelab_set_definition_line (l,
04683               ffewhere_line_use (ffelab_doref_line (l)));
04684     ffelab_set_definition_column (l,
04685           ffewhere_column_use (ffelab_doref_column (l)));
04686     ffestv_num_label_defines_++;
04687   }
04688       ffestd_labeldef_branch (l);
04689     }
04690 
04691   ffestd_do (ok);
04692 
04693   if (ffestw_name (ffestw_stack_top ()) != NULL)
04694     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04695   if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
04696     ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
04697   if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
04698     ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
04699   ffestw_kill (ffestw_pop ());
04700 }
04701 
04702 /* ffestc_shriek_end_program_ -- End a PROGRAM
04703 
04704    ffestc_shriek_end_program_();  */
04705 
04706 static void
04707 ffestc_shriek_end_program_ (bool ok)
04708 {
04709   if (!ffesta_seen_first_exec)
04710     {
04711       ffesta_seen_first_exec = TRUE;
04712       ffestd_exec_begin ();
04713     }
04714 
04715   ffestd_R1103 (ok);
04716 
04717   ffestd_exec_end ();
04718 
04719   if (ffestw_name (ffestw_stack_top ()) != NULL)
04720     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04721   ffestw_kill (ffestw_pop ());
04722 
04723   ffe_terminate_2 ();
04724   ffe_init_2 ();
04725 }
04726 
04727 /* ffestc_shriek_end_uses_ -- End a bunch of USE statements
04728 
04729    ffestc_shriek_end_uses_(TRUE);
04730 
04731    ok==TRUE means simply not popping due to ffestc_eof()
04732    being called, because there is no formal END USES statement in Fortran.  */
04733 
04734 #if FFESTR_F90
04735 static void
04736 ffestc_shriek_end_uses_ (bool ok)
04737 {
04738   ffestd_end_uses (ok);
04739 
04740   ffestw_kill (ffestw_pop ());
04741 }
04742 
04743 #endif
04744 /* ffestc_shriek_function_ -- End a FUNCTION
04745 
04746    ffestc_shriek_function_(TRUE);  */
04747 
04748 static void
04749 ffestc_shriek_function_ (bool ok)
04750 {
04751   if (!ffesta_seen_first_exec)
04752     {
04753       ffesta_seen_first_exec = TRUE;
04754       ffestd_exec_begin ();
04755     }
04756 
04757   ffestd_R1221 (ok);
04758 
04759   ffestd_exec_end ();
04760 
04761   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04762   ffestw_kill (ffestw_pop ());
04763   ffesta_is_entry_valid = FALSE;
04764 
04765   switch (ffestw_state (ffestw_stack_top ()))
04766     {
04767     case FFESTV_stateNIL:
04768       ffe_terminate_2 ();
04769       ffe_init_2 ();
04770       break;
04771 
04772     default:
04773       ffe_terminate_3 ();
04774       ffe_init_3 ();
04775       break;
04776 
04777     case FFESTV_stateINTERFACE0:
04778       ffe_terminate_4 ();
04779       ffe_init_4 ();
04780       break;
04781     }
04782 }
04783 
04784 /* ffestc_shriek_if_ -- End of statement following logical IF
04785 
04786    ffestc_shriek_if_(TRUE);
04787 
04788    Applies ONLY to logical IF, not to IF-THEN.  For example, does not
04789    ffelex_token_kill the construct name for an IF-THEN block (the name
04790    field is invalid for logical IF).  ok==TRUE iff statement following
04791    logical IF (substatement) is valid; else, statement is invalid or
04792    stack forcibly popped due to ffestc_eof().  */
04793 
04794 static void
04795 ffestc_shriek_if_ (bool ok)
04796 {
04797   ffestd_end_R807 (ok);
04798 
04799   ffestw_kill (ffestw_pop ());
04800   ffestc_shriek_after1_ = NULL;
04801 
04802   ffestc_try_shriek_do_ ();
04803 }
04804 
04805 /* ffestc_shriek_ifthen_ -- End an IF-THEN
04806 
04807    ffestc_shriek_ifthen_(TRUE);  */
04808 
04809 static void
04810 ffestc_shriek_ifthen_ (bool ok)
04811 {
04812   ffestd_R806 (ok);
04813 
04814   if (ffestw_name (ffestw_stack_top ()) != NULL)
04815     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04816   ffestw_kill (ffestw_pop ());
04817 
04818   ffestc_try_shriek_do_ ();
04819 }
04820 
04821 /* ffestc_shriek_interface_ -- End an INTERFACE
04822 
04823    ffestc_shriek_interface_(TRUE);  */
04824 
04825 #if FFESTR_F90
04826 static void
04827 ffestc_shriek_interface_ (bool ok)
04828 {
04829   ffestd_R1203 (ok);
04830 
04831   ffestw_kill (ffestw_pop ());
04832 
04833   ffestc_try_shriek_do_ ();
04834 }
04835 
04836 #endif
04837 /* ffestc_shriek_map_ -- End a MAP
04838 
04839    ffestc_shriek_map_(TRUE);  */
04840 
04841 #if FFESTR_VXT
04842 static void
04843 ffestc_shriek_map_ (bool ok)
04844 {
04845   ffestd_V013 (ok);
04846 
04847   ffestw_kill (ffestw_pop ());
04848 
04849   ffestc_try_shriek_do_ ();
04850 }
04851 
04852 #endif
04853 /* ffestc_shriek_module_ -- End a MODULE
04854 
04855    ffestc_shriek_module_(TRUE);  */
04856 
04857 #if FFESTR_F90
04858 static void
04859 ffestc_shriek_module_ (bool ok)
04860 {
04861   if (!ffesta_seen_first_exec)
04862     {
04863       ffesta_seen_first_exec = TRUE;
04864       ffestd_exec_begin ();
04865     }
04866 
04867   ffestd_R1106 (ok);
04868 
04869   ffestd_exec_end ();
04870 
04871   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04872   ffestw_kill (ffestw_pop ());
04873 
04874   ffe_terminate_2 ();
04875   ffe_init_2 ();
04876 }
04877 
04878 #endif
04879 /* ffestc_shriek_select_ -- End a SELECT
04880 
04881    ffestc_shriek_select_(TRUE);  */
04882 
04883 static void
04884 ffestc_shriek_select_ (bool ok)
04885 {
04886   ffestwSelect s;
04887   ffestwCase c;
04888 
04889   ffestd_R811 (ok);
04890 
04891   if (ffestw_name (ffestw_stack_top ()) != NULL)
04892     ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04893   s = ffestw_select (ffestw_stack_top ());
04894   ffelex_token_kill (s->t);
04895   for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
04896     ffelex_token_kill (c->t);
04897   malloc_pool_kill (s->pool);
04898 
04899   ffestw_kill (ffestw_pop ());
04900 
04901   ffestc_try_shriek_do_ ();
04902 }
04903 
04904 /* ffestc_shriek_structure_ -- End a STRUCTURE
04905 
04906    ffestc_shriek_structure_(TRUE);  */
04907 
04908 #if FFESTR_VXT
04909 static void
04910 ffestc_shriek_structure_ (bool ok)
04911 {
04912   ffestd_V004 (ok);
04913 
04914   ffestw_kill (ffestw_pop ());
04915 
04916   ffestc_try_shriek_do_ ();
04917 }
04918 
04919 #endif
04920 /* ffestc_shriek_subroutine_ -- End a SUBROUTINE
04921 
04922    ffestc_shriek_subroutine_(TRUE);  */
04923 
04924 static void
04925 ffestc_shriek_subroutine_ (bool ok)
04926 {
04927   if (!ffesta_seen_first_exec)
04928     {
04929       ffesta_seen_first_exec = TRUE;
04930       ffestd_exec_begin ();
04931     }
04932 
04933   ffestd_R1225 (ok);
04934 
04935   ffestd_exec_end ();
04936 
04937   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04938   ffestw_kill (ffestw_pop ());
04939   ffesta_is_entry_valid = FALSE;
04940 
04941   switch (ffestw_state (ffestw_stack_top ()))
04942     {
04943     case FFESTV_stateNIL:
04944       ffe_terminate_2 ();
04945       ffe_init_2 ();
04946       break;
04947 
04948     default:
04949       ffe_terminate_3 ();
04950       ffe_init_3 ();
04951       break;
04952 
04953     case FFESTV_stateINTERFACE0:
04954       ffe_terminate_4 ();
04955       ffe_init_4 ();
04956       break;
04957     }
04958 }
04959 
04960 /* ffestc_shriek_type_ -- End a TYPE
04961 
04962    ffestc_shriek_type_(TRUE);  */
04963 
04964 #if FFESTR_F90
04965 static void
04966 ffestc_shriek_type_ (bool ok)
04967 {
04968   ffestd_R425 (ok);
04969 
04970   ffe_terminate_4 ();
04971 
04972   ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
04973   ffestw_kill (ffestw_pop ());
04974 
04975   ffestc_try_shriek_do_ ();
04976 }
04977 
04978 #endif
04979 /* ffestc_shriek_union_ -- End a UNION
04980 
04981    ffestc_shriek_union_(TRUE);  */
04982 
04983 #if FFESTR_VXT
04984 static void
04985 ffestc_shriek_union_ (bool ok)
04986 {
04987   ffestd_V010 (ok);
04988 
04989   ffestw_kill (ffestw_pop ());
04990 
04991   ffestc_try_shriek_do_ ();
04992 }
04993 
04994 #endif
04995 /* ffestc_shriek_where_ -- Implicit END WHERE statement
04996 
04997    ffestc_shriek_where_(TRUE);
04998 
04999    Implement the end of the current WHERE "block".  ok==TRUE iff statement
05000    following WHERE (substatement) is valid; else, statement is invalid
05001    or stack forcibly popped due to ffestc_eof().  */
05002 
05003 #if FFESTR_F90
05004 static void
05005 ffestc_shriek_where_ (bool ok)
05006 {
05007   ffestd_R745 (ok);
05008 
05009   ffestw_kill (ffestw_pop ());
05010   ffestc_shriek_after1_ = NULL;
05011   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF)
05012     ffestc_shriek_if_ (TRUE); /* "IF (x) WHERE (y) stmt" is only valid
05013            case. */
05014 
05015   ffestc_try_shriek_do_ ();
05016 }
05017 
05018 #endif
05019 /* ffestc_shriek_wherethen_ -- End a WHERE(-THEN)
05020 
05021    ffestc_shriek_wherethen_(TRUE);  */
05022 
05023 #if FFESTR_F90
05024 static void
05025 ffestc_shriek_wherethen_ (bool ok)
05026 {
05027   ffestd_end_R740 (ok);
05028 
05029   ffestw_kill (ffestw_pop ());
05030 
05031   ffestc_try_shriek_do_ ();
05032 }
05033 
05034 #endif
05035 /* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
05036 
05037    i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
05038 
05039    search_list contains search_list_size char *'s, spec is checked to see
05040    if it is a char constant and, if so, is binary-searched against the list.
05041    0 is returned if not found, else the "classic" index (beginning with 1)
05042    is returned.  Before returning 0 where the search was performed but
05043    fruitless, if "etc" is a non-NULL char *, an error message is displayed
05044    using "etc" as the pick-one-of-these string.  */
05045 
05046 static int
05047 ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
05048           const char *whine)
05049 {
05050   int lowest_tested;
05051   int highest_tested;
05052   int halfway;
05053   int offset;
05054   int c;
05055   const char *str;
05056   int len;
05057 
05058   if (size == 0)
05059     return 0;     /* Nobody should pass size == 0, but for
05060            elegance.... */
05061 
05062   lowest_tested = -1;
05063   highest_tested = size;
05064   halfway = size >> 1;
05065 
05066   list += halfway;
05067 
05068   c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
05069   if (c == 2)
05070     return 0;
05071   c = -c;     /* Sigh.  */
05072 
05073 next:       /* :::::::::::::::::::: */
05074   switch (c)
05075     {
05076     case -1:
05077       offset = (halfway - lowest_tested) >> 1;
05078       if (offset == 0)
05079   goto nope;    /* :::::::::::::::::::: */
05080       highest_tested = halfway;
05081       list -= offset;
05082       halfway -= offset;
05083       c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
05084       goto next;    /* :::::::::::::::::::: */
05085 
05086     case 0:
05087       return halfway + 1;
05088 
05089     case 1:
05090       offset = (highest_tested - halfway) >> 1;
05091       if (offset == 0)
05092   goto nope;    /* :::::::::::::::::::: */
05093       lowest_tested = halfway;
05094       list += offset;
05095       halfway += offset;
05096       c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
05097       goto next;    /* :::::::::::::::::::: */
05098 
05099     default:
05100       assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
05101       break;
05102     }
05103 
05104 nope:       /* :::::::::::::::::::: */
05105   ffebad_start (FFEBAD_SPEC_VALUE);
05106   ffebad_here (0, ffelex_token_where_line (spec->value),
05107          ffelex_token_where_column (spec->value));
05108   ffebad_string (whine);
05109   ffebad_finish ();
05110   return 0;
05111 }
05112 
05113 /* ffestc_subr_format_ -- Return summary of format specifier
05114 
05115    ffestc_subr_format_(&specifier);  */
05116 
05117 static ffestvFormat
05118 ffestc_subr_format_ (ffestpFile *spec)
05119 {
05120   if (!spec->kw_or_val_present)
05121     return FFESTV_formatNONE;
05122   assert (spec->value_present);
05123   if (spec->value_is_label)
05124     return FFESTV_formatLABEL;  /* Ok if not a label. */
05125 
05126   assert (spec->value != NULL);
05127   if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
05128     return FFESTV_formatASTERISK;
05129 
05130   if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
05131     return FFESTV_formatNAMELIST;
05132 
05133   if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
05134     return FFESTV_formatCHAREXPR; /* F77 C5. */
05135 
05136   switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
05137     {
05138     case FFEINFO_basictypeINTEGER:
05139       return FFESTV_formatINTEXPR;
05140 
05141     case FFEINFO_basictypeCHARACTER:
05142       return FFESTV_formatCHAREXPR;
05143 
05144     case FFEINFO_basictypeANY:
05145       return FFESTV_formatASTERISK;
05146 
05147     default:
05148       assert ("bad basictype" == NULL);
05149       return FFESTV_formatINTEXPR;
05150     }
05151 }
05152 
05153 /* ffestc_subr_is_branch_ -- Handle specifier as branch target label
05154 
05155    ffestc_subr_is_branch_(&specifier);  */
05156 
05157 static bool
05158 ffestc_subr_is_branch_ (ffestpFile *spec)
05159 {
05160   if (!spec->kw_or_val_present)
05161     return TRUE;
05162   assert (spec->value_present);
05163   assert (spec->value_is_label);
05164   spec->value_is_label++; /* For checking purposes only; 1=>2. */
05165   return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
05166 }
05167 
05168 /* ffestc_subr_is_format_ -- Handle specifier as format target label
05169 
05170    ffestc_subr_is_format_(&specifier);  */
05171 
05172 static bool
05173 ffestc_subr_is_format_ (ffestpFile *spec)
05174 {
05175   if (!spec->kw_or_val_present)
05176     return TRUE;
05177   assert (spec->value_present);
05178   if (!spec->value_is_label)
05179     return TRUE;    /* Ok if not a label. */
05180 
05181   spec->value_is_label++; /* For checking purposes only; 1=>2. */
05182   return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
05183 }
05184 
05185 /* ffestc_subr_is_present_ -- Ensure specifier is present, else error
05186 
05187    ffestc_subr_is_present_("SPECIFIER",&specifier);  */
05188 
05189 static bool
05190 ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
05191 {
05192   if (spec->kw_or_val_present)
05193     {
05194       assert (spec->value_present);
05195       return TRUE;
05196     }
05197 
05198   ffebad_start (FFEBAD_MISSING_SPECIFIER);
05199   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
05200          ffelex_token_where_column (ffesta_tokens[0]));
05201   ffebad_string (name);
05202   ffebad_finish ();
05203   return FALSE;
05204 }
05205 
05206 /* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
05207 
05208    if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
05209        // specifier value is present and is a char constant "CONSTANT"
05210 
05211    Like strcmp, except the return values are defined as: -1 returned in place
05212    of strcmp's generic negative value, 1 in place of it's generic positive
05213    value, and 2 when there is no character constant string to compare.  Also,
05214    a case-insensitive comparison is performed, where string is assumed to
05215    already be in InitialCaps form.
05216 
05217    If a non-NULL pointer is provided as the char **target, then *target is
05218    written with NULL if 2 is returned, a pointer to the constant string
05219    value of the specifier otherwise.  Similarly, length is written with
05220    0 if 2 is returned, the length of the constant string value otherwise.  */
05221 
05222 static int
05223 ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
05224           int *length)
05225 {
05226   ffebldConstant c;
05227   int i;
05228 
05229   if (!spec->kw_or_val_present || !spec->value_present
05230       || (spec->u.expr == NULL)
05231       || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
05232     {
05233       if (target != NULL)
05234   *target = NULL;
05235       if (length != NULL)
05236   *length = 0;
05237       return 2;
05238     }
05239 
05240   if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
05241       != FFEBLD_constCHARACTERDEFAULT)
05242     {
05243       if (target != NULL)
05244   *target = NULL;
05245       if (length != NULL)
05246   *length = 0;
05247       return 2;
05248     }
05249 
05250   if (target != NULL)
05251     *target = ffebld_constant_characterdefault (c).text;
05252   if (length != NULL)
05253     *length = ffebld_constant_characterdefault (c).length;
05254 
05255   i = ffesrc_strcmp_1ns2i (ffe_case_match (),
05256          ffebld_constant_characterdefault (c).text,
05257          ffebld_constant_characterdefault (c).length,
05258          string);
05259   if (i == 0)
05260     return 0;
05261   if (i > 0)
05262     return -1;      /* Yes indeed, we reverse the strings to
05263            _strcmpin_.   */
05264   return 1;
05265 }
05266 
05267 /* ffestc_subr_unit_ -- Return summary of unit specifier
05268 
05269    ffestc_subr_unit_(&specifier);  */
05270 
05271 static ffestvUnit
05272 ffestc_subr_unit_ (ffestpFile *spec)
05273 {
05274   if (!spec->kw_or_val_present)
05275     return FFESTV_unitNONE;
05276   assert (spec->value_present);
05277   assert (spec->value != NULL);
05278 
05279   if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
05280     return FFESTV_unitASTERISK;
05281 
05282   switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
05283     {
05284     case FFEINFO_basictypeINTEGER:
05285       return FFESTV_unitINTEXPR;
05286 
05287     case FFEINFO_basictypeCHARACTER:
05288       return FFESTV_unitCHAREXPR;
05289 
05290     case FFEINFO_basictypeANY:
05291       return FFESTV_unitASTERISK;
05292 
05293     default:
05294       assert ("bad basictype" == NULL);
05295       return FFESTV_unitINTEXPR;
05296     }
05297 }
05298 
05299 /* Call this function whenever it's possible that one or more top
05300    stack items are label-targeting DO blocks that have had their
05301    labels defined, but at a time when they weren't at the top of the
05302    stack.  This prevents uninformative diagnostics for programs
05303    like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END".  */
05304 
05305 static void
05306 ffestc_try_shriek_do_ ()
05307 {
05308   ffelab lab;
05309   ffelabType ty;
05310 
05311   while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
05312    && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
05313    && (((ty = (ffelab_type (lab)))
05314         == FFELAB_typeANY)
05315        || (ty == FFELAB_typeUSELESS)
05316        || (ty == FFELAB_typeFORMAT)
05317        || (ty == FFELAB_typeNOTLOOP)
05318        || (ty == FFELAB_typeENDIF)))
05319     ffestc_shriek_do_ (FALSE);
05320 }
05321 
05322 /* ffestc_decl_start -- R426 or R501
05323 
05324    ffestc_decl_start(...);
05325 
05326    Verify that R426 component-def-stmt or R501 type-declaration-stmt are
05327    valid here, figure out which one, and implement.  */
05328 
05329 void
05330 ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
05331        ffelexToken kindt, ffebld len, ffelexToken lent)
05332 {
05333   switch (ffestw_state (ffestw_stack_top ()))
05334     {
05335     case FFESTV_stateNIL:
05336     case FFESTV_statePROGRAM0:
05337     case FFESTV_stateSUBROUTINE0:
05338     case FFESTV_stateFUNCTION0:
05339     case FFESTV_stateMODULE0:
05340     case FFESTV_stateBLOCKDATA0:
05341     case FFESTV_statePROGRAM1:
05342     case FFESTV_stateSUBROUTINE1:
05343     case FFESTV_stateFUNCTION1:
05344     case FFESTV_stateMODULE1:
05345     case FFESTV_stateBLOCKDATA1:
05346     case FFESTV_statePROGRAM2:
05347     case FFESTV_stateSUBROUTINE2:
05348     case FFESTV_stateFUNCTION2:
05349     case FFESTV_stateMODULE2:
05350     case FFESTV_stateBLOCKDATA2:
05351     case FFESTV_statePROGRAM3:
05352     case FFESTV_stateSUBROUTINE3:
05353     case FFESTV_stateFUNCTION3:
05354     case FFESTV_stateMODULE3:
05355     case FFESTV_stateBLOCKDATA3:
05356     case FFESTV_stateUSE:
05357       ffestc_local_.decl.is_R426 = 2;
05358       break;
05359 
05360     case FFESTV_stateTYPE:
05361     case FFESTV_stateSTRUCTURE:
05362     case FFESTV_stateMAP:
05363       ffestc_local_.decl.is_R426 = 1;
05364       break;
05365 
05366     default:
05367       ffestc_order_bad_ ();
05368       ffestc_labeldef_useless_ ();
05369       ffestc_local_.decl.is_R426 = 0;
05370       return;
05371     }
05372 
05373   switch (ffestc_local_.decl.is_R426)
05374     {
05375 #if FFESTR_F90
05376     case 1:
05377       ffestc_R426_start (type, typet, kind, kindt, len, lent);
05378       break;
05379 #endif
05380 
05381     case 2:
05382       ffestc_R501_start (type, typet, kind, kindt, len, lent);
05383       break;
05384 
05385     default:
05386       ffestc_labeldef_useless_ ();
05387       break;
05388     }
05389 }
05390 
05391 /* ffestc_decl_attrib -- R426 or R501 type attribute
05392 
05393    ffestc_decl_attrib(...);
05394 
05395    Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
05396    is valid here and implement.  */
05397 
05398 void
05399 ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
05400         ffelexToken attribt UNUSED,
05401         ffestrOther intent_kw UNUSED,
05402         ffesttDimList dims UNUSED)
05403 {
05404 #if FFESTR_F90
05405   switch (ffestc_local_.decl.is_R426)
05406     {
05407     case 1:
05408       ffestc_R426_attrib (attrib, attribt, intent_kw, dims);
05409       break;
05410 
05411     case 2:
05412       ffestc_R501_attrib (attrib, attribt, intent_kw, dims);
05413       break;
05414 
05415     default:
05416       break;
05417     }
05418 #else
05419   ffebad_start (FFEBAD_F90);
05420   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
05421          ffelex_token_where_column (ffesta_tokens[0]));
05422   ffebad_finish ();
05423   return;
05424 #endif
05425 }
05426 
05427 /* ffestc_decl_item -- R426 or R501
05428 
05429    ffestc_decl_item(...);
05430 
05431    Establish type for a particular object.  */
05432 
05433 void
05434 ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
05435         ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
05436       ffelexToken initt, bool clist)
05437 {
05438   switch (ffestc_local_.decl.is_R426)
05439     {
05440 #if FFESTR_F90
05441     case 1:
05442       ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt,
05443       clist);
05444       break;
05445 #endif
05446 
05447     case 2:
05448       ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
05449       clist);
05450       break;
05451 
05452     default:
05453       break;
05454     }
05455 }
05456 
05457 /* ffestc_decl_itemstartvals -- R426 or R501 start list of values
05458 
05459    ffestc_decl_itemstartvals();
05460 
05461    Gonna specify values for the object now.  */
05462 
05463 void
05464 ffestc_decl_itemstartvals ()
05465 {
05466   switch (ffestc_local_.decl.is_R426)
05467     {
05468 #if FFESTR_F90
05469     case 1:
05470       ffestc_R426_itemstartvals ();
05471       break;
05472 #endif
05473 
05474     case 2:
05475       ffestc_R501_itemstartvals ();
05476       break;
05477 
05478     default:
05479       break;
05480     }
05481 }
05482 
05483 /* ffestc_decl_itemvalue -- R426 or R501 source value
05484 
05485    ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
05486 
05487    Make sure repeat and value are valid for the object being initialized.  */
05488 
05489 void
05490 ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
05491            ffebld value, ffelexToken value_token)
05492 {
05493   switch (ffestc_local_.decl.is_R426)
05494     {
05495 #if FFESTR_F90
05496     case 1:
05497       ffestc_R426_itemvalue (repeat, repeat_token, value, value_token);
05498       break;
05499 #endif
05500 
05501     case 2:
05502       ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
05503       break;
05504 
05505     default:
05506       break;
05507     }
05508 }
05509 
05510 /* ffestc_decl_itemendvals -- R426 or R501 end list of values
05511 
05512    ffelexToken t;  // the SLASH token that ends the list.
05513    ffestc_decl_itemendvals(t);
05514 
05515    No more values, might specify more objects now.  */
05516 
05517 void
05518 ffestc_decl_itemendvals (ffelexToken t)
05519 {
05520   switch (ffestc_local_.decl.is_R426)
05521     {
05522 #if FFESTR_F90
05523     case 1:
05524       ffestc_R426_itemendvals (t);
05525       break;
05526 #endif
05527 
05528     case 2:
05529       ffestc_R501_itemendvals (t);
05530       break;
05531 
05532     default:
05533       break;
05534     }
05535 }
05536 
05537 /* ffestc_decl_finish -- R426 or R501
05538 
05539    ffestc_decl_finish();
05540 
05541    Just wrap up any local activities.  */
05542 
05543 void
05544 ffestc_decl_finish ()
05545 {
05546   switch (ffestc_local_.decl.is_R426)
05547     {
05548 #if FFESTR_F90
05549     case 1:
05550       ffestc_R426_finish ();
05551       break;
05552 #endif
05553 
05554     case 2:
05555       ffestc_R501_finish ();
05556       break;
05557 
05558     default:
05559       break;
05560     }
05561 }
05562 
05563 /* ffestc_elsewhere -- Generic ELSE WHERE statement
05564 
05565    ffestc_end();
05566 
05567    Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant.  */
05568 
05569 void
05570 ffestc_elsewhere (ffelexToken where)
05571 {
05572   switch (ffestw_state (ffestw_stack_top ()))
05573     {
05574     case FFESTV_stateIFTHEN:
05575       ffestc_R805 (where);
05576       break;
05577 
05578     default:
05579 #if FFESTR_F90
05580       ffestc_R744 ();
05581 #endif
05582       break;
05583     }
05584 }
05585 
05586 /* ffestc_end -- Generic END statement
05587 
05588    ffestc_end();
05589 
05590    Make sure a generic END is valid in the current context, and implement
05591    it.  */
05592 
05593 void
05594 ffestc_end ()
05595 {
05596   ffestw b;
05597 
05598   b = ffestw_stack_top ();
05599 
05600 recurse:
05601 
05602   switch (ffestw_state (b))
05603     {
05604     case FFESTV_stateBLOCKDATA0:
05605     case FFESTV_stateBLOCKDATA1:
05606     case FFESTV_stateBLOCKDATA2:
05607     case FFESTV_stateBLOCKDATA3:
05608     case FFESTV_stateBLOCKDATA4:
05609     case FFESTV_stateBLOCKDATA5:
05610       ffestc_R1112 (NULL);
05611       break;
05612 
05613     case FFESTV_stateFUNCTION0:
05614     case FFESTV_stateFUNCTION1:
05615     case FFESTV_stateFUNCTION2:
05616     case FFESTV_stateFUNCTION3:
05617     case FFESTV_stateFUNCTION4:
05618     case FFESTV_stateFUNCTION5:
05619       if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
05620     && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
05621   {
05622     ffebad_start (FFEBAD_END_WO);
05623     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
05624            ffelex_token_where_column (ffesta_tokens[0]));
05625     ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
05626     ffebad_string ("FUNCTION");
05627     ffebad_finish ();
05628   }
05629       ffestc_R1221 (NULL);
05630       break;
05631 
05632     case FFESTV_stateMODULE0:
05633     case FFESTV_stateMODULE1:
05634     case FFESTV_stateMODULE2:
05635     case FFESTV_stateMODULE3:
05636     case FFESTV_stateMODULE4:
05637     case FFESTV_stateMODULE5:
05638 #if FFESTR_F90
05639       ffestc_R1106 (NULL);
05640 #endif
05641       break;
05642 
05643     case FFESTV_stateSUBROUTINE0:
05644     case FFESTV_stateSUBROUTINE1:
05645     case FFESTV_stateSUBROUTINE2:
05646     case FFESTV_stateSUBROUTINE3:
05647     case FFESTV_stateSUBROUTINE4:
05648     case FFESTV_stateSUBROUTINE5:
05649       if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
05650     && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
05651   {
05652     ffebad_start (FFEBAD_END_WO);
05653     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
05654            ffelex_token_where_column (ffesta_tokens[0]));
05655     ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
05656     ffebad_string ("SUBROUTINE");
05657     ffebad_finish ();
05658   }
05659       ffestc_R1225 (NULL);
05660       break;
05661 
05662     case FFESTV_stateUSE:
05663       b = ffestw_previous (ffestw_stack_top ());
05664       goto recurse;   /* :::::::::::::::::::: */
05665 
05666     default:
05667       ffestc_R1103 (NULL);
05668       break;
05669     }
05670 }
05671 
05672 /* ffestc_eof -- Generic EOF
05673 
05674    ffestc_eof();
05675 
05676    Make sure we're at state NIL, or issue an error message and use each
05677    block's shriek function to clean up to state NIL.  */
05678 
05679 void
05680 ffestc_eof ()
05681 {
05682   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
05683     {
05684       ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
05685       ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
05686       ffebad_finish ();
05687       do
05688   (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
05689       while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
05690     }
05691 }
05692 
05693 /* ffestc_exec_transition -- Check if ok and move stmt state to executable
05694 
05695    if (ffestc_exec_transition())
05696        // Transition successful (kind of like a CONTINUE stmt was seen).
05697 
05698    If the current statement state is a non-nested specification state in
05699    which, say, a CONTINUE statement would be valid, then enter the state
05700    we'd be in after seeing CONTINUE (without, of course, generating any
05701    CONTINUE code), call ffestd_exec_begin, and return TRUE.  Otherwise
05702    return FALSE.
05703 
05704    This function cannot be invoked once the first executable statement
05705    is seen.  This function may choose to always return TRUE by shrieking
05706    away any interceding state stack entries to reach the base level of
05707    specification state, but right now it doesn't, and it is (or should
05708    be) purely an issue of how one wishes errors to be handled (for example,
05709    an unrecognized statement in the middle of a STRUCTURE construct: after
05710    the error message, should subsequent statements still be interpreted as
05711    being within the construct, or should the construct be terminated upon
05712    seeing the unrecognized statement?  we do the former at the moment).  */
05713 
05714 bool
05715 ffestc_exec_transition ()
05716 {
05717   bool update;
05718 
05719 recurse:
05720 
05721   switch (ffestw_state (ffestw_stack_top ()))
05722     {
05723     case FFESTV_stateNIL:
05724       ffestc_shriek_begin_program_ ();
05725       goto recurse;   /* :::::::::::::::::::: */
05726 
05727     case FFESTV_statePROGRAM0:
05728     case FFESTV_stateSUBROUTINE0:
05729     case FFESTV_stateFUNCTION0:
05730     case FFESTV_stateBLOCKDATA0:
05731       ffestw_state (ffestw_stack_top ()) += 4;  /* To state UNIT4. */
05732       update = TRUE;
05733       break;
05734 
05735     case FFESTV_statePROGRAM1:
05736     case FFESTV_stateSUBROUTINE1:
05737     case FFESTV_stateFUNCTION1:
05738     case FFESTV_stateBLOCKDATA1:
05739       ffestw_state (ffestw_stack_top ()) += 3;  /* To state UNIT4. */
05740       update = TRUE;
05741       break;
05742 
05743     case FFESTV_statePROGRAM2:
05744     case FFESTV_stateSUBROUTINE2:
05745     case FFESTV_stateFUNCTION2:
05746     case FFESTV_stateBLOCKDATA2:
05747       ffestw_state (ffestw_stack_top ()) += 2;  /* To state UNIT4. */
05748       update = TRUE;
05749       break;
05750 
05751     case FFESTV_statePROGRAM3:
05752     case FFESTV_stateSUBROUTINE3:
05753     case FFESTV_stateFUNCTION3:
05754     case FFESTV_stateBLOCKDATA3:
05755       ffestw_state (ffestw_stack_top ()) += 1;  /* To state UNIT4. */
05756       update = TRUE;
05757       break;
05758 
05759     case FFESTV_stateUSE:
05760 #if FFESTR_F90
05761       ffestc_shriek_end_uses_ (TRUE);
05762 #endif
05763       goto recurse;   /* :::::::::::::::::::: */
05764 
05765     default:
05766       return FALSE;
05767     }
05768 
05769   if (update)
05770     ffestw_update (NULL); /* Update state line/col info. */
05771 
05772   ffesta_seen_first_exec = TRUE;
05773   ffestd_exec_begin ();
05774 
05775   return TRUE;
05776 }
05777 
05778 /* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
05779 
05780    ffesymbol s;
05781    // call ffebad_start first, of course.
05782    ffestc_ffebad_here_doiter(0,s);
05783    // call ffebad_finish afterwards, naturally.
05784 
05785    Searches the stack of blocks backwards for a DO loop that has s
05786    as its iteration variable, then calls ffebad_here with pointers to
05787    that particular reference to the variable.  Crashes if the DO loop
05788    can't be found.  */
05789 
05790 void
05791 ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
05792 {
05793   ffestw block;
05794 
05795   for (block = ffestw_top_do (ffestw_stack_top ());
05796        (block != NULL) && (ffestw_blocknum (block) != 0);
05797        block = ffestw_top_do (ffestw_previous (block)))
05798     {
05799       if (ffestw_do_iter_var (block) == s)
05800   {
05801     ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
05802       ffelex_token_where_column (ffestw_do_iter_var_t (block)));
05803     return;
05804   }
05805     }
05806   assert ("no do block found" == NULL);
05807 }
05808 
05809 /* ffestc_is_decl_not_R1219 -- Context information for FFESTB
05810 
05811    if (ffestc_is_decl_not_R1219()) ...
05812 
05813    When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
05814    is seen, call this function.  It returns TRUE if the statement's context
05815    is such that it is a declaration of an object named
05816    "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
05817    if the statement's context is such that it begins the definition of a
05818    function named "name" havin the dummy argument list "name-list" (this
05819    is the R1219 function-stmt case).  */
05820 
05821 bool
05822 ffestc_is_decl_not_R1219 ()
05823 {
05824   switch (ffestw_state (ffestw_stack_top ()))
05825     {
05826     case FFESTV_stateNIL:
05827     case FFESTV_statePROGRAM5:
05828     case FFESTV_stateSUBROUTINE5:
05829     case FFESTV_stateFUNCTION5:
05830     case FFESTV_stateMODULE5:
05831     case FFESTV_stateINTERFACE0:
05832       return FALSE;
05833 
05834     default:
05835       return TRUE;
05836     }
05837 }
05838 
05839 /* ffestc_is_entry_in_subr -- Context information for FFESTB
05840 
05841    if (ffestc_is_entry_in_subr()) ...
05842 
05843    When a statement with the form "ENTRY name(name-list)"
05844    is seen, call this function.  It returns TRUE if the statement's context
05845    is such that it may have "*", meaning alternate return, in place of
05846    names in the name list (i.e. if the ENTRY is in a subroutine context).
05847    It also returns TRUE if the ENTRY is not in a function context (invalid
05848    but prevents extra complaints about "*", if present).  It returns FALSE
05849    if the ENTRY is in a function context.  */
05850 
05851 bool
05852 ffestc_is_entry_in_subr ()
05853 {
05854   ffestvState s;
05855 
05856   s = ffestw_state (ffestw_stack_top ());
05857 
05858 recurse:
05859 
05860   switch (s)
05861     {
05862     case FFESTV_stateFUNCTION0:
05863     case FFESTV_stateFUNCTION1:
05864     case FFESTV_stateFUNCTION2:
05865     case FFESTV_stateFUNCTION3:
05866     case FFESTV_stateFUNCTION4:
05867       return FALSE;
05868 
05869     case FFESTV_stateUSE:
05870       s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
05871       goto recurse;   /* :::::::::::::::::::: */
05872 
05873     default:
05874       return TRUE;
05875     }
05876 }
05877 
05878 /* ffestc_is_let_not_V027 -- Context information for FFESTB
05879 
05880    if (ffestc_is_let_not_V027()) ...
05881 
05882    When a statement with the form "PARAMETERname=expr"
05883    is seen, call this function.  It returns TRUE if the statement's context
05884    is such that it is an assignment to an object named "PARAMETERname", FALSE
05885    if the statement's context is such that it is a V-extension PARAMETER
05886    statement that is like a PARAMETER(name=expr) statement except that the
05887    type of name is determined by the type of expr, not the implicit or
05888    explicit typing of name.  */
05889 
05890 bool
05891 ffestc_is_let_not_V027 ()
05892 {
05893   switch (ffestw_state (ffestw_stack_top ()))
05894     {
05895     case FFESTV_statePROGRAM4:
05896     case FFESTV_stateSUBROUTINE4:
05897     case FFESTV_stateFUNCTION4:
05898     case FFESTV_stateWHERETHEN:
05899     case FFESTV_stateIFTHEN:
05900     case FFESTV_stateDO:
05901     case FFESTV_stateSELECT0:
05902     case FFESTV_stateSELECT1:
05903     case FFESTV_stateWHERE:
05904     case FFESTV_stateIF:
05905       return TRUE;
05906 
05907     default:
05908       return FALSE;
05909     }
05910 }
05911 
05912 /* ffestc_module -- MODULE or MODULE PROCEDURE statement
05913 
05914    ffestc_module(module_name_token,procedure_name_token);
05915 
05916    Decide which is intended, and implement it by calling _R1105_ or
05917    _R1205_.  */
05918 
05919 #if FFESTR_F90
05920 void
05921 ffestc_module (ffelexToken module, ffelexToken procedure)
05922 {
05923   switch (ffestw_state (ffestw_stack_top ()))
05924     {
05925     case FFESTV_stateINTERFACE0:
05926     case FFESTV_stateINTERFACE1:
05927       ffestc_R1205_start ();
05928       ffestc_R1205_item (procedure);
05929       ffestc_R1205_finish ();
05930       break;
05931 
05932     default:
05933       ffestc_R1105 (module);
05934       break;
05935     }
05936 }
05937 
05938 #endif
05939 /* ffestc_private -- Generic PRIVATE statement
05940 
05941    ffestc_end();
05942 
05943    This is either a PRIVATE within R422 derived-type statement or an
05944    R521 PRIVATE statement.  Figure it out based on context and implement
05945    it, or produce an error.  */
05946 
05947 #if FFESTR_F90
05948 void
05949 ffestc_private ()
05950 {
05951   switch (ffestw_state (ffestw_stack_top ()))
05952     {
05953     case FFESTV_stateTYPE:
05954       ffestc_R423A ();
05955       break;
05956 
05957     default:
05958       ffestc_R521B ();
05959       break;
05960     }
05961 }
05962 
05963 #endif
05964 /* ffestc_terminate_4 -- Terminate ffestc after scoping unit
05965 
05966    ffestc_terminate_4();
05967 
05968    For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
05969    defs, and statement function defs.  */
05970 
05971 void
05972 ffestc_terminate_4 ()
05973 {
05974   ffestc_entry_num_ = ffestc_saved_entry_num_;
05975 }
05976 
05977 /* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement)
05978 
05979    ffestc_R423A();  */
05980 
05981 #if FFESTR_F90
05982 void
05983 ffestc_R423A ()
05984 {
05985   ffestc_check_simple_ ();
05986   if (ffestc_order_type_ () != FFESTC_orderOK_)
05987     return;
05988   ffestc_labeldef_useless_ ();
05989 
05990   if (ffestw_substate (ffestw_stack_top ()) != 0)
05991     {
05992       ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
05993       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
05994        ffelex_token_where_column (ffesta_tokens[0]));
05995       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
05996       ffebad_finish ();
05997       return;
05998     }
05999 
06000   if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3)
06001     {
06002       ffebad_start (FFEBAD_DERIVTYP_ACCESS);
06003       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
06004        ffelex_token_where_column (ffesta_tokens[0]));
06005       ffebad_finish ();
06006       return;
06007     }
06008 
06009   ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
06010                private-sequence-stmt. */
06011 
06012   ffestd_R423A ();
06013 }
06014 
06015 /* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
06016 
06017    ffestc_R423B();  */
06018 
06019 void
06020 ffestc_R423B ()
06021 {
06022   ffestc_check_simple_ ();
06023   if (ffestc_order_type_ () != FFESTC_orderOK_)
06024     return;
06025   ffestc_labeldef_useless_ ();
06026 
06027   if (ffestw_substate (ffestw_stack_top ()) != 0)
06028     {
06029       ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
06030       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
06031        ffelex_token_where_column (ffesta_tokens[0]));
06032       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
06033       ffebad_finish ();
06034       return;
06035     }
06036 
06037   ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
06038                private-sequence-stmt. */
06039 
06040   ffestd_R423B ();
06041 }
06042 
06043 /* ffestc_R424 -- derived-TYPE-def statement
06044 
06045    ffestc_R424(access_token,access_kw,name_token);
06046 
06047    Handle a derived-type definition.  */
06048 
06049 void
06050 ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
06051 {
06052   ffestw b;
06053 
06054   assert (name != NULL);
06055 
06056   ffestc_check_simple_ ();
06057   if (ffestc_order_derivedtype_ () != FFESTC_orderOK_)
06058     return;
06059   ffestc_labeldef_useless_ ();
06060 
06061   if ((access != NULL)
06062       && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3))
06063     {
06064       ffebad_start (FFEBAD_DERIVTYP_ACCESS);
06065       ffebad_here (0, ffelex_token_where_line (access),
06066        ffelex_token_where_column (access));
06067       ffebad_finish ();
06068       access = NULL;
06069     }
06070 
06071   b = ffestw_update (ffestw_push (NULL));
06072   ffestw_set_top_do (b, NULL);
06073   ffestw_set_state (b, FFESTV_stateTYPE);
06074   ffestw_set_blocknum (b, 0);
06075   ffestw_set_shriek (b, ffestc_shriek_type_);
06076   ffestw_set_name (b, ffelex_token_use (name));
06077   ffestw_set_substate (b, 0); /* Awaiting private-sequence-stmt and one
06078            component-def-stmt. */
06079 
06080   ffestd_R424 (access, access_kw, name);
06081 
06082   ffe_init_4 ();
06083 }
06084 
06085 /* ffestc_R425 -- END TYPE statement
06086 
06087    ffestc_R425(name_token);
06088 
06089    Make sure ffestc_kind_ identifies a TYPE definition.  If not
06090    NULL, make sure name_token gives the correct name.  Implement the end
06091    of the type definition.  */
06092 
06093 void
06094 ffestc_R425 (ffelexToken name)
06095 {
06096   ffestc_check_simple_ ();
06097   if (ffestc_order_type_ () != FFESTC_orderOK_)
06098     return;
06099   ffestc_labeldef_useless_ ();
06100 
06101   if (ffestw_substate (ffestw_stack_top ()) != 2)
06102     {
06103       ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS);
06104       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
06105        ffelex_token_where_column (ffesta_tokens[0]));
06106       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
06107       ffebad_finish ();
06108     }
06109 
06110   if ((name != NULL)
06111     && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
06112     {
06113       ffebad_start (FFEBAD_TYPE_WRONG_NAME);
06114       ffebad_here (0, ffelex_token_where_line (name),
06115        ffelex_token_where_column (name));
06116       ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
06117        ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
06118       ffebad_finish ();
06119     }
06120 
06121   ffestc_shriek_type_ (TRUE);
06122 }
06123 
06124 /* ffestc_R426_start -- component-declaration-stmt
06125 
06126    ffestc_R426_start(...);
06127 
06128    Verify that R426 component-declaration-stmt is
06129    valid here and implement.  */
06130 
06131 void
06132 ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind,
06133        ffelexToken kindt, ffebld len, ffelexToken lent)
06134 {
06135   ffestc_check_start_ ();
06136   if (ffestc_order_component_ () != FFESTC_orderOK_)
06137     {
06138       ffestc_local_.decl.is_R426 = 0;
06139       return;
06140     }
06141   ffestc_labeldef_useless_ ();
06142 
06143   switch (ffestw_state (ffestw_stack_top ()))
06144     {
06145     case FFESTV_stateSTRUCTURE:
06146     case FFESTV_stateMAP:
06147       ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
06148                  member. */
06149       break;
06150 
06151     case FFESTV_stateTYPE:
06152       ffestw_set_substate (ffestw_stack_top (), 2);
06153       break;
06154 
06155     default:
06156       assert ("Component parent state invalid" == NULL);
06157       break;
06158     }
06159 }
06160 
06161 /* ffestc_R426_attrib -- type attribute
06162 
06163    ffestc_R426_attrib(...);
06164 
06165    Verify that R426 component-declaration-stmt attribute
06166    is valid here and implement.  */
06167 
06168 void
06169 ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt,
06170         ffestrOther intent_kw, ffesttDimList dims)
06171 {
06172   ffestc_check_attrib_ ();
06173 }
06174 
06175 /* ffestc_R426_item -- declared object
06176 
06177    ffestc_R426_item(...);
06178 
06179    Establish type for a particular object.  */
06180 
06181 void
06182 ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt,
06183         ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
06184       ffelexToken initt, bool clist)
06185 {
06186   ffestc_check_item_ ();
06187   assert (name != NULL);
06188   assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
06189   assert (kind == NULL);  /* No way an expression should get here. */
06190 
06191   if ((dims != NULL) || (init != NULL) || clist)
06192     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
06193 }
06194 
06195 /* ffestc_R426_itemstartvals -- Start list of values
06196 
06197    ffestc_R426_itemstartvals();
06198 
06199    Gonna specify values for the object now.  */
06200 
06201 void
06202 ffestc_R426_itemstartvals ()
06203 {
06204   ffestc_check_item_startvals_ ();
06205 }
06206 
06207 /* ffestc_R426_itemvalue -- Source value
06208 
06209    ffestc_R426_itemvalue(repeat,repeat_token,value,value_token);
06210 
06211    Make sure repeat and value are valid for the object being initialized.  */
06212 
06213 void
06214 ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token,
06215            ffebld value, ffelexToken value_token)
06216 {
06217   ffestc_check_item_value_ ();
06218 }
06219 
06220 /* ffestc_R426_itemendvals -- End list of values
06221 
06222    ffelexToken t;  // the SLASH token that ends the list.
06223    ffestc_R426_itemendvals(t);
06224 
06225    No more values, might specify more objects now.  */
06226 
06227 void
06228 ffestc_R426_itemendvals (ffelexToken t)
06229 {
06230   ffestc_check_item_endvals_ ();
06231 }
06232 
06233 /* ffestc_R426_finish -- Done
06234 
06235    ffestc_R426_finish();
06236 
06237    Just wrap up any local activities.  */
06238 
06239 void
06240 ffestc_R426_finish ()
06241 {
06242   ffestc_check_finish_ ();
06243 }
06244 
06245 #endif
06246 /* ffestc_R501_start -- type-declaration-stmt
06247 
06248    ffestc_R501_start(...);
06249 
06250    Verify that R501 type-declaration-stmt is
06251    valid here and implement.  */
06252 
06253 void
06254 ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
06255        ffelexToken kindt, ffebld len, ffelexToken lent)
06256 {
06257   ffestc_check_start_ ();
06258   if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
06259     {
06260       ffestc_local_.decl.is_R426 = 0;
06261       return;
06262     }
06263   ffestc_labeldef_useless_ ();
06264 
06265   ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
06266 }
06267 
06268 /* ffestc_R501_attrib -- type attribute
06269 
06270    ffestc_R501_attrib(...);
06271 
06272    Verify that R501 type-declaration-stmt attribute
06273    is valid here and implement.  */
06274 
06275 void
06276 ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
06277         ffestrOther intent_kw UNUSED,
06278         ffesttDimList dims UNUSED)
06279 {
06280   ffestc_check_attrib_ ();
06281 
06282   switch (attrib)
06283     {
06284 #if FFESTR_F90
06285     case FFESTP_attribALLOCATABLE:
06286       break;
06287 #endif
06288 
06289     case FFESTP_attribDIMENSION:
06290       ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
06291       break;
06292 
06293     case FFESTP_attribEXTERNAL:
06294       break;
06295 
06296 #if FFESTR_F90
06297     case FFESTP_attribINTENT:
06298       break;
06299 #endif
06300 
06301     case FFESTP_attribINTRINSIC:
06302       break;
06303 
06304 #if FFESTR_F90
06305     case FFESTP_attribOPTIONAL:
06306       break;
06307 #endif
06308 
06309     case FFESTP_attribPARAMETER:
06310       break;
06311 
06312 #if FFESTR_F90
06313     case FFESTP_attribPOINTER:
06314       break;
06315 #endif
06316 
06317 #if FFESTR_F90
06318     case FFESTP_attribPRIVATE:
06319       break;
06320 
06321     case FFESTP_attribPUBLIC:
06322       break;
06323 #endif
06324 
06325     case FFESTP_attribSAVE:
06326       switch (ffestv_save_state_)
06327   {
06328   case FFESTV_savestateNONE:
06329     ffestv_save_state_ = FFESTV_savestateSPECIFIC;
06330     ffestv_save_line_
06331       = ffewhere_line_use (ffelex_token_where_line (attribt));
06332     ffestv_save_col_
06333       = ffewhere_column_use (ffelex_token_where_column (attribt));
06334     break;
06335 
06336   case FFESTV_savestateSPECIFIC:
06337   case FFESTV_savestateANY:
06338     break;
06339 
06340   case FFESTV_savestateALL:
06341     if (ffe_is_pedantic ())
06342       {
06343         ffebad_start (FFEBAD_CONFLICTING_SAVES);
06344         ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
06345         ffebad_here (1, ffelex_token_where_line (attribt),
06346          ffelex_token_where_column (attribt));
06347         ffebad_finish ();
06348       }
06349     ffestv_save_state_ = FFESTV_savestateANY;
06350     break;
06351 
06352   default:
06353     assert ("unexpected save state" == NULL);
06354     break;
06355   }
06356       break;
06357 
06358 #if FFESTR_F90
06359     case FFESTP_attribTARGET:
06360       break;
06361 #endif
06362 
06363     default:
06364       assert ("unexpected attribute" == NULL);
06365       break;
06366     }
06367 }
06368 
06369 /* ffestc_R501_item -- declared object
06370 
06371    ffestc_R501_item(...);
06372 
06373    Establish type for a particular object.  */
06374 
06375 void
06376 ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
06377       ffesttDimList dims, ffebld len, ffelexToken lent,
06378       ffebld init, ffelexToken initt, bool clist)
06379 {
06380   ffesymbol s;
06381   ffesymbol sfn;    /* FUNCTION symbol. */
06382   ffebld array_size;
06383   ffebld extents;
06384   ffesymbolAttrs sa;
06385   ffesymbolAttrs na;
06386   ffestpDimtype nd;
06387   bool is_init = (init != NULL) || clist;
06388   bool is_assumed;
06389   bool is_ugly_assumed;
06390   ffeinfoRank rank;
06391 
06392   ffestc_check_item_ ();
06393   assert (name != NULL);
06394   assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
06395   assert (kind == NULL);  /* No way an expression should get here. */
06396 
06397   ffestc_establish_declinfo_ (kind, kindt, len, lent);
06398 
06399   is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
06400     && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
06401 
06402   if ((dims != NULL) || is_init)
06403     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
06404 
06405   s = ffesymbol_declare_local (name, TRUE);
06406   sa = ffesymbol_attrs (s);
06407 
06408   /* First figure out what kind of object this is based solely on the current
06409      object situation (type params, dimension list, and initialization). */
06410 
06411   na = FFESYMBOL_attrsTYPE;
06412 
06413   if (is_assumed)
06414     na |= FFESYMBOL_attrsANYLEN;
06415 
06416   is_ugly_assumed = (ffe_is_ugly_assumed ()
06417          && ((sa & FFESYMBOL_attrsDUMMY)
06418        || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
06419 
06420   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
06421   switch (nd)
06422     {
06423     case FFESTP_dimtypeNONE:
06424       break;
06425 
06426     case FFESTP_dimtypeKNOWN:
06427       na |= FFESYMBOL_attrsARRAY;
06428       break;
06429 
06430     case FFESTP_dimtypeADJUSTABLE:
06431       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
06432       break;
06433 
06434     case FFESTP_dimtypeASSUMED:
06435       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
06436       break;
06437 
06438     case FFESTP_dimtypeADJUSTABLEASSUMED:
06439       na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
06440   | FFESYMBOL_attrsANYSIZE;
06441       break;
06442 
06443     default:
06444       assert ("unexpected dimtype" == NULL);
06445       na = FFESYMBOL_attrsetNONE;
06446       break;
06447     }
06448 
06449   if (!ffesta_is_entry_valid
06450       && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
06451      == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
06452     na = FFESYMBOL_attrsetNONE;
06453 
06454   if (is_init)
06455     {
06456       if (na == FFESYMBOL_attrsetNONE)
06457   ;
06458       else if (na & (FFESYMBOL_attrsANYLEN
06459          | FFESYMBOL_attrsADJUSTABLE
06460          | FFESYMBOL_attrsANYSIZE))
06461   na = FFESYMBOL_attrsetNONE;
06462       else
06463   na |= FFESYMBOL_attrsINIT;
06464     }
06465 
06466   /* Now figure out what kind of object we've got based on previous
06467      declarations of or references to the object. */
06468 
06469   if (na == FFESYMBOL_attrsetNONE)
06470     ;
06471   else if (!ffesymbol_is_specable (s)
06472      && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
06473     && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
06474          || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
06475     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
06476            dimension/init UNDERSTOODs. */
06477   else if (sa & FFESYMBOL_attrsANY)
06478     na = sa;
06479   else if ((sa & na)
06480      || ((sa & (FFESYMBOL_attrsSFARG
06481           | FFESYMBOL_attrsADJUSTS))
06482          && (na & (FFESYMBOL_attrsARRAY
06483        | FFESYMBOL_attrsANYLEN)))
06484      || ((sa & FFESYMBOL_attrsRESULT)
06485          && (na & (FFESYMBOL_attrsARRAY
06486        | FFESYMBOL_attrsINIT)))
06487      || ((sa & (FFESYMBOL_attrsSFUNC
06488           | FFESYMBOL_attrsEXTERNAL
06489           | FFESYMBOL_attrsINTRINSIC
06490           | FFESYMBOL_attrsINIT))
06491          && (na & (FFESYMBOL_attrsARRAY
06492        | FFESYMBOL_attrsANYLEN
06493        | FFESYMBOL_attrsINIT)))
06494      || ((sa & FFESYMBOL_attrsARRAY)
06495          && !ffesta_is_entry_valid
06496          && (na & FFESYMBOL_attrsANYLEN))
06497      || ((sa & (FFESYMBOL_attrsADJUSTABLE
06498           | FFESYMBOL_attrsANYLEN
06499           | FFESYMBOL_attrsANYSIZE
06500           | FFESYMBOL_attrsDUMMY))
06501          && (na & FFESYMBOL_attrsINIT))
06502      || ((sa & (FFESYMBOL_attrsSAVE
06503           | FFESYMBOL_attrsNAMELIST
06504           | FFESYMBOL_attrsCOMMON
06505           | FFESYMBOL_attrsEQUIV))
06506          && (na & (FFESYMBOL_attrsADJUSTABLE
06507        | FFESYMBOL_attrsANYLEN
06508        | FFESYMBOL_attrsANYSIZE))))
06509     na = FFESYMBOL_attrsetNONE;
06510   else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
06511      && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
06512      && (na & FFESYMBOL_attrsANYLEN))
06513     {       /* If CHARACTER*(*) FOO after PARAMETER FOO. */
06514       na |= FFESYMBOL_attrsTYPE;
06515       ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
06516     }
06517   else
06518     na |= sa;
06519 
06520   /* Now see what we've got for a new object: NONE means a new error cropped
06521      up; ANY means an old error to be ignored; otherwise, everything's ok,
06522      update the object (symbol) and continue on. */
06523 
06524   if (na == FFESYMBOL_attrsetNONE)
06525     {
06526       ffesymbol_error (s, name);
06527       ffestc_parent_ok_ = FALSE;
06528     }
06529   else if (na & FFESYMBOL_attrsANY)
06530     ffestc_parent_ok_ = FALSE;
06531   else
06532     {
06533       ffesymbol_set_attrs (s, na);
06534       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
06535   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
06536       rank = ffesymbol_rank (s);
06537       if (dims != NULL)
06538   {
06539     ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
06540                &array_size,
06541                &extents,
06542                is_ugly_assumed));
06543     ffesymbol_set_arraysize (s, array_size);
06544     ffesymbol_set_extents (s, extents);
06545     if (!(0 && ffe_is_90 ())
06546         && (ffebld_op (array_size) == FFEBLD_opCONTER)
06547         && (ffebld_constant_integerdefault (ffebld_conter (array_size))
06548       == 0))
06549       {
06550         ffebad_start (FFEBAD_ZERO_ARRAY);
06551         ffebad_here (0, ffelex_token_where_line (name),
06552          ffelex_token_where_column (name));
06553         ffebad_finish ();
06554       }
06555   }
06556       if (init != NULL)
06557   {
06558     ffesymbol_set_init (s,
06559             ffeexpr_convert (init, initt, name,
06560                  ffestc_local_.decl.basic_type,
06561                  ffestc_local_.decl.kind_type,
06562                  rank,
06563                  ffestc_local_.decl.size,
06564                  FFEEXPR_contextDATA));
06565     ffecom_notify_init_symbol (s);
06566     ffesymbol_update_init (s);
06567 #if FFEGLOBAL_ENABLED
06568     if (ffesymbol_common (s) != NULL)
06569       ffeglobal_init_common (ffesymbol_common (s), initt);
06570 #endif
06571   }
06572       else if (clist)
06573   {
06574     ffebld symter;
06575 
06576     symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
06577               FFEINTRIN_specNONE,
06578               FFEINTRIN_impNONE);
06579 
06580     ffebld_set_info (symter,
06581          ffeinfo_new (ffestc_local_.decl.basic_type,
06582           ffestc_local_.decl.kind_type,
06583           rank,
06584           FFEINFO_kindNONE,
06585           FFEINFO_whereNONE,
06586           ffestc_local_.decl.size));
06587     ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
06588   }
06589       if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
06590   {
06591     ffesymbol_set_info (s,
06592             ffeinfo_new (ffestc_local_.decl.basic_type,
06593              ffestc_local_.decl.kind_type,
06594              rank,
06595              ffesymbol_kind (s),
06596              ffesymbol_where (s),
06597              ffestc_local_.decl.size));
06598     if ((na & FFESYMBOL_attrsRESULT)
06599         && ((sfn = ffesymbol_funcresult (s)) != NULL))
06600       {
06601         ffesymbol_set_info (sfn,
06602           ffeinfo_new (ffestc_local_.decl.basic_type,
06603                  ffestc_local_.decl.kind_type,
06604                  rank,
06605                  ffesymbol_kind (sfn),
06606                  ffesymbol_where (sfn),
06607                  ffestc_local_.decl.size));
06608         ffesymbol_signal_unreported (sfn);
06609       }
06610   }
06611       else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
06612          || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
06613          || ((ffestc_local_.decl.basic_type
06614         == FFEINFO_basictypeCHARACTER)
06615        && (ffestc_local_.decl.size != ffesymbol_size (s))))
06616   {     /* Explicit type disagrees with established
06617            implicit type. */
06618     ffesymbol_error (s, name);
06619   }
06620 
06621       if ((na & FFESYMBOL_attrsADJUSTS)
06622     && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
06623         || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
06624   ffesymbol_error (s, name);
06625 
06626       ffesymbol_signal_unreported (s);
06627       ffestc_parent_ok_ = TRUE;
06628     }
06629 }
06630 
06631 /* ffestc_R501_itemstartvals -- Start list of values
06632 
06633    ffestc_R501_itemstartvals();
06634 
06635    Gonna specify values for the object now.  */
06636 
06637 void
06638 ffestc_R501_itemstartvals ()
06639 {
06640   ffestc_check_item_startvals_ ();
06641 
06642   if (ffestc_parent_ok_)
06643     ffedata_begin (ffestc_local_.decl.initlist);
06644 }
06645 
06646 /* ffestc_R501_itemvalue -- Source value
06647 
06648    ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
06649 
06650    Make sure repeat and value are valid for the object being initialized.  */
06651 
06652 void
06653 ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
06654            ffebld value, ffelexToken value_token)
06655 {
06656   ffetargetIntegerDefault rpt;
06657 
06658   ffestc_check_item_value_ ();
06659 
06660   if (!ffestc_parent_ok_)
06661     return;
06662 
06663   if (repeat == NULL)
06664     rpt = 1;
06665   else if (ffebld_op (repeat) == FFEBLD_opCONTER)
06666     rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
06667   else
06668     {
06669       ffestc_parent_ok_ = FALSE;
06670       ffedata_end (TRUE, NULL);
06671       return;
06672     }
06673 
06674   if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
06675           (repeat_token == NULL) ? value_token : repeat_token)))
06676     ffedata_end (TRUE, NULL);
06677 }
06678 
06679 /* ffestc_R501_itemendvals -- End list of values
06680 
06681    ffelexToken t;  // the SLASH token that ends the list.
06682    ffestc_R501_itemendvals(t);
06683 
06684    No more values, might specify more objects now.  */
06685 
06686 void
06687 ffestc_R501_itemendvals (ffelexToken t)
06688 {
06689   ffestc_check_item_endvals_ ();
06690 
06691   if (ffestc_parent_ok_)
06692     ffestc_parent_ok_ = ffedata_end (FALSE, t);
06693 
06694   if (ffestc_parent_ok_)
06695     ffesymbol_signal_unreported (ffebld_symter (ffebld_head
06696                (ffestc_local_.decl.initlist)));
06697 }
06698 
06699 /* ffestc_R501_finish -- Done
06700 
06701    ffestc_R501_finish();
06702 
06703    Just wrap up any local activities.  */
06704 
06705 void
06706 ffestc_R501_finish ()
06707 {
06708   ffestc_check_finish_ ();
06709 }
06710 
06711 /* ffestc_R519_start -- INTENT statement list begin
06712 
06713    ffestc_R519_start();
06714 
06715    Verify that INTENT is valid here, and begin accepting items in the list.  */
06716 
06717 #if FFESTR_F90
06718 void
06719 ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw)
06720 {
06721   ffestc_check_start_ ();
06722   if (ffestc_order_spec_ () != FFESTC_orderOK_)
06723     {
06724       ffestc_ok_ = FALSE;
06725       return;
06726     }
06727   ffestc_labeldef_useless_ ();
06728 
06729   ffestd_R519_start (intent_kw);
06730 
06731   ffestc_ok_ = TRUE;
06732 }
06733 
06734 /* ffestc_R519_item -- INTENT statement for name
06735 
06736    ffestc_R519_item(name_token);
06737 
06738    Make sure name_token identifies a valid object to be INTENTed.  */
06739 
06740 void
06741 ffestc_R519_item (ffelexToken name)
06742 {
06743   ffestc_check_item_ ();
06744   assert (name != NULL);
06745   if (!ffestc_ok_)
06746     return;
06747 
06748   ffestd_R519_item (name);
06749 }
06750 
06751 /* ffestc_R519_finish -- INTENT statement list complete
06752 
06753    ffestc_R519_finish();
06754 
06755    Just wrap up any local activities.  */
06756 
06757 void
06758 ffestc_R519_finish ()
06759 {
06760   ffestc_check_finish_ ();
06761   if (!ffestc_ok_)
06762     return;
06763 
06764   ffestd_R519_finish ();
06765 }
06766 
06767 /* ffestc_R520_start -- OPTIONAL statement list begin
06768 
06769    ffestc_R520_start();
06770 
06771    Verify that OPTIONAL is valid here, and begin accepting items in the list.  */
06772 
06773 void
06774 ffestc_R520_start ()
06775 {
06776   ffestc_check_start_ ();
06777   if (ffestc_order_spec_ () != FFESTC_orderOK_)
06778     {
06779       ffestc_ok_ = FALSE;
06780       return;
06781     }
06782   ffestc_labeldef_useless_ ();
06783 
06784   ffestd_R520_start ();
06785 
06786   ffestc_ok_ = TRUE;
06787 }
06788 
06789 /* ffestc_R520_item -- OPTIONAL statement for name
06790 
06791    ffestc_R520_item(name_token);
06792 
06793    Make sure name_token identifies a valid object to be OPTIONALed.  */
06794 
06795 void
06796 ffestc_R520_item (ffelexToken name)
06797 {
06798   ffestc_check_item_ ();
06799   assert (name != NULL);
06800   if (!ffestc_ok_)
06801     return;
06802 
06803   ffestd_R520_item (name);
06804 }
06805 
06806 /* ffestc_R520_finish -- OPTIONAL statement list complete
06807 
06808    ffestc_R520_finish();
06809 
06810    Just wrap up any local activities.  */
06811 
06812 void
06813 ffestc_R520_finish ()
06814 {
06815   ffestc_check_finish_ ();
06816   if (!ffestc_ok_)
06817     return;
06818 
06819   ffestd_R520_finish ();
06820 }
06821 
06822 /* ffestc_R521A -- PUBLIC statement
06823 
06824    ffestc_R521A();
06825 
06826    Verify that PUBLIC is valid here.  */
06827 
06828 void
06829 ffestc_R521A ()
06830 {
06831   ffestc_check_simple_ ();
06832   if (ffestc_order_access_ () != FFESTC_orderOK_)
06833     return;
06834   ffestc_labeldef_useless_ ();
06835 
06836   switch (ffestv_access_state_)
06837     {
06838     case FFESTV_accessstateNONE:
06839       ffestv_access_state_ = FFESTV_accessstatePUBLIC;
06840       ffestv_access_line_
06841   = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
06842       ffestv_access_col_
06843   = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
06844       break;
06845 
06846     case FFESTV_accessstateANY:
06847       break;
06848 
06849     case FFESTV_accessstatePUBLIC:
06850     case FFESTV_accessstatePRIVATE:
06851       ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
06852       ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
06853       ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
06854        ffelex_token_where_column (ffesta_tokens[0]));
06855       ffebad_finish ();
06856       ffestv_access_state_ = FFESTV_accessstateANY;
06857       break;
06858 
06859     default:
06860       assert ("unexpected access state" == NULL);
06861       break;
06862     }
06863 
06864   ffestd_R521A ();
06865 }
06866 
06867 /* ffestc_R521Astart -- PUBLIC statement list begin
06868 
06869    ffestc_R521Astart();
06870 
06871    Verify that PUBLIC is valid here, and begin accepting items in the list.  */
06872 
06873 void
06874 ffestc_R521Astart ()
06875 {
06876   ffestc_check_start_ ();
06877   if (ffestc_order_access_ () != FFESTC_orderOK_)
06878     {
06879       ffestc_ok_ = FALSE;
06880       return;
06881     }
06882   ffestc_labeldef_useless_ ();
06883 
06884   ffestd_R521Astart ();
06885 
06886   ffestc_ok_ = TRUE;
06887 }
06888 
06889 /* ffestc_R521Aitem -- PUBLIC statement for name
06890 
06891    ffestc_R521Aitem(name_token);
06892 
06893    Make sure name_token identifies a valid object to be PUBLICed.  */
06894 
06895 void
06896 ffestc_R521Aitem (ffelexToken name)
06897 {
06898   ffestc_check_item_ ();
06899   assert (name != NULL);
06900   if (!ffestc_ok_)
06901     return;
06902 
06903   ffestd_R521Aitem (name);
06904 }
06905 
06906 /* ffestc_R521Afinish -- PUBLIC statement list complete
06907 
06908    ffestc_R521Afinish();
06909 
06910    Just wrap up any local activities.  */
06911 
06912 void
06913 ffestc_R521Afinish ()
06914 {
06915   ffestc_check_finish_ ();
06916   if (!ffestc_ok_)
06917     return;
06918 
06919   ffestd_R521Afinish ();
06920 }
06921 
06922 /* ffestc_R521B -- PRIVATE statement
06923 
06924    ffestc_R521B();
06925 
06926    Verify that PRIVATE is valid here (outside a derived-type statement).  */
06927 
06928 void
06929 ffestc_R521B ()
06930 {
06931   ffestc_check_simple_ ();
06932   if (ffestc_order_access_ () != FFESTC_orderOK_)
06933     return;
06934   ffestc_labeldef_useless_ ();
06935 
06936   switch (ffestv_access_state_)
06937     {
06938     case FFESTV_accessstateNONE:
06939       ffestv_access_state_ = FFESTV_accessstatePRIVATE;
06940       ffestv_access_line_
06941   = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
06942       ffestv_access_col_
06943   = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
06944       break;
06945 
06946     case FFESTV_accessstateANY:
06947       break;
06948 
06949     case FFESTV_accessstatePUBLIC:
06950     case FFESTV_accessstatePRIVATE:
06951       ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
06952       ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
06953       ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
06954        ffelex_token_where_column (ffesta_tokens[0]));
06955       ffebad_finish ();
06956       ffestv_access_state_ = FFESTV_accessstateANY;
06957       break;
06958 
06959     default:
06960       assert ("unexpected access state" == NULL);
06961       break;
06962     }
06963 
06964   ffestd_R521B ();
06965 }
06966 
06967 /* ffestc_R521Bstart -- PRIVATE statement list begin
06968 
06969    ffestc_R521Bstart();
06970 
06971    Verify that PRIVATE is valid here, and begin accepting items in the list.  */
06972 
06973 void
06974 ffestc_R521Bstart ()
06975 {
06976   ffestc_check_start_ ();
06977   if (ffestc_order_access_ () != FFESTC_orderOK_)
06978     {
06979       ffestc_ok_ = FALSE;
06980       return;
06981     }
06982   ffestc_labeldef_useless_ ();
06983 
06984   ffestd_R521Bstart ();
06985 
06986   ffestc_ok_ = TRUE;
06987 }
06988 
06989 /* ffestc_R521Bitem -- PRIVATE statement for name
06990 
06991    ffestc_R521Bitem(name_token);
06992 
06993    Make sure name_token identifies a valid object to be PRIVATEed.  */
06994 
06995 void
06996 ffestc_R521Bitem (ffelexToken name)
06997 {
06998   ffestc_check_item_ ();
06999   assert (name != NULL);
07000   if (!ffestc_ok_)
07001     return;
07002 
07003   ffestd_R521Bitem (name);
07004 }
07005 
07006 /* ffestc_R521Bfinish -- PRIVATE statement list complete
07007 
07008    ffestc_R521Bfinish();
07009 
07010    Just wrap up any local activities.  */
07011 
07012 void
07013 ffestc_R521Bfinish ()
07014 {
07015   ffestc_check_finish_ ();
07016   if (!ffestc_ok_)
07017     return;
07018 
07019   ffestd_R521Bfinish ();
07020 }
07021 
07022 #endif
07023 /* ffestc_R522 -- SAVE statement with no list
07024 
07025    ffestc_R522();
07026 
07027    Verify that SAVE is valid here, and flag everything as SAVEd.  */
07028 
07029 void
07030 ffestc_R522 ()
07031 {
07032   ffestc_check_simple_ ();
07033   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
07034     return;
07035   ffestc_labeldef_useless_ ();
07036 
07037   switch (ffestv_save_state_)
07038     {
07039     case FFESTV_savestateNONE:
07040       ffestv_save_state_ = FFESTV_savestateALL;
07041       ffestv_save_line_
07042   = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
07043       ffestv_save_col_
07044   = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
07045       break;
07046 
07047     case FFESTV_savestateANY:
07048       break;
07049 
07050     case FFESTV_savestateSPECIFIC:
07051     case FFESTV_savestateALL:
07052       if (ffe_is_pedantic ())
07053   {
07054     ffebad_start (FFEBAD_CONFLICTING_SAVES);
07055     ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
07056     ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
07057            ffelex_token_where_column (ffesta_tokens[0]));
07058     ffebad_finish ();
07059   }
07060       ffestv_save_state_ = FFESTV_savestateALL;
07061       break;
07062 
07063     default:
07064       assert ("unexpected save state" == NULL);
07065       break;
07066     }
07067 
07068   ffe_set_is_saveall (TRUE);
07069 
07070   ffestd_R522 ();
07071 }
07072 
07073 /* ffestc_R522start -- SAVE statement list begin
07074 
07075    ffestc_R522start();
07076 
07077    Verify that SAVE is valid here, and begin accepting items in the list.  */
07078 
07079 void
07080 ffestc_R522start ()
07081 {
07082   ffestc_check_start_ ();
07083   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
07084     {
07085       ffestc_ok_ = FALSE;
07086       return;
07087     }
07088   ffestc_labeldef_useless_ ();
07089 
07090   switch (ffestv_save_state_)
07091     {
07092     case FFESTV_savestateNONE:
07093       ffestv_save_state_ = FFESTV_savestateSPECIFIC;
07094       ffestv_save_line_
07095   = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
07096       ffestv_save_col_
07097   = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
07098       break;
07099 
07100     case FFESTV_savestateSPECIFIC:
07101     case FFESTV_savestateANY:
07102       break;
07103 
07104     case FFESTV_savestateALL:
07105       if (ffe_is_pedantic ())
07106   {
07107     ffebad_start (FFEBAD_CONFLICTING_SAVES);
07108     ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
07109     ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
07110            ffelex_token_where_column (ffesta_tokens[0]));
07111     ffebad_finish ();
07112   }
07113       ffestv_save_state_ = FFESTV_savestateANY;
07114       break;
07115 
07116     default:
07117       assert ("unexpected save state" == NULL);
07118       break;
07119     }
07120 
07121   ffestd_R522start ();
07122 
07123   ffestc_ok_ = TRUE;
07124 }
07125 
07126 /* ffestc_R522item_object -- SAVE statement for object-name
07127 
07128    ffestc_R522item_object(name_token);
07129 
07130    Make sure name_token identifies a valid object to be SAVEd.  */
07131 
07132 void
07133 ffestc_R522item_object (ffelexToken name)
07134 {
07135   ffesymbol s;
07136   ffesymbolAttrs sa;
07137   ffesymbolAttrs na;
07138 
07139   ffestc_check_item_ ();
07140   assert (name != NULL);
07141   if (!ffestc_ok_)
07142     return;
07143 
07144   s = ffesymbol_declare_local (name, FALSE);
07145   sa = ffesymbol_attrs (s);
07146 
07147   /* Figure out what kind of object we've got based on previous declarations
07148      of or references to the object. */
07149 
07150   if (!ffesymbol_is_specable (s)
07151       && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
07152     || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
07153     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
07154   else if (sa & FFESYMBOL_attrsANY)
07155     na = sa;
07156   else if (!(sa & ~(FFESYMBOL_attrsARRAY
07157         | FFESYMBOL_attrsEQUIV
07158         | FFESYMBOL_attrsINIT
07159         | FFESYMBOL_attrsNAMELIST
07160         | FFESYMBOL_attrsSFARG
07161         | FFESYMBOL_attrsTYPE)))
07162     na = sa | FFESYMBOL_attrsSAVE;
07163   else
07164     na = FFESYMBOL_attrsetNONE;
07165 
07166   /* Now see what we've got for a new object: NONE means a new error cropped
07167      up; ANY means an old error to be ignored; otherwise, everything's ok,
07168      update the object (symbol) and continue on. */
07169 
07170   if (na == FFESYMBOL_attrsetNONE)
07171     ffesymbol_error (s, name);
07172   else if (!(na & FFESYMBOL_attrsANY))
07173     {
07174       ffesymbol_set_attrs (s, na);
07175       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
07176   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
07177       ffesymbol_update_save (s);
07178       ffesymbol_signal_unreported (s);
07179     }
07180 
07181   ffestd_R522item_object (name);
07182 }
07183 
07184 /* ffestc_R522item_cblock -- SAVE statement for common-block-name
07185 
07186    ffestc_R522item_cblock(name_token);
07187 
07188    Make sure name_token identifies a valid common block to be SAVEd.  */
07189 
07190 void
07191 ffestc_R522item_cblock (ffelexToken name)
07192 {
07193   ffesymbol s;
07194   ffesymbolAttrs sa;
07195   ffesymbolAttrs na;
07196 
07197   ffestc_check_item_ ();
07198   assert (name != NULL);
07199   if (!ffestc_ok_)
07200     return;
07201 
07202   s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
07203             ffelex_token_where_column (ffesta_tokens[0]));
07204   sa = ffesymbol_attrs (s);
07205 
07206   /* Figure out what kind of object we've got based on previous declarations
07207      of or references to the object. */
07208 
07209   if (!ffesymbol_is_specable (s))
07210     na = FFESYMBOL_attrsetNONE;
07211   else if (sa & FFESYMBOL_attrsANY)
07212     na = sa;      /* Already have an error here, say nothing. */
07213   else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
07214     na = sa | FFESYMBOL_attrsSAVECBLOCK;
07215   else
07216     na = FFESYMBOL_attrsetNONE;
07217 
07218   /* Now see what we've got for a new object: NONE means a new error cropped
07219      up; ANY means an old error to be ignored; otherwise, everything's ok,
07220      update the object (symbol) and continue on. */
07221 
07222   if (na == FFESYMBOL_attrsetNONE)
07223     ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
07224   else if (!(na & FFESYMBOL_attrsANY))
07225     {
07226       ffesymbol_set_attrs (s, na);
07227       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
07228       ffesymbol_update_save (s);
07229       ffesymbol_signal_unreported (s);
07230     }
07231 
07232   ffestd_R522item_cblock (name);
07233 }
07234 
07235 /* ffestc_R522finish -- SAVE statement list complete
07236 
07237    ffestc_R522finish();
07238 
07239    Just wrap up any local activities.  */
07240 
07241 void
07242 ffestc_R522finish ()
07243 {
07244   ffestc_check_finish_ ();
07245   if (!ffestc_ok_)
07246     return;
07247 
07248   ffestd_R522finish ();
07249 }
07250 
07251 /* ffestc_R524_start -- DIMENSION statement list begin
07252 
07253    ffestc_R524_start(bool virtual);
07254 
07255    Verify that DIMENSION is valid here, and begin accepting items in the
07256    list.  */
07257 
07258 void
07259 ffestc_R524_start (bool virtual)
07260 {
07261   ffestc_check_start_ ();
07262   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
07263     {
07264       ffestc_ok_ = FALSE;
07265       return;
07266     }
07267   ffestc_labeldef_useless_ ();
07268 
07269   ffestd_R524_start (virtual);
07270 
07271   ffestc_ok_ = TRUE;
07272 }
07273 
07274 /* ffestc_R524_item -- DIMENSION statement for object-name
07275 
07276    ffestc_R524_item(name_token,dim_list);
07277 
07278    Make sure name_token identifies a valid object to be DIMENSIONd.  */
07279 
07280 void
07281 ffestc_R524_item (ffelexToken name, ffesttDimList dims)
07282 {
07283   ffesymbol s;
07284   ffebld array_size;
07285   ffebld extents;
07286   ffesymbolAttrs sa;
07287   ffesymbolAttrs na;
07288   ffestpDimtype nd;
07289   ffeinfoRank rank;
07290   bool is_ugly_assumed;
07291 
07292   ffestc_check_item_ ();
07293   assert (name != NULL);
07294   assert (dims != NULL);
07295   if (!ffestc_ok_)
07296     return;
07297 
07298   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
07299 
07300   s = ffesymbol_declare_local (name, FALSE);
07301   sa = ffesymbol_attrs (s);
07302 
07303   /* First figure out what kind of object this is based solely on the current
07304      object situation (dimension list). */
07305 
07306   is_ugly_assumed = (ffe_is_ugly_assumed ()
07307          && ((sa & FFESYMBOL_attrsDUMMY)
07308        || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
07309 
07310   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
07311   switch (nd)
07312     {
07313     case FFESTP_dimtypeKNOWN:
07314       na = FFESYMBOL_attrsARRAY;
07315       break;
07316 
07317     case FFESTP_dimtypeADJUSTABLE:
07318       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
07319       break;
07320 
07321     case FFESTP_dimtypeASSUMED:
07322       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
07323       break;
07324 
07325     case FFESTP_dimtypeADJUSTABLEASSUMED:
07326       na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
07327   | FFESYMBOL_attrsANYSIZE;
07328       break;
07329 
07330     default:
07331       assert ("Unexpected dims type" == NULL);
07332       na = FFESYMBOL_attrsetNONE;
07333       break;
07334     }
07335 
07336   /* Now figure out what kind of object we've got based on previous
07337      declarations of or references to the object. */
07338 
07339   if (!ffesymbol_is_specable (s))
07340     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
07341   else if (sa & FFESYMBOL_attrsANY)
07342     na = FFESYMBOL_attrsANY;
07343   else if (!ffesta_is_entry_valid
07344      && (sa & FFESYMBOL_attrsANYLEN))
07345     na = FFESYMBOL_attrsetNONE;
07346   else if ((sa & FFESYMBOL_attrsARRAY)
07347      || ((sa & (FFESYMBOL_attrsCOMMON
07348           | FFESYMBOL_attrsEQUIV
07349           | FFESYMBOL_attrsNAMELIST
07350           | FFESYMBOL_attrsSAVE))
07351          && (na & (FFESYMBOL_attrsADJUSTABLE
07352        | FFESYMBOL_attrsANYSIZE))))
07353     na = FFESYMBOL_attrsetNONE;
07354   else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
07355         | FFESYMBOL_attrsANYLEN
07356         | FFESYMBOL_attrsANYSIZE
07357         | FFESYMBOL_attrsCOMMON
07358         | FFESYMBOL_attrsDUMMY
07359         | FFESYMBOL_attrsEQUIV
07360         | FFESYMBOL_attrsNAMELIST
07361         | FFESYMBOL_attrsSAVE
07362         | FFESYMBOL_attrsTYPE)))
07363     na |= sa;
07364   else
07365     na = FFESYMBOL_attrsetNONE;
07366 
07367   /* Now see what we've got for a new object: NONE means a new error cropped
07368      up; ANY means an old error to be ignored; otherwise, everything's ok,
07369      update the object (symbol) and continue on. */
07370 
07371   if (na == FFESYMBOL_attrsetNONE)
07372     ffesymbol_error (s, name);
07373   else if (!(na & FFESYMBOL_attrsANY))
07374     {
07375       ffesymbol_set_attrs (s, na);
07376       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
07377       ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
07378                  &array_size,
07379                  &extents,
07380                  is_ugly_assumed));
07381       ffesymbol_set_arraysize (s, array_size);
07382       ffesymbol_set_extents (s, extents);
07383       if (!(0 && ffe_is_90 ())
07384     && (ffebld_op (array_size) == FFEBLD_opCONTER)
07385     && (ffebld_constant_integerdefault (ffebld_conter (array_size))
07386         == 0))
07387   {
07388     ffebad_start (FFEBAD_ZERO_ARRAY);
07389     ffebad_here (0, ffelex_token_where_line (name),
07390            ffelex_token_where_column (name));
07391     ffebad_finish ();
07392   }
07393       ffesymbol_set_info (s,
07394         ffeinfo_new (ffesymbol_basictype (s),
07395                ffesymbol_kindtype (s),
07396                rank,
07397                ffesymbol_kind (s),
07398                ffesymbol_where (s),
07399                ffesymbol_size (s)));
07400     }
07401 
07402   ffesymbol_signal_unreported (s);
07403 
07404   ffestd_R524_item (name, dims);
07405 }
07406 
07407 /* ffestc_R524_finish -- DIMENSION statement list complete
07408 
07409    ffestc_R524_finish();
07410 
07411    Just wrap up any local activities.  */
07412 
07413 void
07414 ffestc_R524_finish ()
07415 {
07416   ffestc_check_finish_ ();
07417   if (!ffestc_ok_)
07418     return;
07419 
07420   ffestd_R524_finish ();
07421 }
07422 
07423 /* ffestc_R525_start -- ALLOCATABLE statement list begin
07424 
07425    ffestc_R525_start();
07426 
07427    Verify that ALLOCATABLE is valid here, and begin accepting items in the
07428    list.  */
07429 
07430 #if FFESTR_F90
07431 void
07432 ffestc_R525_start ()
07433 {
07434   ffestc_check_start_ ();
07435   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
07436     {
07437       ffestc_ok_ = FALSE;
07438       return;
07439     }
07440   ffestc_labeldef_useless_ ();
07441 
07442   ffestd_R525_start ();
07443 
07444   ffestc_ok_ = TRUE;
07445 }
07446 
07447 /* ffestc_R525_item -- ALLOCATABLE statement for object-name
07448 
07449    ffestc_R525_item(name_token,dim_list);
07450 
07451    Make sure name_token identifies a valid object to be ALLOCATABLEd.  */
07452 
07453 void
07454 ffestc_R525_item (ffelexToken name, ffesttDimList dims)
07455 {
07456   ffestc_check_item_ ();
07457   assert (name != NULL);
07458   if (!ffestc_ok_)
07459     return;
07460 
07461   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
07462 
07463   ffestd_R525_item (name, dims);
07464 }
07465 
07466 /* ffestc_R525_finish -- ALLOCATABLE statement list complete
07467 
07468    ffestc_R525_finish();
07469 
07470    Just wrap up any local activities.  */
07471 
07472 void
07473 ffestc_R525_finish ()
07474 {
07475   ffestc_check_finish_ ();
07476   if (!ffestc_ok_)
07477     return;
07478 
07479   ffestd_R525_finish ();
07480 }
07481 
07482 /* ffestc_R526_start -- POINTER statement list begin
07483 
07484    ffestc_R526_start();
07485 
07486    Verify that POINTER is valid here, and begin accepting items in the
07487    list.  */
07488 
07489 void
07490 ffestc_R526_start ()
07491 {
07492   ffestc_check_start_ ();
07493   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
07494     {
07495       ffestc_ok_ = FALSE;
07496       return;
07497     }
07498   ffestc_labeldef_useless_ ();
07499 
07500   ffestd_R526_start ();
07501 
07502   ffestc_ok_ = TRUE;
07503 }
07504 
07505 /* ffestc_R526_item -- POINTER statement for object-name
07506 
07507    ffestc_R526_item(name_token,dim_list);
07508 
07509    Make sure name_token identifies a valid object to be POINTERd.  */
07510 
07511 void
07512 ffestc_R526_item (ffelexToken name, ffesttDimList dims)
07513 {
07514   ffestc_check_item_ ();
07515   assert (name != NULL);
07516   if (!ffestc_ok_)
07517     return;
07518 
07519   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
07520 
07521   ffestd_R526_item (name, dims);
07522 }
07523 
07524 /* ffestc_R526_finish -- POINTER statement list complete
07525 
07526    ffestc_R526_finish();
07527 
07528    Just wrap up any local activities.  */
07529 
07530 void
07531 ffestc_R526_finish ()
07532 {
07533   ffestc_check_finish_ ();
07534   if (!ffestc_ok_)
07535     return;
07536 
07537   ffestd_R526_finish ();
07538 }
07539 
07540 /* ffestc_R527_start -- TARGET statement list begin
07541 
07542    ffestc_R527_start();
07543 
07544    Verify that TARGET is valid here, and begin accepting items in the
07545    list.  */
07546 
07547 void
07548 ffestc_R527_start ()
07549 {
07550   ffestc_check_start_ ();
07551   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
07552     {
07553       ffestc_ok_ = FALSE;
07554       return;
07555     }
07556   ffestc_labeldef_useless_ ();
07557 
07558   ffestd_R527_start ();
07559 
07560   ffestc_ok_ = TRUE;
07561 }
07562 
07563 /* ffestc_R527_item -- TARGET statement for object-name
07564 
07565    ffestc_R527_item(name_token,dim_list);
07566 
07567    Make sure name_token identifies a valid object to be TARGETd.  */
07568 
07569 void
07570 ffestc_R527_item (ffelexToken name, ffesttDimList dims)
07571 {
07572   ffestc_check_item_ ();
07573   assert (name != NULL);
07574   if (!ffestc_ok_)
07575     return;
07576 
07577   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
07578 
07579   ffestd_R527_item (name, dims);
07580 }
07581 
07582 /* ffestc_R527_finish -- TARGET statement list complete
07583 
07584    ffestc_R527_finish();
07585 
07586    Just wrap up any local activities.  */
07587 
07588 void
07589 ffestc_R527_finish ()
07590 {
07591   ffestc_check_finish_ ();
07592   if (!ffestc_ok_)
07593     return;
07594 
07595   ffestd_R527_finish ();
07596 }
07597 
07598 #endif
07599 /* ffestc_R528_start -- DATA statement list begin
07600 
07601    ffestc_R528_start();
07602 
07603    Verify that DATA is valid here, and begin accepting items in the list.  */
07604 
07605 void
07606 ffestc_R528_start ()
07607 {
07608   ffestcOrder_ order;
07609 
07610   ffestc_check_start_ ();
07611   if (ffe_is_pedantic_not_90 ())
07612     order = ffestc_order_data77_ ();
07613   else
07614     order = ffestc_order_data_ ();
07615   if (order != FFESTC_orderOK_)
07616     {
07617       ffestc_ok_ = FALSE;
07618       return;
07619     }
07620   ffestc_labeldef_useless_ ();
07621 
07622   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
07623 
07624 #if 1
07625   ffestc_local_.data.objlist = NULL;
07626 #else
07627   ffestd_R528_start_ ();
07628 #endif
07629 
07630   ffestc_ok_ = TRUE;
07631 }
07632 
07633 /* ffestc_R528_item_object -- DATA statement target object
07634 
07635    ffestc_R528_item_object(object,object_token);
07636 
07637    Make sure object is valid to be DATAd.  */
07638 
07639 void
07640 ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
07641 {
07642   ffestc_check_item_ ();
07643   if (!ffestc_ok_)
07644     return;
07645 
07646 #if 1
07647   if (ffestc_local_.data.objlist == NULL)
07648     ffebld_init_list (&ffestc_local_.data.objlist,
07649           &ffestc_local_.data.list_bottom);
07650 
07651   ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
07652 #else
07653   ffestd_R528_item_object_ (expr, expr_token);
07654 #endif
07655 }
07656 
07657 /* ffestc_R528_item_startvals -- DATA statement start list of values
07658 
07659    ffestc_R528_item_startvals();
07660 
07661    No more objects, gonna specify values for the list of objects now.  */
07662 
07663 void
07664 ffestc_R528_item_startvals ()
07665 {
07666   ffestc_check_item_startvals_ ();
07667   if (!ffestc_ok_)
07668     return;
07669 
07670 #if 1
07671   assert (ffestc_local_.data.objlist != NULL);
07672   ffebld_end_list (&ffestc_local_.data.list_bottom);
07673   ffedata_begin (ffestc_local_.data.objlist);
07674 #else
07675   ffestd_R528_item_startvals_ ();
07676 #endif
07677 }
07678 
07679 /* ffestc_R528_item_value -- DATA statement source value
07680 
07681    ffestc_R528_item_value(repeat,repeat_token,value,value_token);
07682 
07683    Make sure repeat and value are valid for the objects being initialized.  */
07684 
07685 void
07686 ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
07687       ffebld value, ffelexToken value_token)
07688 {
07689   ffetargetIntegerDefault rpt;
07690 
07691   ffestc_check_item_value_ ();
07692   if (!ffestc_ok_)
07693     return;
07694 
07695 #if 1
07696   if (repeat == NULL)
07697     rpt = 1;
07698   else if (ffebld_op (repeat) == FFEBLD_opCONTER)
07699     rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
07700   else
07701     {
07702       ffestc_ok_ = FALSE;
07703       ffedata_end (TRUE, NULL);
07704       return;
07705     }
07706 
07707   if (!(ffestc_ok_ = ffedata_value (rpt, value,
07708             (repeat_token == NULL)
07709             ? value_token
07710             : repeat_token)))
07711     ffedata_end (TRUE, NULL);
07712 
07713 #else
07714   ffestd_R528_item_value_ (repeat, value);
07715 #endif
07716 }
07717 
07718 /* ffestc_R528_item_endvals -- DATA statement start list of values
07719 
07720    ffelexToken t;  // the SLASH token that ends the list.
07721    ffestc_R528_item_endvals(t);
07722 
07723    No more values, might specify more objects now.  */
07724 
07725 void
07726 ffestc_R528_item_endvals (ffelexToken t)
07727 {
07728   ffestc_check_item_endvals_ ();
07729   if (!ffestc_ok_)
07730     return;
07731 
07732 #if 1
07733   ffedata_end (!ffestc_ok_, t);
07734   ffestc_local_.data.objlist = NULL;
07735 #else
07736   ffestd_R528_item_endvals_ (t);
07737 #endif
07738 }
07739 
07740 /* ffestc_R528_finish -- DATA statement list complete
07741 
07742    ffestc_R528_finish();
07743 
07744    Just wrap up any local activities.  */
07745 
07746 void
07747 ffestc_R528_finish ()
07748 {
07749   ffestc_check_finish_ ();
07750 
07751 #if 1
07752 #else
07753   ffestd_R528_finish_ ();
07754 #endif
07755 }
07756 
07757 /* ffestc_R537_start -- PARAMETER statement list begin
07758 
07759    ffestc_R537_start();
07760 
07761    Verify that PARAMETER is valid here, and begin accepting items in the
07762    list.  */
07763 
07764 void
07765 ffestc_R537_start ()
07766 {
07767   ffestc_check_start_ ();
07768   if (ffestc_order_parameter_ () != FFESTC_orderOK_)
07769     {
07770       ffestc_ok_ = FALSE;
07771       return;
07772     }
07773   ffestc_labeldef_useless_ ();
07774 
07775   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
07776 
07777   ffestd_R537_start ();
07778 
07779   ffestc_ok_ = TRUE;
07780 }
07781 
07782 /* ffestc_R537_item -- PARAMETER statement assignment
07783 
07784    ffestc_R537_item(dest,dest_token,source,source_token);
07785 
07786    Make sure the source is a valid source for the destination; make the
07787    assignment.  */
07788 
07789 void
07790 ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
07791       ffelexToken source_token)
07792 {
07793   ffesymbol s;
07794 
07795   ffestc_check_item_ ();
07796   if (!ffestc_ok_)
07797     return;
07798 
07799   if ((ffebld_op (dest) == FFEBLD_opANY)
07800       || (ffebld_op (source) == FFEBLD_opANY))
07801     {
07802       if (ffebld_op (dest) == FFEBLD_opSYMTER)
07803   {
07804     s = ffebld_symter (dest);
07805     ffesymbol_set_init (s, ffebld_new_any ());
07806     ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
07807     ffesymbol_signal_unreported (s);
07808   }
07809       ffestd_R537_item (dest, source);
07810       return;
07811     }
07812 
07813   assert (ffebld_op (dest) == FFEBLD_opSYMTER);
07814   assert (ffebld_op (source) == FFEBLD_opCONTER);
07815 
07816   s = ffebld_symter (dest);
07817   if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
07818       && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
07819     {       /* Destination has explicit/implicit
07820            CHARACTER*(*) type; set length. */
07821       ffesymbol_set_info (s,
07822         ffeinfo_new (ffesymbol_basictype (s),
07823                ffesymbol_kindtype (s),
07824                0,
07825                ffesymbol_kind (s),
07826                ffesymbol_where (s),
07827                ffebld_size (source)));
07828       ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
07829     }
07830 
07831   source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
07832          FFEEXPR_contextDATA);
07833 
07834   ffesymbol_set_init (s, source);
07835 
07836   ffesymbol_signal_unreported (s);
07837 
07838   ffestd_R537_item (dest, source);
07839 }
07840 
07841 /* ffestc_R537_finish -- PARAMETER statement list complete
07842 
07843    ffestc_R537_finish();
07844 
07845    Just wrap up any local activities.  */
07846 
07847 void
07848 ffestc_R537_finish ()
07849 {
07850   ffestc_check_finish_ ();
07851   if (!ffestc_ok_)
07852     return;
07853 
07854   ffestd_R537_finish ();
07855 }
07856 
07857 /* ffestc_R539 -- IMPLICIT NONE statement
07858 
07859    ffestc_R539();
07860 
07861    Verify that the IMPLICIT NONE statement is ok here and implement.  */
07862 
07863 void
07864 ffestc_R539 ()
07865 {
07866   ffestc_check_simple_ ();
07867   if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
07868     return;
07869   ffestc_labeldef_useless_ ();
07870 
07871   ffeimplic_none ();
07872 
07873   ffestd_R539 ();
07874 }
07875 
07876 /* ffestc_R539start -- IMPLICIT statement
07877 
07878    ffestc_R539start();
07879 
07880    Verify that the IMPLICIT statement is ok here and implement.  */
07881 
07882 void
07883 ffestc_R539start ()
07884 {
07885   ffestc_check_start_ ();
07886   if (ffestc_order_implicit_ () != FFESTC_orderOK_)
07887     {
07888       ffestc_ok_ = FALSE;
07889       return;
07890     }
07891   ffestc_labeldef_useless_ ();
07892 
07893   ffestd_R539start ();
07894 
07895   ffestc_ok_ = TRUE;
07896 }
07897 
07898 /* ffestc_R539item -- IMPLICIT statement specification (R540)
07899 
07900    ffestc_R539item(...);
07901 
07902    Verify that the type and letter list are all ok and implement.  */
07903 
07904 void
07905 ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
07906      ffebld len, ffelexToken lent, ffesttImpList letters)
07907 {
07908   ffestc_check_item_ ();
07909   if (!ffestc_ok_)
07910     return;
07911 
07912   if ((type == FFESTP_typeCHARACTER) && (len != NULL)
07913       && (ffebld_op (len) == FFEBLD_opSTAR))
07914     {       /* Complain and pretend they're CHARACTER
07915            [*1]. */
07916       ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
07917       ffebad_here (0, ffelex_token_where_line (lent),
07918        ffelex_token_where_column (lent));
07919       ffebad_finish ();
07920       len = NULL;
07921       lent = NULL;
07922     }
07923   ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
07924   ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
07925 
07926   ffestt_implist_drive (letters, ffestc_establish_impletter_);
07927 
07928   ffestd_R539item (type, kind, kindt, len, lent, letters);
07929 }
07930 
07931 /* ffestc_R539finish -- IMPLICIT statement
07932 
07933    ffestc_R539finish();
07934 
07935    Finish up any local activities.  */
07936 
07937 void
07938 ffestc_R539finish ()
07939 {
07940   ffestc_check_finish_ ();
07941   if (!ffestc_ok_)
07942     return;
07943 
07944   ffestd_R539finish ();
07945 }
07946 
07947 /* ffestc_R542_start -- NAMELIST statement list begin
07948 
07949    ffestc_R542_start();
07950 
07951    Verify that NAMELIST is valid here, and begin accepting items in the
07952    list.  */
07953 
07954 void
07955 ffestc_R542_start ()
07956 {
07957   ffestc_check_start_ ();
07958   if (ffestc_order_progspec_ () != FFESTC_orderOK_)
07959     {
07960       ffestc_ok_ = FALSE;
07961       return;
07962     }
07963   ffestc_labeldef_useless_ ();
07964 
07965   if (ffe_is_f2c_library ()
07966       && (ffe_case_source () == FFE_caseNONE))
07967     {
07968       ffebad_start (FFEBAD_NAMELIST_CASE);
07969       ffesta_ffebad_here_current_stmt (0);
07970       ffebad_finish ();
07971     }
07972 
07973   ffestd_R542_start ();
07974 
07975   ffestc_local_.namelist.symbol = NULL;
07976 
07977   ffestc_ok_ = TRUE;
07978 }
07979 
07980 /* ffestc_R542_item_nlist -- NAMELIST statement for group-name
07981 
07982    ffestc_R542_item_nlist(groupname_token);
07983 
07984    Make sure name_token identifies a valid object to be NAMELISTd.  */
07985 
07986 void
07987 ffestc_R542_item_nlist (ffelexToken name)
07988 {
07989   ffesymbol s;
07990 
07991   ffestc_check_item_ ();
07992   assert (name != NULL);
07993   if (!ffestc_ok_)
07994     return;
07995 
07996   if (ffestc_local_.namelist.symbol != NULL)
07997     ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
07998 
07999   s = ffesymbol_declare_local (name, FALSE);
08000 
08001   if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
08002       || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
08003     && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
08004     {
08005       ffestc_parent_ok_ = TRUE;
08006       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
08007   {
08008     ffebld_init_list (ffesymbol_ptr_to_namelist (s),
08009           ffesymbol_ptr_to_listbottom (s));
08010     ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
08011     ffesymbol_set_info (s,
08012             ffeinfo_new (FFEINFO_basictypeNONE,
08013              FFEINFO_kindtypeNONE,
08014              0,
08015              FFEINFO_kindNAMELIST,
08016              FFEINFO_whereLOCAL,
08017              FFETARGET_charactersizeNONE));
08018   }
08019     }
08020   else
08021     {
08022       if (ffesymbol_kind (s) != FFEINFO_kindANY)
08023   ffesymbol_error (s, name);
08024       ffestc_parent_ok_ = FALSE;
08025     }
08026 
08027   ffestc_local_.namelist.symbol = s;
08028 
08029   ffestd_R542_item_nlist (name);
08030 }
08031 
08032 /* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
08033 
08034    ffestc_R542_item_nitem(name_token);
08035 
08036    Make sure name_token identifies a valid object to be NAMELISTd.  */
08037 
08038 void
08039 ffestc_R542_item_nitem (ffelexToken name)
08040 {
08041   ffesymbol s;
08042   ffesymbolAttrs sa;
08043   ffesymbolAttrs na;
08044   ffebld e;
08045 
08046   ffestc_check_item_ ();
08047   assert (name != NULL);
08048   if (!ffestc_ok_)
08049     return;
08050 
08051   s = ffesymbol_declare_local (name, FALSE);
08052   sa = ffesymbol_attrs (s);
08053 
08054   /* Figure out what kind of object we've got based on previous declarations
08055      of or references to the object. */
08056 
08057   if (!ffesymbol_is_specable (s)
08058       && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
08059     || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
08060         && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
08061     na = FFESYMBOL_attrsetNONE;
08062   else if (sa & FFESYMBOL_attrsANY)
08063     na = FFESYMBOL_attrsANY;
08064   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
08065         | FFESYMBOL_attrsARRAY
08066         | FFESYMBOL_attrsCOMMON
08067         | FFESYMBOL_attrsEQUIV
08068         | FFESYMBOL_attrsINIT
08069         | FFESYMBOL_attrsNAMELIST
08070         | FFESYMBOL_attrsSAVE
08071         | FFESYMBOL_attrsSFARG
08072         | FFESYMBOL_attrsTYPE)))
08073     na = sa | FFESYMBOL_attrsNAMELIST;
08074   else
08075     na = FFESYMBOL_attrsetNONE;
08076 
08077   /* Now see what we've got for a new object: NONE means a new error cropped
08078      up; ANY means an old error to be ignored; otherwise, everything's ok,
08079      update the object (symbol) and continue on. */
08080 
08081   if (na == FFESYMBOL_attrsetNONE)
08082     ffesymbol_error (s, name);
08083   else if (!(na & FFESYMBOL_attrsANY))
08084     {
08085       ffesymbol_set_attrs (s, na);
08086       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
08087   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
08088       ffesymbol_set_namelisted (s, TRUE);
08089       ffesymbol_signal_unreported (s);
08090 #if 0       /* No need to establish type yet! */
08091       if (!ffeimplic_establish_symbol (s))
08092   ffesymbol_error (s, name);
08093 #endif
08094     }
08095 
08096   if (ffestc_parent_ok_)
08097     {
08098       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
08099            FFEINTRIN_impNONE);
08100       ffebld_set_info (e,
08101            ffeinfo_new (FFEINFO_basictypeNONE,
08102             FFEINFO_kindtypeNONE, 0,
08103             FFEINFO_kindNONE,
08104             FFEINFO_whereNONE,
08105             FFETARGET_charactersizeNONE));
08106       ffebld_append_item
08107   (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
08108     }
08109 
08110   ffestd_R542_item_nitem (name);
08111 }
08112 
08113 /* ffestc_R542_finish -- NAMELIST statement list complete
08114 
08115    ffestc_R542_finish();
08116 
08117    Just wrap up any local activities.  */
08118 
08119 void
08120 ffestc_R542_finish ()
08121 {
08122   ffestc_check_finish_ ();
08123   if (!ffestc_ok_)
08124     return;
08125 
08126   ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
08127 
08128   ffestd_R542_finish ();
08129 }
08130 
08131 /* ffestc_R544_start -- EQUIVALENCE statement list begin
08132 
08133    ffestc_R544_start();
08134 
08135    Verify that EQUIVALENCE is valid here, and begin accepting items in the
08136    list.  */
08137 
08138 void
08139 ffestc_R544_start ()
08140 {
08141   ffestc_check_start_ ();
08142   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
08143     {
08144       ffestc_ok_ = FALSE;
08145       return;
08146     }
08147   ffestc_labeldef_useless_ ();
08148 
08149   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
08150 
08151   ffestc_ok_ = TRUE;
08152 }
08153 
08154 /* ffestc_R544_item -- EQUIVALENCE statement assignment
08155 
08156    ffestc_R544_item(exprlist);
08157 
08158    Make sure the equivalence is valid, then implement it.  */
08159 
08160 void
08161 ffestc_R544_item (ffesttExprList exprlist)
08162 {
08163   ffestc_check_item_ ();
08164   if (!ffestc_ok_)
08165     return;
08166 
08167   /* First we go through the list and come up with one ffeequiv object that
08168      will describe all items in the list.  When an ffeequiv object is first
08169      found, it is used (else we create one as a "local equiv" for the time
08170      being).  If subsequent ffeequiv objects are found, they are merged with
08171      the first so we end up with one.  However, if more than one COMMON
08172      variable is involved, then an error condition occurs. */
08173 
08174   ffestc_local_.equiv.ok = TRUE;
08175   ffestc_local_.equiv.t = NULL; /* No token yet. */
08176   ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
08177   ffestc_local_.equiv.save = FALSE; /* No SAVEd variables yet. */
08178 
08179   ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
08180   ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
08181   ffebld_end_list (&ffestc_local_.equiv.bottom);
08182 
08183   if (!ffestc_local_.equiv.ok)
08184     return;     /* Something went wrong, stop bothering with
08185            this stuff. */
08186 
08187   if (ffestc_local_.equiv.eq == NULL)
08188     ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */
08189 
08190   /* Append this list of equivalences to list of such lists for this
08191      equivalence. */
08192 
08193   ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
08194     ffestc_local_.equiv.t);
08195   if (ffestc_local_.equiv.save)
08196     ffeequiv_update_save (ffestc_local_.equiv.eq);
08197 }
08198 
08199 /* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
08200 
08201    ffebld expr;
08202    ffelexToken t;
08203    ffestc_R544_equiv_(expr,t);
08204 
08205    Record information, if any, on symbol in expr; if symbol has equivalence
08206    object already, merge with outstanding object if present or make it
08207    the outstanding object.  */
08208 
08209 static void
08210 ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
08211 {
08212   ffesymbol s;
08213 
08214   if (!ffestc_local_.equiv.ok)
08215     return;
08216 
08217   if (ffestc_local_.equiv.t == NULL)
08218     ffestc_local_.equiv.t = t;
08219 
08220   switch (ffebld_op (expr))
08221     {
08222     case FFEBLD_opANY:
08223       return;     /* Don't put this on the list. */
08224 
08225     case FFEBLD_opSYMTER:
08226     case FFEBLD_opARRAYREF:
08227     case FFEBLD_opSUBSTR:
08228       break;      /* All of these are ok. */
08229 
08230     default:
08231       assert ("ffestc_R544_equiv_ bad op" == NULL);
08232       return;
08233     }
08234 
08235   ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
08236 
08237   s = ffeequiv_symbol (expr);
08238 
08239   /* See if symbol has an equivalence object already. */
08240 
08241   if (ffesymbol_equiv (s) != NULL)
08242     {
08243       if (ffestc_local_.equiv.eq == NULL)
08244   ffestc_local_.equiv.eq = ffesymbol_equiv (s); /* New equiv obj. */
08245       else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
08246   {
08247     ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
08248                ffestc_local_.equiv.eq,
08249                t);
08250     if (ffestc_local_.equiv.eq == NULL)
08251       ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */
08252   }
08253     }
08254 
08255   if (ffesymbol_is_save (s))
08256     ffestc_local_.equiv.save = TRUE;
08257 }
08258 
08259 /* ffestc_R544_finish -- EQUIVALENCE statement list complete
08260 
08261    ffestc_R544_finish();
08262 
08263    Just wrap up any local activities.  */
08264 
08265 void
08266 ffestc_R544_finish ()
08267 {
08268   ffestc_check_finish_ ();
08269 }
08270 
08271 /* ffestc_R547_start -- COMMON statement list begin
08272 
08273    ffestc_R547_start();
08274 
08275    Verify that COMMON is valid here, and begin accepting items in the list.  */
08276 
08277 void
08278 ffestc_R547_start ()
08279 {
08280   ffestc_check_start_ ();
08281   if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
08282     {
08283       ffestc_ok_ = FALSE;
08284       return;
08285     }
08286   ffestc_labeldef_useless_ ();
08287 
08288   ffestc_local_.common.symbol = NULL; /* Blank common is the default. */
08289   ffestc_parent_ok_ = TRUE;
08290 
08291   ffestd_R547_start ();
08292 
08293   ffestc_ok_ = TRUE;
08294 }
08295 
08296 /* ffestc_R547_item_object -- COMMON statement for object-name
08297 
08298    ffestc_R547_item_object(name_token,dim_list);
08299 
08300    Make sure name_token identifies a valid object to be COMMONd.  */
08301 
08302 void
08303 ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
08304 {
08305   ffesymbol s;
08306   ffebld array_size;
08307   ffebld extents;
08308   ffesymbolAttrs sa;
08309   ffesymbolAttrs na;
08310   ffestpDimtype nd;
08311   ffebld e;
08312   ffeinfoRank rank;
08313   bool is_ugly_assumed;
08314 
08315   if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
08316     ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */
08317 
08318   ffestc_check_item_ ();
08319   assert (name != NULL);
08320   if (!ffestc_ok_)
08321     return;
08322 
08323   if (dims != NULL)
08324     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
08325 
08326   s = ffesymbol_declare_local (name, FALSE);
08327   sa = ffesymbol_attrs (s);
08328 
08329   /* First figure out what kind of object this is based solely on the current
08330      object situation (dimension list). */
08331 
08332   is_ugly_assumed = (ffe_is_ugly_assumed ()
08333          && ((sa & FFESYMBOL_attrsDUMMY)
08334        || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
08335 
08336   nd = ffestt_dimlist_type (dims, is_ugly_assumed);
08337   switch (nd)
08338     {
08339     case FFESTP_dimtypeNONE:
08340       na = FFESYMBOL_attrsCOMMON;
08341       break;
08342 
08343     case FFESTP_dimtypeKNOWN:
08344       na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
08345       break;
08346 
08347     default:
08348       na = FFESYMBOL_attrsetNONE;
08349       break;
08350     }
08351 
08352   /* Figure out what kind of object we've got based on previous declarations
08353      of or references to the object. */
08354 
08355   if (na == FFESYMBOL_attrsetNONE)
08356     ;
08357   else if (!ffesymbol_is_specable (s))
08358     na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
08359   else if (sa & FFESYMBOL_attrsANY)
08360     na = FFESYMBOL_attrsANY;
08361   else if ((sa & (FFESYMBOL_attrsADJUSTS
08362       | FFESYMBOL_attrsARRAY
08363       | FFESYMBOL_attrsINIT
08364       | FFESYMBOL_attrsSFARG))
08365      && (na & FFESYMBOL_attrsARRAY))
08366     na = FFESYMBOL_attrsetNONE;
08367   else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
08368         | FFESYMBOL_attrsARRAY
08369         | FFESYMBOL_attrsEQUIV
08370         | FFESYMBOL_attrsINIT
08371         | FFESYMBOL_attrsNAMELIST
08372         | FFESYMBOL_attrsSFARG
08373         | FFESYMBOL_attrsTYPE)))
08374     na |= sa;
08375   else
08376     na = FFESYMBOL_attrsetNONE;
08377 
08378   /* Now see what we've got for a new object: NONE means a new error cropped
08379      up; ANY means an old error to be ignored; otherwise, everything's ok,
08380      update the object (symbol) and continue on. */
08381 
08382   if (na == FFESYMBOL_attrsetNONE)
08383     ffesymbol_error (s, name);
08384   else if ((ffesymbol_equiv (s) != NULL)
08385      && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
08386      && (ffeequiv_common (ffesymbol_equiv (s))
08387          != ffestc_local_.common.symbol))
08388     {
08389       /* Oops, just COMMONed a symbol to a different area (via equiv).  */
08390       ffebad_start (FFEBAD_EQUIV_COMMON);
08391       ffebad_here (0, ffelex_token_where_line (name),
08392        ffelex_token_where_column (name));
08393       ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
08394       ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
08395       ffebad_finish ();
08396       ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
08397       ffesymbol_set_info (s, ffeinfo_new_any ());
08398       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
08399       ffesymbol_signal_unreported (s);
08400     }
08401   else if (!(na & FFESYMBOL_attrsANY))
08402     {
08403       ffesymbol_set_attrs (s, na);
08404       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
08405       ffesymbol_set_common (s, ffestc_local_.common.symbol);
08406 #if FFEGLOBAL_ENABLED
08407       if (ffesymbol_is_init (s))
08408   ffeglobal_init_common (ffestc_local_.common.symbol, name);
08409 #endif
08410       if (ffesymbol_is_save (ffestc_local_.common.symbol))
08411   ffesymbol_update_save (s);
08412       if (ffesymbol_equiv (s) != NULL)
08413   {     /* Is this newly COMMONed symbol involved in
08414            an equivalence? */
08415     if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
08416       ffeequiv_set_common (ffesymbol_equiv (s), /* Yes, tell equiv obj. */
08417          ffestc_local_.common.symbol);
08418 #if FFEGLOBAL_ENABLED
08419     if (ffeequiv_is_init (ffesymbol_equiv (s)))
08420       ffeglobal_init_common (ffestc_local_.common.symbol, name);
08421 #endif
08422     if (ffesymbol_is_save (ffestc_local_.common.symbol))
08423       ffeequiv_update_save (ffesymbol_equiv (s));
08424   }
08425       if (dims != NULL)
08426   {
08427     ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
08428                &array_size,
08429                &extents,
08430                is_ugly_assumed));
08431     ffesymbol_set_arraysize (s, array_size);
08432     ffesymbol_set_extents (s, extents);
08433     if (!(0 && ffe_is_90 ())
08434         && (ffebld_op (array_size) == FFEBLD_opCONTER)
08435         && (ffebld_constant_integerdefault (ffebld_conter (array_size))
08436       == 0))
08437       {
08438         ffebad_start (FFEBAD_ZERO_ARRAY);
08439         ffebad_here (0, ffelex_token_where_line (name),
08440          ffelex_token_where_column (name));
08441         ffebad_finish ();
08442       }
08443     ffesymbol_set_info (s,
08444             ffeinfo_new (ffesymbol_basictype (s),
08445              ffesymbol_kindtype (s),
08446              rank,
08447              ffesymbol_kind (s),
08448              ffesymbol_where (s),
08449              ffesymbol_size (s)));
08450   }
08451       ffesymbol_signal_unreported (s);
08452     }
08453 
08454   if (ffestc_parent_ok_)
08455     {
08456       e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
08457            FFEINTRIN_impNONE);
08458       ffebld_set_info (e,
08459            ffeinfo_new (FFEINFO_basictypeNONE,
08460             FFEINFO_kindtypeNONE,
08461             0,
08462             FFEINFO_kindNONE,
08463             FFEINFO_whereNONE,
08464             FFETARGET_charactersizeNONE));
08465       ffebld_append_item
08466   (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
08467     }
08468 
08469   ffestd_R547_item_object (name, dims);
08470 }
08471 
08472 /* ffestc_R547_item_cblock -- COMMON statement for common-block-name
08473 
08474    ffestc_R547_item_cblock(name_token);
08475 
08476    Make sure name_token identifies a valid common block to be COMMONd.  */
08477 
08478 void
08479 ffestc_R547_item_cblock (ffelexToken name)
08480 {
08481   ffesymbol s;
08482   ffesymbolAttrs sa;
08483   ffesymbolAttrs na;
08484 
08485   ffestc_check_item_ ();
08486   if (!ffestc_ok_)
08487     return;
08488 
08489   if (ffestc_local_.common.symbol != NULL)
08490     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
08491 
08492   s = ffesymbol_declare_cblock (name,
08493         ffelex_token_where_line (ffesta_tokens[0]),
08494             ffelex_token_where_column (ffesta_tokens[0]));
08495   sa = ffesymbol_attrs (s);
08496 
08497   /* Figure out what kind of object we've got based on previous declarations
08498      of or references to the object. */
08499 
08500   if (!ffesymbol_is_specable (s))
08501     na = FFESYMBOL_attrsetNONE;
08502   else if (sa & FFESYMBOL_attrsANY)
08503     na = FFESYMBOL_attrsANY;  /* Already have an error here, say nothing. */
08504   else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
08505         | FFESYMBOL_attrsSAVECBLOCK)))
08506     {
08507       if (!(sa & FFESYMBOL_attrsCBLOCK))
08508   ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
08509         ffesymbol_ptr_to_listbottom (s));
08510       na = sa | FFESYMBOL_attrsCBLOCK;
08511     }
08512   else
08513     na = FFESYMBOL_attrsetNONE;
08514 
08515   /* Now see what we've got for a new object: NONE means a new error cropped
08516      up; ANY means an old error to be ignored; otherwise, everything's ok,
08517      update the object (symbol) and continue on. */
08518 
08519   if (na == FFESYMBOL_attrsetNONE)
08520     {
08521       ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
08522       ffestc_parent_ok_ = FALSE;
08523     }
08524   else if (na & FFESYMBOL_attrsANY)
08525     ffestc_parent_ok_ = FALSE;
08526   else
08527     {
08528       ffesymbol_set_attrs (s, na);
08529       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
08530       if (name == NULL)
08531   ffesymbol_update_save (s);
08532       ffestc_parent_ok_ = TRUE;
08533     }
08534 
08535   ffestc_local_.common.symbol = s;
08536 
08537   ffestd_R547_item_cblock (name);
08538 }
08539 
08540 /* ffestc_R547_finish -- COMMON statement list complete
08541 
08542    ffestc_R547_finish();
08543 
08544    Just wrap up any local activities.  */
08545 
08546 void
08547 ffestc_R547_finish ()
08548 {
08549   ffestc_check_finish_ ();
08550   if (!ffestc_ok_)
08551     return;
08552 
08553   if (ffestc_local_.common.symbol != NULL)
08554     ffesymbol_signal_unreported (ffestc_local_.common.symbol);
08555 
08556   ffestd_R547_finish ();
08557 }
08558 
08559 /* ffestc_R620 -- ALLOCATE statement
08560 
08561    ffestc_R620(exprlist,stat,stat_token);
08562 
08563    Make sure the expression list is valid, then implement it.  */
08564 
08565 #if FFESTR_F90
08566 void
08567 ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
08568 {
08569   ffestc_check_simple_ ();
08570   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
08571     return;
08572   ffestc_labeldef_branch_begin_ ();
08573 
08574   ffestd_R620 (exprlist, stat);
08575 
08576   if (ffestc_shriek_after1_ != NULL)
08577     (*ffestc_shriek_after1_) (TRUE);
08578   ffestc_labeldef_branch_end_ ();
08579 }
08580 
08581 /* ffestc_R624 -- NULLIFY statement
08582 
08583    ffestc_R624(pointer_name_list);
08584 
08585    Make sure pointer_name_list identifies valid pointers for a NULLIFY.  */
08586 
08587 void
08588 ffestc_R624 (ffesttExprList pointers)
08589 {
08590   ffestc_check_simple_ ();
08591   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
08592     return;
08593   ffestc_labeldef_branch_begin_ ();
08594 
08595   ffestd_R624 (pointers);
08596 
08597   if (ffestc_shriek_after1_ != NULL)
08598     (*ffestc_shriek_after1_) (TRUE);
08599   ffestc_labeldef_branch_end_ ();
08600 }
08601 
08602 /* ffestc_R625 -- DEALLOCATE statement
08603 
08604    ffestc_R625(exprlist,stat,stat_token);
08605 
08606    Make sure the equivalence is valid, then implement it.  */
08607 
08608 void
08609 ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
08610 {
08611   ffestc_check_simple_ ();
08612   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
08613     return;
08614   ffestc_labeldef_branch_begin_ ();
08615 
08616   ffestd_R625 (exprlist, stat);
08617 
08618   if (ffestc_shriek_after1_ != NULL)
08619     (*ffestc_shriek_after1_) (TRUE);
08620   ffestc_labeldef_branch_end_ ();
08621 }
08622 
08623 #endif
08624 /* ffestc_let -- R1213 or R737
08625 
08626    ffestc_let(...);
08627 
08628    Verify that R1213 defined-assignment or R737 assignment-stmt are
08629    valid here, figure out which one, and implement.  */
08630 
08631 #if FFESTR_F90
08632 void
08633 ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
08634 {
08635   ffestc_R737 (dest, source, source_token);
08636 }
08637 
08638 #endif
08639 /* ffestc_R737 -- Assignment statement
08640 
08641    ffestc_R737(dest_expr,source_expr,source_token);
08642 
08643    Make sure the assignment is valid.  */
08644 
08645 void
08646 ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
08647 {
08648   ffestc_check_simple_ ();
08649 
08650   switch (ffestw_state (ffestw_stack_top ()))
08651     {
08652 #if FFESTR_F90
08653     case FFESTV_stateWHERE:
08654     case FFESTV_stateWHERETHEN:
08655       if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
08656   return;
08657       ffestc_labeldef_useless_ ();
08658 
08659       ffestd_R737B (dest, source);
08660 
08661       if (ffestc_shriek_after1_ != NULL)
08662   (*ffestc_shriek_after1_) (TRUE);
08663       return;
08664 #endif
08665 
08666     default:
08667       break;
08668     }
08669 
08670   if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
08671     return;
08672   ffestc_labeldef_branch_begin_ ();
08673 
08674   source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
08675          FFEEXPR_contextLET);
08676 
08677   ffestd_R737A (dest, source);
08678 
08679   if (ffestc_shriek_after1_ != NULL)
08680     (*ffestc_shriek_after1_) (TRUE);
08681   ffestc_labeldef_branch_end_ ();
08682 }
08683 
08684 /* ffestc_R738 -- Pointer assignment statement
08685 
08686    ffestc_R738(dest_expr,source_expr,source_token);
08687 
08688    Make sure the assignment is valid.  */
08689 
08690 #if FFESTR_F90
08691 void
08692 ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
08693 {
08694   ffestc_check_simple_ ();
08695   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
08696     return;
08697   ffestc_labeldef_branch_begin_ ();
08698 
08699   ffestd_R738 (dest, source);
08700 
08701   if (ffestc_shriek_after1_ != NULL)
08702     (*ffestc_shriek_after1_) (TRUE);
08703   ffestc_labeldef_branch_end_ ();
08704 }
08705 
08706 /* ffestc_R740 -- WHERE statement
08707 
08708    ffestc_R740(expr,expr_token);
08709 
08710    Make sure statement is valid here; implement.  */
08711 
08712 void
08713 ffestc_R740 (ffebld expr, ffelexToken expr_token)
08714 {
08715   ffestw b;
08716 
08717   ffestc_check_simple_ ();
08718   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
08719     return;
08720   ffestc_labeldef_branch_begin_ ();
08721 
08722   b = ffestw_update (ffestw_push (NULL));
08723   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
08724   ffestw_set_state (b, FFESTV_stateWHERE);
08725   ffestw_set_blocknum (b, ffestc_blocknum_++);
08726   ffestw_set_shriek (b, ffestc_shriek_where_lost_);
08727 
08728   ffestd_R740 (expr);
08729 
08730   /* Leave label finishing to next statement. */
08731 
08732 }
08733 
08734 /* ffestc_R742 -- WHERE-construct statement
08735 
08736    ffestc_R742(expr,expr_token);
08737 
08738    Make sure statement is valid here; implement.  */
08739 
08740 void
08741 ffestc_R742 (ffebld expr, ffelexToken expr_token)
08742 {
08743   ffestw b;
08744 
08745   ffestc_check_simple_ ();
08746   if (ffestc_order_exec_ () != FFESTC_orderOK_)
08747     return;
08748   ffestc_labeldef_notloop_probably_this_wont_work_ ();
08749 
08750   b = ffestw_update (ffestw_push (NULL));
08751   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
08752   ffestw_set_state (b, FFESTV_stateWHERETHEN);
08753   ffestw_set_blocknum (b, ffestc_blocknum_++);
08754   ffestw_set_shriek (b, ffestc_shriek_wherethen_);
08755   ffestw_set_substate (b, 0); /* Haven't seen ELSEWHERE yet. */
08756 
08757   ffestd_R742 (expr);
08758 }
08759 
08760 /* ffestc_R744 -- ELSE WHERE statement
08761 
08762    ffestc_R744();
08763 
08764    Make sure ffestc_kind_ identifies a WHERE block.
08765    Implement the ELSE of the current WHERE block.  */
08766 
08767 void
08768 ffestc_R744 ()
08769 {
08770   ffestc_check_simple_ ();
08771   if (ffestc_order_where_ () != FFESTC_orderOK_)
08772     return;
08773   ffestc_labeldef_useless_ ();
08774 
08775   if (ffestw_substate (ffestw_stack_top ()) != 0)
08776     {
08777       ffebad_start (FFEBAD_SECOND_ELSE_WHERE);
08778       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
08779        ffelex_token_where_column (ffesta_tokens[0]));
08780       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
08781       ffebad_finish ();
08782     }
08783 
08784   ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */
08785 
08786   ffestd_R744 ();
08787 }
08788 
08789 /* ffestc_R745 -- END WHERE statement
08790 
08791    ffestc_R745();
08792 
08793    Make sure ffestc_kind_ identifies a WHERE block.
08794    Implement the end of the current WHERE block.  */
08795 
08796 void
08797 ffestc_R745 ()
08798 {
08799   ffestc_check_simple_ ();
08800   if (ffestc_order_where_ () != FFESTC_orderOK_)
08801     return;
08802   ffestc_labeldef_useless_ ();
08803 
08804   ffestc_shriek_wherethen_ (TRUE);
08805 }
08806 
08807 #endif
08808 /* ffestc_R803 -- Block IF (IF-THEN) statement
08809 
08810    ffestc_R803(construct_name,expr,expr_token);
08811 
08812    Make sure statement is valid here; implement.  */
08813 
08814 void
08815 ffestc_R803 (ffelexToken construct_name, ffebld expr,
08816        ffelexToken expr_token UNUSED)
08817 {
08818   ffestw b;
08819   ffesymbol s;
08820 
08821   ffestc_check_simple_ ();
08822   if (ffestc_order_exec_ () != FFESTC_orderOK_)
08823     return;
08824   ffestc_labeldef_notloop_ ();
08825 
08826   b = ffestw_update (ffestw_push (NULL));
08827   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
08828   ffestw_set_state (b, FFESTV_stateIFTHEN);
08829   ffestw_set_blocknum (b, ffestc_blocknum_++);
08830   ffestw_set_shriek (b, ffestc_shriek_ifthen_);
08831   ffestw_set_substate (b, 0); /* Haven't seen ELSE yet. */
08832 
08833   if (construct_name == NULL)
08834     ffestw_set_name (b, NULL);
08835   else
08836     {
08837       ffestw_set_name (b, ffelex_token_use (construct_name));
08838 
08839       s = ffesymbol_declare_local (construct_name, FALSE);
08840 
08841       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
08842   {
08843     ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
08844     ffesymbol_set_info (s,
08845             ffeinfo_new (FFEINFO_basictypeNONE,
08846              FFEINFO_kindtypeNONE,
08847              0,
08848              FFEINFO_kindCONSTRUCT,
08849              FFEINFO_whereLOCAL,
08850              FFETARGET_charactersizeNONE));
08851     s = ffecom_sym_learned (s);
08852     ffesymbol_signal_unreported (s);
08853   }
08854       else
08855   ffesymbol_error (s, construct_name);
08856     }
08857 
08858   ffestd_R803 (construct_name, expr);
08859 }
08860 
08861 /* ffestc_R804 -- ELSE IF statement
08862 
08863    ffestc_R804(expr,expr_token,name_token);
08864 
08865    Make sure ffestc_kind_ identifies an IF block.  If not
08866    NULL, make sure name_token gives the correct name.  Implement the else
08867    of the IF block.  */
08868 
08869 void
08870 ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
08871        ffelexToken name)
08872 {
08873   ffestc_check_simple_ ();
08874   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
08875     return;
08876   ffestc_labeldef_useless_ ();
08877 
08878   if (name != NULL)
08879     {
08880       if (ffestw_name (ffestw_stack_top ()) == NULL)
08881   {
08882     ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
08883     ffebad_here (0, ffelex_token_where_line (name),
08884            ffelex_token_where_column (name));
08885     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
08886     ffebad_finish ();
08887   }
08888       else if (ffelex_token_strcmp (name,
08889             ffestw_name (ffestw_stack_top ()))
08890          != 0)
08891   {
08892     ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
08893     ffebad_here (0, ffelex_token_where_line (name),
08894            ffelex_token_where_column (name));
08895     ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
08896        ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
08897     ffebad_finish ();
08898   }
08899     }
08900 
08901   if (ffestw_substate (ffestw_stack_top ()) != 0)
08902     {
08903       ffebad_start (FFEBAD_AFTER_ELSE);
08904       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
08905        ffelex_token_where_column (ffesta_tokens[0]));
08906       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
08907       ffebad_finish ();
08908       return;     /* Don't upset back end with ELSEIF
08909            after ELSE. */
08910     }
08911 
08912   ffestd_R804 (expr, name);
08913 }
08914 
08915 /* ffestc_R805 -- ELSE statement
08916 
08917    ffestc_R805(name_token);
08918 
08919    Make sure ffestc_kind_ identifies an IF block.  If not
08920    NULL, make sure name_token gives the correct name.  Implement the ELSE
08921    of the IF block.  */
08922 
08923 void
08924 ffestc_R805 (ffelexToken name)
08925 {
08926   ffestc_check_simple_ ();
08927   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
08928     return;
08929   ffestc_labeldef_useless_ ();
08930 
08931   if (name != NULL)
08932     {
08933       if (ffestw_name (ffestw_stack_top ()) == NULL)
08934   {
08935     ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
08936     ffebad_here (0, ffelex_token_where_line (name),
08937            ffelex_token_where_column (name));
08938     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
08939     ffebad_finish ();
08940   }
08941       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
08942   {
08943     ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
08944     ffebad_here (0, ffelex_token_where_line (name),
08945            ffelex_token_where_column (name));
08946     ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
08947        ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
08948     ffebad_finish ();
08949   }
08950     }
08951 
08952   if (ffestw_substate (ffestw_stack_top ()) != 0)
08953     {
08954       ffebad_start (FFEBAD_AFTER_ELSE);
08955       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
08956        ffelex_token_where_column (ffesta_tokens[0]));
08957       ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
08958       ffebad_finish ();
08959       return;     /* Tell back end about only one ELSE. */
08960     }
08961 
08962   ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
08963 
08964   ffestd_R805 (name);
08965 }
08966 
08967 /* ffestc_R806 -- END IF statement
08968 
08969    ffestc_R806(name_token);
08970 
08971    Make sure ffestc_kind_ identifies an IF block.  If not
08972    NULL, make sure name_token gives the correct name.  Implement the end
08973    of the IF block.  */
08974 
08975 void
08976 ffestc_R806 (ffelexToken name)
08977 {
08978   ffestc_check_simple_ ();
08979   if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
08980     return;
08981   ffestc_labeldef_endif_ ();
08982 
08983   if (name == NULL)
08984     {
08985       if (ffestw_name (ffestw_stack_top ()) != NULL)
08986   {
08987     ffebad_start (FFEBAD_CONSTRUCT_NAMED);
08988     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
08989            ffelex_token_where_column (ffesta_tokens[0]));
08990     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
08991     ffebad_finish ();
08992   }
08993     }
08994   else
08995     {
08996       if (ffestw_name (ffestw_stack_top ()) == NULL)
08997   {
08998     ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
08999     ffebad_here (0, ffelex_token_where_line (name),
09000            ffelex_token_where_column (name));
09001     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09002     ffebad_finish ();
09003   }
09004       else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
09005   {
09006     ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
09007     ffebad_here (0, ffelex_token_where_line (name),
09008            ffelex_token_where_column (name));
09009     ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
09010        ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
09011     ffebad_finish ();
09012   }
09013     }
09014 
09015   ffestc_shriek_ifthen_ (TRUE);
09016 }
09017 
09018 /* ffestc_R807 -- Logical IF statement
09019 
09020    ffestc_R807(expr,expr_token);
09021 
09022    Make sure statement is valid here; implement.  */
09023 
09024 void
09025 ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
09026 {
09027   ffestw b;
09028 
09029   ffestc_check_simple_ ();
09030   if (ffestc_order_action_ () != FFESTC_orderOK_)
09031     return;
09032   ffestc_labeldef_branch_begin_ ();
09033 
09034   b = ffestw_update (ffestw_push (NULL));
09035   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
09036   ffestw_set_state (b, FFESTV_stateIF);
09037   ffestw_set_blocknum (b, ffestc_blocknum_++);
09038   ffestw_set_shriek (b, ffestc_shriek_if_lost_);
09039 
09040   ffestd_R807 (expr);
09041 
09042   /* Do the label finishing in the next statement. */
09043 
09044 }
09045 
09046 /* ffestc_R809 -- SELECT CASE statement
09047 
09048    ffestc_R809(construct_name,expr,expr_token);
09049 
09050    Make sure statement is valid here; implement.  */
09051 
09052 void
09053 ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
09054 {
09055   ffestw b;
09056   mallocPool pool;
09057   ffestwSelect s;
09058   ffesymbol sym;
09059 
09060   ffestc_check_simple_ ();
09061   if (ffestc_order_exec_ () != FFESTC_orderOK_)
09062     return;
09063   ffestc_labeldef_notloop_ ();
09064 
09065   b = ffestw_update (ffestw_push (NULL));
09066   ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
09067   ffestw_set_state (b, FFESTV_stateSELECT0);
09068   ffestw_set_blocknum (b, ffestc_blocknum_++);
09069   ffestw_set_shriek (b, ffestc_shriek_select_);
09070   ffestw_set_substate (b, 0); /* Haven't seen CASE DEFAULT yet. */
09071 
09072   /* Init block to manage CASE list. */
09073 
09074   pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
09075   s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
09076   s->first_rel = (ffestwCase) &s->first_rel;
09077   s->last_rel = (ffestwCase) &s->first_rel;
09078   s->first_stmt = (ffestwCase) &s->first_rel;
09079   s->last_stmt = (ffestwCase) &s->first_rel;
09080   s->pool = pool;
09081   s->cases = 1;
09082   s->t = ffelex_token_use (expr_token);
09083   s->type = ffeinfo_basictype (ffebld_info (expr));
09084   s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
09085   ffestw_set_select (b, s);
09086 
09087   if (construct_name == NULL)
09088     ffestw_set_name (b, NULL);
09089   else
09090     {
09091       ffestw_set_name (b, ffelex_token_use (construct_name));
09092 
09093       sym = ffesymbol_declare_local (construct_name, FALSE);
09094 
09095       if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
09096   {
09097     ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
09098     ffesymbol_set_info (sym,
09099             ffeinfo_new (FFEINFO_basictypeNONE,
09100              FFEINFO_kindtypeNONE, 0,
09101              FFEINFO_kindCONSTRUCT,
09102              FFEINFO_whereLOCAL,
09103              FFETARGET_charactersizeNONE));
09104     sym = ffecom_sym_learned (sym);
09105     ffesymbol_signal_unreported (sym);
09106   }
09107       else
09108   ffesymbol_error (sym, construct_name);
09109     }
09110 
09111   ffestd_R809 (construct_name, expr);
09112 }
09113 
09114 /* ffestc_R810 -- CASE statement
09115 
09116    ffestc_R810(case_value_range_list,name);
09117 
09118    If case_value_range_list is NULL, it's CASE DEFAULT.  name is the case-
09119    construct-name.  Make sure no more than one CASE DEFAULT is present for
09120    a given case-construct and that there aren't any overlapping ranges or
09121    duplicate case values.  */
09122 
09123 void
09124 ffestc_R810 (ffesttCaseList cases, ffelexToken name)
09125 {
09126   ffesttCaseList caseobj;
09127   ffestwSelect s;
09128   ffestwCase c, nc;
09129   ffebldConstant expr1c, expr2c;
09130 
09131   ffestc_check_simple_ ();
09132   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
09133     return;
09134   ffestc_labeldef_useless_ ();
09135 
09136   s = ffestw_select (ffestw_stack_top ());
09137 
09138   if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
09139     {
09140 #if 0       /* Not sure we want to have msgs point here
09141            instead of SELECT CASE. */
09142       ffestw_update (NULL); /* Update state line/col info. */
09143 #endif
09144       ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
09145     }
09146 
09147   if (name != NULL)
09148     {
09149       if (ffestw_name (ffestw_stack_top ()) == NULL)
09150   {
09151     ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
09152     ffebad_here (0, ffelex_token_where_line (name),
09153            ffelex_token_where_column (name));
09154     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09155     ffebad_finish ();
09156   }
09157       else if (ffelex_token_strcmp (name,
09158             ffestw_name (ffestw_stack_top ()))
09159          != 0)
09160   {
09161     ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
09162     ffebad_here (0, ffelex_token_where_line (name),
09163            ffelex_token_where_column (name));
09164     ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
09165        ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
09166     ffebad_finish ();
09167   }
09168     }
09169 
09170   if (cases == NULL)
09171     {
09172       if (ffestw_substate (ffestw_stack_top ()) != 0)
09173   {
09174     ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
09175     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
09176            ffelex_token_where_column (ffesta_tokens[0]));
09177     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09178     ffebad_finish ();
09179   }
09180 
09181       ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
09182     }
09183   else
09184     {       /* For each case, try to fit into sorted list
09185            of ranges. */
09186       for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
09187   {
09188     if ((caseobj->expr1 == NULL)
09189         && (!caseobj->range
09190       || (caseobj->expr2 == NULL)))
09191       {     /* "CASE (:)". */
09192         ffebad_start (FFEBAD_CASE_BAD_RANGE);
09193         ffebad_here (0, ffelex_token_where_line (caseobj->t),
09194          ffelex_token_where_column (caseobj->t));
09195         ffebad_finish ();
09196         continue;
09197       }
09198 
09199     if (((caseobj->expr1 != NULL)
09200          && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
09201         != s->type)
09202        || (ffeinfo_kindtype (ffebld_info (caseobj->expr1))
09203            != s->kindtype)))
09204         || ((caseobj->range)
09205       && (caseobj->expr2 != NULL)
09206       && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
09207            != s->type)
09208           || (ffeinfo_kindtype (ffebld_info (caseobj->expr2))
09209         != s->kindtype))))
09210       {
09211         ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
09212         ffebad_here (0, ffelex_token_where_line (caseobj->t),
09213          ffelex_token_where_column (caseobj->t));
09214         ffebad_here (1, ffelex_token_where_line (s->t),
09215          ffelex_token_where_column (s->t));
09216         ffebad_finish ();
09217         continue;
09218       }
09219 
09220     if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
09221       {
09222         ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
09223         ffebad_here (0, ffelex_token_where_line (caseobj->t),
09224          ffelex_token_where_column (caseobj->t));
09225         ffebad_finish ();
09226         continue;
09227       }
09228 
09229     if (caseobj->expr1 == NULL)
09230       expr1c = NULL;
09231     else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
09232       continue;   /* opANY. */
09233     else
09234       expr1c = ffebld_conter (caseobj->expr1);
09235 
09236     if (!caseobj->range)
09237       expr2c = expr1c;  /* expr1c and expr2c are NOT NULL in this
09238            case. */
09239     else if (caseobj->expr2 == NULL)
09240       expr2c = NULL;
09241     else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
09242       continue;   /* opANY. */
09243     else
09244       expr2c = ffebld_conter (caseobj->expr2);
09245 
09246     if (expr1c == NULL)
09247       {     /* "CASE (:high)", must be first in list. */
09248         c = s->first_rel;
09249         if ((c != (ffestwCase) &s->first_rel)
09250       && ((c->low == NULL)
09251           || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
09252     {   /* Other "CASE (:high)" or lowest "CASE
09253            (low[:high])" low. */
09254       ffebad_start (FFEBAD_CASE_DUPLICATE);
09255       ffebad_here (0, ffelex_token_where_line (caseobj->t),
09256              ffelex_token_where_column (caseobj->t));
09257       ffebad_here (1, ffelex_token_where_line (c->t),
09258              ffelex_token_where_column (c->t));
09259       ffebad_finish ();
09260       continue;
09261     }
09262       }
09263     else if (expr2c == NULL)
09264       {     /* "CASE (low:)", must be last in list. */
09265         c = s->last_rel;
09266         if ((c != (ffestwCase) &s->first_rel)
09267       && ((c->high == NULL)
09268           || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
09269     {   /* Other "CASE (low:)" or lowest "CASE
09270            ([low:]high)" high. */
09271       ffebad_start (FFEBAD_CASE_DUPLICATE);
09272       ffebad_here (0, ffelex_token_where_line (caseobj->t),
09273              ffelex_token_where_column (caseobj->t));
09274       ffebad_here (1, ffelex_token_where_line (c->t),
09275              ffelex_token_where_column (c->t));
09276       ffebad_finish ();
09277       continue;
09278     }
09279         c = c->next_rel;  /* Same as c = (ffestwCase) &s->first;. */
09280       }
09281     else
09282       {     /* (expr1c != NULL) && (expr2c != NULL). */
09283         if (ffebld_constant_cmp (expr1c, expr2c) > 0)
09284     {   /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
09285       ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */
09286       ffebad_here (0, ffelex_token_where_line (caseobj->t),
09287              ffelex_token_where_column (caseobj->t));
09288       ffebad_finish ();
09289       continue;
09290     }
09291         for (c = s->first_rel;
09292        (c != (ffestwCase) &s->first_rel)
09293        && ((c->low == NULL)
09294            || (ffebld_constant_cmp (expr1c, c->low) > 0));
09295        c = c->next_rel)
09296     ;
09297         nc = c;   /* Which one to report? */
09298         if (((c != (ffestwCase) &s->first_rel)
09299        && (ffebld_constant_cmp (expr2c, c->low) >= 0))
09300       || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
09301           && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
09302     {   /* Interference with range in case nc. */
09303       ffebad_start (FFEBAD_CASE_DUPLICATE);
09304       ffebad_here (0, ffelex_token_where_line (caseobj->t),
09305              ffelex_token_where_column (caseobj->t));
09306       ffebad_here (1, ffelex_token_where_line (nc->t),
09307              ffelex_token_where_column (nc->t));
09308       ffebad_finish ();
09309       continue;
09310     }
09311       }
09312 
09313     /* If we reach here for this case range/value, it's ok (sorts into
09314        the list of ranges/values) so we give it its own case object
09315        sorted into the list of case statements. */
09316 
09317     nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
09318     nc->next_rel = c;
09319     nc->previous_rel = c->previous_rel;
09320     nc->next_stmt = (ffestwCase) &s->first_rel;
09321     nc->previous_stmt = s->last_stmt;
09322     nc->low = expr1c;
09323     nc->high = expr2c;
09324     nc->casenum = s->cases;
09325     nc->t = ffelex_token_use (caseobj->t);
09326     nc->next_rel->previous_rel = nc;
09327     nc->previous_rel->next_rel = nc;
09328     nc->next_stmt->previous_stmt = nc;
09329     nc->previous_stmt->next_stmt = nc;
09330   }
09331     }
09332 
09333   ffestd_R810 ((cases == NULL) ? 0 : s->cases);
09334 
09335   s->cases++;     /* Increment # of cases. */
09336 }
09337 
09338 /* ffestc_R811 -- END SELECT statement
09339 
09340    ffestc_R811(name_token);
09341 
09342    Make sure ffestc_kind_ identifies a SELECT block.  If not
09343    NULL, make sure name_token gives the correct name.  Implement the end
09344    of the SELECT block.  */
09345 
09346 void
09347 ffestc_R811 (ffelexToken name)
09348 {
09349   ffestc_check_simple_ ();
09350   if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
09351     return;
09352   ffestc_labeldef_notloop_ ();
09353 
09354   if (name == NULL)
09355     {
09356       if (ffestw_name (ffestw_stack_top ()) != NULL)
09357   {
09358     ffebad_start (FFEBAD_CONSTRUCT_NAMED);
09359     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
09360            ffelex_token_where_column (ffesta_tokens[0]));
09361     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09362     ffebad_finish ();
09363   }
09364     }
09365   else
09366     {
09367       if (ffestw_name (ffestw_stack_top ()) == NULL)
09368   {
09369     ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
09370     ffebad_here (0, ffelex_token_where_line (name),
09371            ffelex_token_where_column (name));
09372     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09373     ffebad_finish ();
09374   }
09375       else if (ffelex_token_strcmp (name,
09376             ffestw_name (ffestw_stack_top ()))
09377          != 0)
09378   {
09379     ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
09380     ffebad_here (0, ffelex_token_where_line (name),
09381            ffelex_token_where_column (name));
09382     ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
09383        ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
09384     ffebad_finish ();
09385   }
09386     }
09387 
09388   ffestc_shriek_select_ (TRUE);
09389 }
09390 
09391 /* ffestc_R819A -- Iterative labeled DO statement
09392 
09393    ffestc_R819A(construct_name,label_token,expr,expr_token);
09394 
09395    Make sure statement is valid here; implement.  */
09396 
09397 void
09398 ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
09399    ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
09400         ffelexToken end_token, ffebld incr, ffelexToken incr_token)
09401 {
09402   ffestw b;
09403   ffelab label;
09404   ffesymbol s;
09405   ffesymbol varsym;
09406 
09407   ffestc_check_simple_ ();
09408   if (ffestc_order_exec_ () != FFESTC_orderOK_)
09409     return;
09410   ffestc_labeldef_notloop_ ();
09411 
09412   if (!ffestc_labelref_is_loopend_ (label_token, &label))
09413     return;
09414 
09415   b = ffestw_update (ffestw_push (NULL));
09416   ffestw_set_top_do (b, b);
09417   ffestw_set_state (b, FFESTV_stateDO);
09418   ffestw_set_blocknum (b, ffestc_blocknum_++);
09419   ffestw_set_shriek (b, ffestc_shriek_do_);
09420   ffestw_set_label (b, label);
09421   switch (ffebld_op (var))
09422     {
09423     case FFEBLD_opSYMTER:
09424       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
09425     && ffe_is_warn_surprising ())
09426   {
09427     ffebad_start (FFEBAD_DO_REAL);  /* See error message!!! */
09428     ffebad_here (0, ffelex_token_where_line (var_token),
09429            ffelex_token_where_column (var_token));
09430     ffebad_string (ffesymbol_text (ffebld_symter (var)));
09431     ffebad_finish ();
09432   }
09433       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
09434   {     /* Presumably already complained about by
09435            ffeexpr_lhs_. */
09436     ffesymbol_set_is_doiter (varsym, TRUE);
09437     ffestw_set_do_iter_var (b, varsym);
09438     ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
09439     break;
09440   }
09441       /* Fall through. */
09442     case FFEBLD_opANY:
09443       ffestw_set_do_iter_var (b, NULL);
09444       ffestw_set_do_iter_var_t (b, NULL);
09445       break;
09446 
09447     default:
09448       assert ("bad iter var" == NULL);
09449       break;
09450     }
09451 
09452   if (construct_name == NULL)
09453     ffestw_set_name (b, NULL);
09454   else
09455     {
09456       ffestw_set_name (b, ffelex_token_use (construct_name));
09457 
09458       s = ffesymbol_declare_local (construct_name, FALSE);
09459 
09460       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
09461   {
09462     ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
09463     ffesymbol_set_info (s,
09464             ffeinfo_new (FFEINFO_basictypeNONE,
09465              FFEINFO_kindtypeNONE,
09466              0,
09467              FFEINFO_kindCONSTRUCT,
09468              FFEINFO_whereLOCAL,
09469              FFETARGET_charactersizeNONE));
09470     s = ffecom_sym_learned (s);
09471     ffesymbol_signal_unreported (s);
09472   }
09473       else
09474   ffesymbol_error (s, construct_name);
09475     }
09476 
09477   if (incr == NULL)
09478     {
09479       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
09480       ffebld_set_info (incr, ffeinfo_new
09481            (FFEINFO_basictypeINTEGER,
09482       FFEINFO_kindtypeINTEGERDEFAULT,
09483       0,
09484       FFEINFO_kindENTITY,
09485       FFEINFO_whereCONSTANT,
09486       FFETARGET_charactersizeNONE));
09487     }
09488 
09489   start = ffeexpr_convert_expr (start, start_token, var, var_token,
09490         FFEEXPR_contextLET);
09491   end = ffeexpr_convert_expr (end, end_token, var, var_token,
09492             FFEEXPR_contextLET);
09493   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
09494              FFEEXPR_contextLET);
09495 
09496   ffestd_R819A (construct_name, label, var,
09497     start, start_token,
09498     end, end_token,
09499     incr, incr_token);
09500 }
09501 
09502 /* ffestc_R819B -- Labeled DO WHILE statement
09503 
09504    ffestc_R819B(construct_name,label_token,expr,expr_token);
09505 
09506    Make sure statement is valid here; implement.  */
09507 
09508 void
09509 ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
09510         ffebld expr, ffelexToken expr_token UNUSED)
09511 {
09512   ffestw b;
09513   ffelab label;
09514   ffesymbol s;
09515 
09516   ffestc_check_simple_ ();
09517   if (ffestc_order_exec_ () != FFESTC_orderOK_)
09518     return;
09519   ffestc_labeldef_notloop_ ();
09520 
09521   if (!ffestc_labelref_is_loopend_ (label_token, &label))
09522     return;
09523 
09524   b = ffestw_update (ffestw_push (NULL));
09525   ffestw_set_top_do (b, b);
09526   ffestw_set_state (b, FFESTV_stateDO);
09527   ffestw_set_blocknum (b, ffestc_blocknum_++);
09528   ffestw_set_shriek (b, ffestc_shriek_do_);
09529   ffestw_set_label (b, label);
09530   ffestw_set_do_iter_var (b, NULL);
09531   ffestw_set_do_iter_var_t (b, NULL);
09532 
09533   if (construct_name == NULL)
09534     ffestw_set_name (b, NULL);
09535   else
09536     {
09537       ffestw_set_name (b, ffelex_token_use (construct_name));
09538 
09539       s = ffesymbol_declare_local (construct_name, FALSE);
09540 
09541       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
09542   {
09543     ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
09544     ffesymbol_set_info (s,
09545             ffeinfo_new (FFEINFO_basictypeNONE,
09546              FFEINFO_kindtypeNONE,
09547              0,
09548              FFEINFO_kindCONSTRUCT,
09549              FFEINFO_whereLOCAL,
09550              FFETARGET_charactersizeNONE));
09551     s = ffecom_sym_learned (s);
09552     ffesymbol_signal_unreported (s);
09553   }
09554       else
09555   ffesymbol_error (s, construct_name);
09556     }
09557 
09558   ffestd_R819B (construct_name, label, expr);
09559 }
09560 
09561 /* ffestc_R820A -- Iterative nonlabeled DO statement
09562 
09563    ffestc_R820A(construct_name,expr,expr_token);
09564 
09565    Make sure statement is valid here; implement.  */
09566 
09567 void
09568 ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
09569    ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
09570         ffebld incr, ffelexToken incr_token)
09571 {
09572   ffestw b;
09573   ffesymbol s;
09574   ffesymbol varsym;
09575 
09576   ffestc_check_simple_ ();
09577   if (ffestc_order_exec_ () != FFESTC_orderOK_)
09578     return;
09579   ffestc_labeldef_notloop_ ();
09580 
09581   b = ffestw_update (ffestw_push (NULL));
09582   ffestw_set_top_do (b, b);
09583   ffestw_set_state (b, FFESTV_stateDO);
09584   ffestw_set_blocknum (b, ffestc_blocknum_++);
09585   ffestw_set_shriek (b, ffestc_shriek_do_);
09586   ffestw_set_label (b, NULL);
09587   switch (ffebld_op (var))
09588     {
09589     case FFEBLD_opSYMTER:
09590       if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
09591     && ffe_is_warn_surprising ())
09592   {
09593     ffebad_start (FFEBAD_DO_REAL);  /* See error message!!! */
09594     ffebad_here (0, ffelex_token_where_line (var_token),
09595            ffelex_token_where_column (var_token));
09596     ffebad_string (ffesymbol_text (ffebld_symter (var)));
09597     ffebad_finish ();
09598   }
09599       if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
09600   {     /* Presumably already complained about by
09601            ffeexpr_lhs_. */
09602     ffesymbol_set_is_doiter (varsym, TRUE);
09603     ffestw_set_do_iter_var (b, varsym);
09604     ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
09605     break;
09606   }
09607       /* Fall through. */
09608     case FFEBLD_opANY:
09609       ffestw_set_do_iter_var (b, NULL);
09610       ffestw_set_do_iter_var_t (b, NULL);
09611       break;
09612 
09613     default:
09614       assert ("bad iter var" == NULL);
09615       break;
09616     }
09617 
09618   if (construct_name == NULL)
09619     ffestw_set_name (b, NULL);
09620   else
09621     {
09622       ffestw_set_name (b, ffelex_token_use (construct_name));
09623 
09624       s = ffesymbol_declare_local (construct_name, FALSE);
09625 
09626       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
09627   {
09628     ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
09629     ffesymbol_set_info (s,
09630             ffeinfo_new (FFEINFO_basictypeNONE,
09631              FFEINFO_kindtypeNONE,
09632              0,
09633              FFEINFO_kindCONSTRUCT,
09634              FFEINFO_whereLOCAL,
09635              FFETARGET_charactersizeNONE));
09636     s = ffecom_sym_learned (s);
09637     ffesymbol_signal_unreported (s);
09638   }
09639       else
09640   ffesymbol_error (s, construct_name);
09641     }
09642 
09643   if (incr == NULL)
09644     {
09645       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
09646       ffebld_set_info (incr, ffeinfo_new
09647            (FFEINFO_basictypeINTEGER,
09648       FFEINFO_kindtypeINTEGERDEFAULT,
09649       0,
09650       FFEINFO_kindENTITY,
09651       FFEINFO_whereCONSTANT,
09652       FFETARGET_charactersizeNONE));
09653     }
09654 
09655   start = ffeexpr_convert_expr (start, start_token, var, var_token,
09656         FFEEXPR_contextLET);
09657   end = ffeexpr_convert_expr (end, end_token, var, var_token,
09658             FFEEXPR_contextLET);
09659   incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
09660              FFEEXPR_contextLET);
09661 
09662 #if 0
09663   if ((ffebld_op (incr) == FFEBLD_opCONTER)
09664       && (ffebld_constant_is_zero (ffebld_conter (incr))))
09665     {
09666       ffebad_start (FFEBAD_DO_STEP_ZERO);
09667       ffebad_here (0, ffelex_token_where_line (incr_token),
09668        ffelex_token_where_column (incr_token));
09669       ffebad_string ("Iterative DO loop");
09670       ffebad_finish ();
09671     }
09672 #endif
09673 
09674   ffestd_R819A (construct_name, NULL, var,
09675     start, start_token,
09676     end, end_token,
09677     incr, incr_token);
09678 }
09679 
09680 /* ffestc_R820B -- Nonlabeled DO WHILE statement
09681 
09682    ffestc_R820B(construct_name,expr,expr_token);
09683 
09684    Make sure statement is valid here; implement.  */
09685 
09686 void
09687 ffestc_R820B (ffelexToken construct_name, ffebld expr,
09688         ffelexToken expr_token UNUSED)
09689 {
09690   ffestw b;
09691   ffesymbol s;
09692 
09693   ffestc_check_simple_ ();
09694   if (ffestc_order_exec_ () != FFESTC_orderOK_)
09695     return;
09696   ffestc_labeldef_notloop_ ();
09697 
09698   b = ffestw_update (ffestw_push (NULL));
09699   ffestw_set_top_do (b, b);
09700   ffestw_set_state (b, FFESTV_stateDO);
09701   ffestw_set_blocknum (b, ffestc_blocknum_++);
09702   ffestw_set_shriek (b, ffestc_shriek_do_);
09703   ffestw_set_label (b, NULL);
09704   ffestw_set_do_iter_var (b, NULL);
09705   ffestw_set_do_iter_var_t (b, NULL);
09706 
09707   if (construct_name == NULL)
09708     ffestw_set_name (b, NULL);
09709   else
09710     {
09711       ffestw_set_name (b, ffelex_token_use (construct_name));
09712 
09713       s = ffesymbol_declare_local (construct_name, FALSE);
09714 
09715       if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
09716   {
09717     ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
09718     ffesymbol_set_info (s,
09719             ffeinfo_new (FFEINFO_basictypeNONE,
09720              FFEINFO_kindtypeNONE,
09721              0,
09722              FFEINFO_kindCONSTRUCT,
09723              FFEINFO_whereLOCAL,
09724              FFETARGET_charactersizeNONE));
09725     s = ffecom_sym_learned (s);
09726     ffesymbol_signal_unreported (s);
09727   }
09728       else
09729   ffesymbol_error (s, construct_name);
09730     }
09731 
09732   ffestd_R819B (construct_name, NULL, expr);
09733 }
09734 
09735 /* ffestc_R825 -- END DO statement
09736 
09737    ffestc_R825(name_token);
09738 
09739    Make sure ffestc_kind_ identifies a DO block.  If not
09740    NULL, make sure name_token gives the correct name.  Implement the end
09741    of the DO block.  */
09742 
09743 void
09744 ffestc_R825 (ffelexToken name)
09745 {
09746   ffestc_check_simple_ ();
09747   if (ffestc_order_do_ () != FFESTC_orderOK_)
09748     return;
09749   ffestc_labeldef_branch_begin_ ();
09750 
09751   if (name == NULL)
09752     {
09753       if (ffestw_name (ffestw_stack_top ()) != NULL)
09754   {
09755     ffebad_start (FFEBAD_CONSTRUCT_NAMED);
09756     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
09757            ffelex_token_where_column (ffesta_tokens[0]));
09758     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09759     ffebad_finish ();
09760   }
09761     }
09762   else
09763     {
09764       if (ffestw_name (ffestw_stack_top ()) == NULL)
09765   {
09766     ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
09767     ffebad_here (0, ffelex_token_where_line (name),
09768            ffelex_token_where_column (name));
09769     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09770     ffebad_finish ();
09771   }
09772       else if (ffelex_token_strcmp (name,
09773             ffestw_name (ffestw_stack_top ()))
09774          != 0)
09775   {
09776     ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
09777     ffebad_here (0, ffelex_token_where_line (name),
09778            ffelex_token_where_column (name));
09779     ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
09780        ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
09781     ffebad_finish ();
09782   }
09783     }
09784 
09785   if (ffesta_label_token == NULL)
09786     {       /* If top of stack has label, its an error! */
09787       if (ffestw_label (ffestw_stack_top ()) != NULL)
09788   {
09789     ffebad_start (FFEBAD_DO_HAD_LABEL);
09790     ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
09791            ffelex_token_where_column (ffesta_tokens[0]));
09792     ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
09793     ffebad_finish ();
09794   }
09795 
09796       ffestc_shriek_do_ (TRUE);
09797 
09798       ffestc_try_shriek_do_ ();
09799 
09800       return;
09801     }
09802 
09803   ffestd_R825 (name);
09804 
09805   ffestc_labeldef_branch_end_ ();
09806 }
09807 
09808 /* ffestc_R834 -- CYCLE statement
09809 
09810    ffestc_R834(name_token);
09811 
09812    Handle a CYCLE within a loop.  */
09813 
09814 void
09815 ffestc_R834 (ffelexToken name)
09816 {
09817   ffestw block;
09818 
09819   ffestc_check_simple_ ();
09820   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
09821     return;
09822   ffestc_labeldef_notloop_begin_ ();
09823 
09824   if (name == NULL)
09825     block = ffestw_top_do (ffestw_stack_top ());
09826   else
09827     {       /* Search for name. */
09828       for (block = ffestw_top_do (ffestw_stack_top ());
09829      (block != NULL) && (ffestw_blocknum (block) != 0);
09830      block = ffestw_top_do (ffestw_previous (block)))
09831   {
09832     if ((ffestw_name (block) != NULL)
09833         && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
09834       break;
09835   }
09836       if ((block == NULL) || (ffestw_blocknum (block) == 0))
09837   {
09838     block = ffestw_top_do (ffestw_stack_top ());
09839     ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
09840     ffebad_here (0, ffelex_token_where_line (name),
09841            ffelex_token_where_column (name));
09842     ffebad_finish ();
09843   }
09844     }
09845 
09846   ffestd_R834 (block);
09847 
09848   if (ffestc_shriek_after1_ != NULL)
09849     (*ffestc_shriek_after1_) (TRUE);
09850 
09851   /* notloop's that are actionif's can be the target of a loop-end
09852      statement if they're in the "then" part of a logical IF, as
09853      in "DO 10", "10 IF (...) CYCLE".  */
09854 
09855   ffestc_labeldef_branch_end_ ();
09856 }
09857 
09858 /* ffestc_R835 -- EXIT statement
09859 
09860    ffestc_R835(name_token);
09861 
09862    Handle a EXIT within a loop.  */
09863 
09864 void
09865 ffestc_R835 (ffelexToken name)
09866 {
09867   ffestw block;
09868 
09869   ffestc_check_simple_ ();
09870   if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
09871     return;
09872   ffestc_labeldef_notloop_begin_ ();
09873 
09874   if (name == NULL)
09875     block = ffestw_top_do (ffestw_stack_top ());
09876   else
09877     {       /* Search for name. */
09878       for (block = ffestw_top_do (ffestw_stack_top ());
09879      (block != NULL) && (ffestw_blocknum (block) != 0);
09880      block = ffestw_top_do (ffestw_previous (block)))
09881   {
09882     if ((ffestw_name (block) != NULL)
09883         && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
09884       break;
09885   }
09886       if ((block == NULL) || (ffestw_blocknum (block) == 0))
09887   {
09888     block = ffestw_top_do (ffestw_stack_top ());
09889     ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
09890     ffebad_here (0, ffelex_token_where_line (name),
09891            ffelex_token_where_column (name));
09892     ffebad_finish ();
09893   }
09894     }
09895 
09896   ffestd_R835 (block);
09897 
09898   if (ffestc_shriek_after1_ != NULL)
09899     (*ffestc_shriek_after1_) (TRUE);
09900 
09901   /* notloop's that are actionif's can be the target of a loop-end
09902      statement if they're in the "then" part of a logical IF, as
09903      in "DO 10", "10 IF (...) EXIT".  */
09904 
09905   ffestc_labeldef_branch_end_ ();
09906 }
09907 
09908 /* ffestc_R836 -- GOTO statement
09909 
09910    ffestc_R836(label_token);
09911 
09912    Make sure label_token identifies a valid label for a GOTO.  Update
09913    that label's info to indicate it is the target of a GOTO.  */
09914 
09915 void
09916 ffestc_R836 (ffelexToken label_token)
09917 {
09918   ffelab label;
09919 
09920   ffestc_check_simple_ ();
09921   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
09922     return;
09923   ffestc_labeldef_notloop_begin_ ();
09924 
09925   if (ffestc_labelref_is_branch_ (label_token, &label))
09926     ffestd_R836 (label);
09927 
09928   if (ffestc_shriek_after1_ != NULL)
09929     (*ffestc_shriek_after1_) (TRUE);
09930 
09931   /* notloop's that are actionif's can be the target of a loop-end
09932      statement if they're in the "then" part of a logical IF, as
09933      in "DO 10", "10 IF (...) GOTO 100".  */
09934 
09935   ffestc_labeldef_branch_end_ ();
09936 }
09937 
09938 /* ffestc_R837 -- Computed GOTO statement
09939 
09940    ffestc_R837(label_list,expr,expr_token);
09941 
09942    Make sure label_list identifies valid labels for a GOTO.  Update
09943    each label's info to indicate it is the target of a GOTO.  */
09944 
09945 void
09946 ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
09947        ffelexToken expr_token UNUSED)
09948 {
09949   ffesttTokenItem ti;
09950   bool ok = TRUE;
09951   int i;
09952   ffelab *labels;
09953 
09954   assert (label_toks != NULL);
09955 
09956   ffestc_check_simple_ ();
09957   if (ffestc_order_actionif_ () != FFESTC_orderOK_)
09958     return;
09959   ffestc_labeldef_branch_begin_ ();
09960 
09961   labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
09962         sizeof (*labels)
09963         * ffestt_tokenlist_count (label_toks));
09964 
09965   for (ti = label_toks->first, i = 0;
09966        ti != (ffesttTokenItem) &label_toks->first;
09967        ti = ti->next, ++i)
09968     {
09969       if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
09970   {
09971     ok = FALSE;
09972     break;
09973   }
09974     }
09975 
09976   if (ok)
09977     ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
09978 
09979   if (ffestc_shriek_after1_ != NULL)
09980     (*ffestc_shriek_after1_) (TRUE);
09981   ffestc_labeldef_branch_end_ ();
09982 }
09983 
09984 /* ffestc_R838 -- ASSIGN statement
09985 
09986    ffestc_R838(label_token,target_variable,target_token);
09987 
09988    Make sure label_token identifies a valid label for an assignment.  Update
09989    that label's info to indicate it is the source of an assignment.  Update
09990    target_variable's info to indicate it is the target the assignment of that
09991    label.  */
09992 
09993 void
09994 ffestc_R838 (ffelexToken label_token, ffebld target,
09995        ffelexToken target_token UNUSED)
09996 {
09997   ffelab label;
09998 
09999   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 }