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