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   ffe