+++ /dev/null
-/* stc.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-This file is part of GNU Fortran.
-
-GNU Fortran is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Fortran is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Fortran; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA.
-
- Related Modules:
- st.c
-
- Description:
- Verifies the proper semantics for statements, checking expressions already
- semantically analyzed individually, collectively, checking label defs and
- refs, and so on. Uses ffebad to indicate errors in semantics.
-
- In many cases, both a token and a keyword (ffestrFirst, ffestrSecond,
- or ffestrOther) is provided. ONLY USE THE TOKEN as a pointer to the
- source-code location for an error message or similar; use the keyword
- as the semantic matching for the token, since the token's text might
- not match the keyword's code. For example, INTENT(IN OUT) A in free
- source form passes to ffestc_R519_start the token "IN" but the keyword
- FFESTR_otherINOUT, and the latter is correct.
-
- Generally, either a single ffestc function handles an entire statement,
- in which case its name is ffestc_xyz_, or more than one function is
- needed, in which case its names are ffestc_xyz_start_,
- ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_.
- The caller must call _start_ before calling any _item_ functions, and
- must call _finish_ afterwards. If it is clearly a syntactic matter as
- to restrictions on the number and variety of _item_ calls, then the caller
- should report any errors and ffestc_ should presume it has been taken
- care of and handle any semantic problems with grace and no error messages.
- If the permitted number and variety of _item_ calls has some basis in
- semantics, then the caller should not generate any messages and ffestc
- should do all the checking.
-
- A few ffestc functions have names rather than grammar numbers, like
- ffestc_elsewhere and ffestc_end. These are cases where the actual
- statement depends on its context rather than just its form; ELSE WHERE
- may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little
- more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE). The actual
- ffestc functions do exist and do work, but may or may not be invoked
- by ffestb depending on whether some form of resolution is possible.
- For example, ffestc_R1103 end-program-stmt is reachable directly when
- END PROGRAM [name] is specified, or via ffestc_end when END is specified
- and the context is a main program. So ffestc_xyz_ should make a quick
- determination of the context and pick the appropriate ffestc_Nxyz_
- function to invoke, without a lot of ceremony.
-
- Modifications:
-*/
-
-/* Include files. */
-
-#include "proj.h"
-#include "stc.h"
-#include "bad.h"
-#include "bld.h"
-#include "data.h"
-#include "expr.h"
-#include "global.h"
-#include "implic.h"
-#include "lex.h"
-#include "malloc.h"
-#include "src.h"
-#include "sta.h"
-#include "std.h"
-#include "stp.h"
-#include "str.h"
-#include "stt.h"
-#include "stw.h"
-
-/* Externals defined here. */
-
-ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
-/* Valid only from READ/WRITE start to finish. */
-
-/* Simple definitions and enumerations. */
-
-typedef enum
- {
- FFESTC_orderOK_, /* Statement ok in this context, process. */
- FFESTC_orderBAD_, /* Statement not ok in this context, don't
- process. */
- FFESTC_orderBADOK_, /* Don't process but push block if
- applicable. */
- FFESTC
- } ffestcOrder_;
-
-typedef enum
- {
- FFESTC_stateletSIMPLE_, /* Expecting simple/start. */
- FFESTC_stateletATTRIB_, /* Expecting attrib/item/itemstart. */
- FFESTC_stateletITEM_, /* Expecting item/itemstart/finish. */
- FFESTC_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */
- FFESTC_
- } ffestcStatelet_;
-
-/* Internal typedefs. */
-
-
-/* Private include files. */
-
-
-/* Internal structure definitions. */
-
-union ffestc_local_u_
- {
- struct
- {
- ffebld initlist; /* For list of one sym in INTEGER I/3/ case. */
- ffetargetCharacterSize stmt_size;
- ffetargetCharacterSize size;
- ffeinfoBasictype basic_type;
- ffeinfoKindtype stmt_kind_type;
- ffeinfoKindtype kind_type;
- bool per_var_kind_ok;
- char is_R426; /* 1=R426, 2=R501. */
- }
- decl;
- struct
- {
- ffebld objlist; /* For list of target objects. */
- ffebldListBottom list_bottom; /* For building lists. */
- }
- data;
- struct
- {
- ffebldListBottom list_bottom; /* For building lists. */
- int entry_num;
- }
- dummy;
- struct
- {
- ffesymbol symbol; /* NML symbol. */
- }
- namelist;
- struct
- {
- ffelexToken t; /* First token in list. */
- ffeequiv eq; /* Current equivalence being built up. */
- ffebld list; /* List of expressions in equivalence. */
- ffebldListBottom bottom;
- bool ok; /* TRUE while current list still being
- processed. */
- bool save; /* TRUE if any var in list is SAVEd. */
- }
- equiv;
- struct
- {
- ffesymbol symbol; /* BCB/NCB symbol. */
- }
- common;
- struct
- {
- ffesymbol symbol; /* SFN symbol. */
- }
- sfunc;
-#if FFESTR_VXT
- struct
- {
- char list_state; /* 0=>no field names allowed, 1=>error
- reported already, 2=>field names req'd,
- 3=>have a field name. */
- }
- V003;
-#endif
- }; /* Merge with the one in ffestc later. */
-
-/* Static objects accessed by functions in this module. */
-
-static bool ffestc_ok_; /* _start_ fn's send this to _xyz_ fn's. */
-static bool ffestc_parent_ok_; /* Parent sym for baby sym fn's ok. */
-static char ffestc_namelist_; /* 0=>not namelist, 1=>namelist, 2=>error. */
-static union ffestc_local_u_ ffestc_local_;
-static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_;
-static ffestwShriek ffestc_shriek_after1_ = NULL;
-static unsigned long ffestc_blocknum_ = 0; /* Next block# to assign. */
-static int ffestc_entry_num_;
-static int ffestc_sfdummy_argno_;
-static int ffestc_saved_entry_num_;
-static ffelab ffestc_label_;
-
-/* Static functions (internal). */
-
-static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t);
-static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt,
- ffebld len, ffelexToken lent);
-static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet,
- ffebld kind, ffelexToken kindt,
- ffebld len, ffelexToken lent);
-static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last);
-static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt,
- ffetargetCharacterSize val);
-static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt,
- ffetargetCharacterSize val);
-static void ffestc_labeldef_any_ (void);
-static bool ffestc_labeldef_begin_ (void);
-static void ffestc_labeldef_branch_begin_ (void);
-static void ffestc_labeldef_branch_end_ (void);
-static void ffestc_labeldef_endif_ (void);
-static void ffestc_labeldef_format_ (void);
-static void ffestc_labeldef_invalid_ (void);
-static void ffestc_labeldef_notloop_ (void);
-static void ffestc_labeldef_notloop_begin_ (void);
-static void ffestc_labeldef_useless_ (void);
-static bool ffestc_labelref_is_assignable_ (ffelexToken label_token,
- ffelab *label);
-static bool ffestc_labelref_is_branch_ (ffelexToken label_token,
- ffelab *label);
-static bool ffestc_labelref_is_format_ (ffelexToken label_token,
- ffelab *label);
-static bool ffestc_labelref_is_loopend_ (ffelexToken label_token,
- ffelab *label);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_access_ (void);
-#endif
-static ffestcOrder_ ffestc_order_actiondo_ (void);
-static ffestcOrder_ ffestc_order_actionif_ (void);
-static ffestcOrder_ ffestc_order_actionwhere_ (void);
-static void ffestc_order_any_ (void);
-static void ffestc_order_bad_ (void);
-static ffestcOrder_ ffestc_order_blockdata_ (void);
-static ffestcOrder_ ffestc_order_blockspec_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_component_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_contains_ (void);
-#endif
-static ffestcOrder_ ffestc_order_data_ (void);
-static ffestcOrder_ ffestc_order_data77_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_derivedtype_ (void);
-#endif
-static ffestcOrder_ ffestc_order_do_ (void);
-static ffestcOrder_ ffestc_order_entry_ (void);
-static ffestcOrder_ ffestc_order_exec_ (void);
-static ffestcOrder_ ffestc_order_format_ (void);
-static ffestcOrder_ ffestc_order_function_ (void);
-static ffestcOrder_ ffestc_order_iface_ (void);
-static ffestcOrder_ ffestc_order_ifthen_ (void);
-static ffestcOrder_ ffestc_order_implicit_ (void);
-static ffestcOrder_ ffestc_order_implicitnone_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_interface_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_map_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_module_ (void);
-#endif
-static ffestcOrder_ ffestc_order_parameter_ (void);
-static ffestcOrder_ ffestc_order_program_ (void);
-static ffestcOrder_ ffestc_order_progspec_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_record_ (void);
-#endif
-static ffestcOrder_ ffestc_order_selectcase_ (void);
-static ffestcOrder_ ffestc_order_sfunc_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_spec_ (void);
-#endif
-#if FFESTR_VXT
-static ffestcOrder_ ffestc_order_structure_ (void);
-#endif
-static ffestcOrder_ ffestc_order_subroutine_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_type_ (void);
-#endif
-static ffestcOrder_ ffestc_order_typedecl_ (void);
-#if FFESTR_VXT
-static ffestcOrder_ ffestc_order_union_ (void);
-#endif
-static ffestcOrder_ ffestc_order_unit_ (void);
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_use_ (void);
-#endif
-#if FFESTR_VXT
-static ffestcOrder_ ffestc_order_vxtstructure_ (void);
-#endif
-#if FFESTR_F90
-static ffestcOrder_ ffestc_order_where_ (void);
-#endif
-static void ffestc_promote_dummy_ (ffelexToken t);
-static void ffestc_promote_execdummy_ (ffelexToken t);
-static void ffestc_promote_sfdummy_ (ffelexToken t);
-static void ffestc_shriek_begin_program_ (void);
-#if FFESTR_F90
-static void ffestc_shriek_begin_uses_ (void);
-#endif
-static void ffestc_shriek_blockdata_ (bool ok);
-static void ffestc_shriek_do_ (bool ok);
-static void ffestc_shriek_end_program_ (bool ok);
-#if FFESTR_F90
-static void ffestc_shriek_end_uses_ (bool ok);
-#endif
-static void ffestc_shriek_function_ (bool ok);
-static void ffestc_shriek_if_ (bool ok);
-static void ffestc_shriek_ifthen_ (bool ok);
-#if FFESTR_F90
-static void ffestc_shriek_interface_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_map_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_module_ (bool ok);
-#endif
-static void ffestc_shriek_select_ (bool ok);
-#if FFESTR_VXT
-static void ffestc_shriek_structure_ (bool ok);
-#endif
-static void ffestc_shriek_subroutine_ (bool ok);
-#if FFESTR_F90
-static void ffestc_shriek_type_ (bool ok);
-#endif
-#if FFESTR_VXT
-static void ffestc_shriek_union_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_where_ (bool ok);
-#endif
-#if FFESTR_F90
-static void ffestc_shriek_wherethen_ (bool ok);
-#endif
-static int ffestc_subr_binsrch_ (const char *const *list, int size,
- ffestpFile *spec, const char *whine);
-static ffestvFormat ffestc_subr_format_ (ffestpFile *spec);
-static bool ffestc_subr_is_branch_ (ffestpFile *spec);
-static bool ffestc_subr_is_format_ (ffestpFile *spec);
-static bool ffestc_subr_is_present_ (const char *name, ffestpFile *spec);
-static int ffestc_subr_speccmp_ (const char *string, ffestpFile *spec,
- const char **target, int *length);
-static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec);
-static void ffestc_try_shriek_do_ (void);
-
-/* Internal macros. */
-
-#define ffestc_check_simple_() \
- assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_)
-#define ffestc_check_start_() \
- assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \
- ffestc_statelet_ = FFESTC_stateletATTRIB_
-#define ffestc_check_attrib_() \
- assert(ffestc_statelet_ == FFESTC_stateletATTRIB_)
-#define ffestc_check_item_() \
- assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \
- || ffestc_statelet_ == FFESTC_stateletITEM_); \
- ffestc_statelet_ = FFESTC_stateletITEM_
-#define ffestc_check_item_startvals_() \
- assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \
- || ffestc_statelet_ == FFESTC_stateletITEM_); \
- ffestc_statelet_ = FFESTC_stateletITEMVALS_
-#define ffestc_check_item_value_() \
- assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_)
-#define ffestc_check_item_endvals_() \
- assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \
- ffestc_statelet_ = FFESTC_stateletITEM_
-#define ffestc_check_finish_() \
- assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \
- || ffestc_statelet_ == FFESTC_stateletITEM_); \
- ffestc_statelet_ = FFESTC_stateletSIMPLE_
-#define ffestc_order_action_() ffestc_order_exec_()
-#if FFESTR_F90
-#define ffestc_order_interfacespec_() ffestc_order_derivedtype_()
-#endif
-#define ffestc_shriek_if_lost_ ffestc_shriek_if_
-#if FFESTR_F90
-#define ffestc_shriek_where_lost_ ffestc_shriek_where_
-#endif
-\f
-/* ffestc_establish_declinfo_ -- Determine specific type/params info for entity
-
- ffestc_establish_declinfo_(kind,kind_token,len,len_token);
-
- Must be called after _declstmt_ called to establish base type. */
-
-static void
-ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len,
- ffelexToken lent)
-{
- ffeinfoBasictype bt = ffestc_local_.decl.basic_type;
- ffeinfoKindtype kt;
- ffetargetCharacterSize val;
-
- if (kindt == NULL)
- kt = ffestc_local_.decl.stmt_kind_type;
- else if (!ffestc_local_.decl.per_var_kind_ok)
- {
- ffebad_start (FFEBAD_KINDTYPE);
- ffebad_here (0, ffelex_token_where_line (kindt),
- ffelex_token_where_column (kindt));
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- kt = ffestc_local_.decl.stmt_kind_type;
- }
- else
- {
- if (kind == NULL)
- {
- assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
- val = atol (ffelex_token_text (kindt));
- kt = ffestc_kindtype_star_ (bt, val);
- }
- else if (ffebld_op (kind) == FFEBLD_opANY)
- kt = ffestc_local_.decl.stmt_kind_type;
- else
- {
- assert (ffebld_op (kind) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (kind))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (kind))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- val = ffebld_constant_integerdefault (ffebld_conter (kind));
- kt = ffestc_kindtype_kind_ (bt, val);
- }
-
- if (kt == FFEINFO_kindtypeNONE)
- { /* Not valid kind type. */
- ffebad_start (FFEBAD_KINDTYPE);
- ffebad_here (0, ffelex_token_where_line (kindt),
- ffelex_token_where_column (kindt));
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- kt = ffestc_local_.decl.stmt_kind_type;
- }
- }
-
- ffestc_local_.decl.kind_type = kt;
-
- /* Now check length specification for CHARACTER data type. */
-
- if (((len == NULL) && (lent == NULL))
- || (bt != FFEINFO_basictypeCHARACTER))
- val = ffestc_local_.decl.stmt_size;
- else
- {
- if (len == NULL)
- {
- assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
- val = atol (ffelex_token_text (lent));
- }
- else if (ffebld_op (len) == FFEBLD_opSTAR)
- val = FFETARGET_charactersizeNONE;
- else if (ffebld_op (len) == FFEBLD_opANY)
- val = FFETARGET_charactersizeNONE;
- else
- {
- assert (ffebld_op (len) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (len))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (len))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- val = ffebld_constant_integerdefault (ffebld_conter (len));
- }
- }
-
- if ((val == 0) && !(0 && ffe_is_90 ()))
- {
- val = 1;
- ffebad_start (FFEBAD_ZERO_SIZE);
- ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
- ffebad_finish ();
- }
- ffestc_local_.decl.size = val;
-}
-
-/* ffestc_establish_declstmt_ -- Establish host-specific type/params info
-
- ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
- len_token); */
-
-static void
-ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent)
-{
- ffeinfoBasictype bt;
- ffeinfoKindtype ktd; /* Default kindtype. */
- ffeinfoKindtype kt;
- ffetargetCharacterSize val;
- bool per_var_kind_ok = TRUE;
-
- /* Determine basictype and default kindtype. */
-
- switch (type)
- {
- case FFESTP_typeINTEGER:
- bt = FFEINFO_basictypeINTEGER;
- ktd = FFEINFO_kindtypeINTEGERDEFAULT;
- break;
-
- case FFESTP_typeBYTE:
- bt = FFEINFO_basictypeINTEGER;
- ktd = FFEINFO_kindtypeINTEGER2;
- break;
-
- case FFESTP_typeWORD:
- bt = FFEINFO_basictypeINTEGER;
- ktd = FFEINFO_kindtypeINTEGER3;
- break;
-
- case FFESTP_typeREAL:
- bt = FFEINFO_basictypeREAL;
- ktd = FFEINFO_kindtypeREALDEFAULT;
- break;
-
- case FFESTP_typeCOMPLEX:
- bt = FFEINFO_basictypeCOMPLEX;
- ktd = FFEINFO_kindtypeREALDEFAULT;
- break;
-
- case FFESTP_typeLOGICAL:
- bt = FFEINFO_basictypeLOGICAL;
- ktd = FFEINFO_kindtypeLOGICALDEFAULT;
- break;
-
- case FFESTP_typeCHARACTER:
- bt = FFEINFO_basictypeCHARACTER;
- ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
- break;
-
- case FFESTP_typeDBLPRCSN:
- bt = FFEINFO_basictypeREAL;
- ktd = FFEINFO_kindtypeREALDOUBLE;
- per_var_kind_ok = FALSE;
- break;
-
- case FFESTP_typeDBLCMPLX:
- bt = FFEINFO_basictypeCOMPLEX;
-#if FFETARGET_okCOMPLEX2
- ktd = FFEINFO_kindtypeREALDOUBLE;
-#else
- ktd = FFEINFO_kindtypeREALDEFAULT;
- ffebad_start (FFEBAD_BAD_DBLCMPLX);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
-#endif
- per_var_kind_ok = FALSE;
- break;
-
- default:
- assert ("Unexpected type (F90 TYPE?)!" == NULL);
- bt = FFEINFO_basictypeNONE;
- ktd = FFEINFO_kindtypeNONE;
- break;
- }
-
- if (kindt == NULL)
- kt = ktd;
- else
- { /* Not necessarily default kind type. */
- if (kind == NULL)
- { /* Shouldn't happen for CHARACTER. */
- assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
- val = atol (ffelex_token_text (kindt));
- kt = ffestc_kindtype_star_ (bt, val);
- }
- else if (ffebld_op (kind) == FFEBLD_opANY)
- kt = ktd;
- else
- {
- assert (ffebld_op (kind) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (kind))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (kind))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- val = ffebld_constant_integerdefault (ffebld_conter (kind));
- kt = ffestc_kindtype_kind_ (bt, val);
- }
-
- if (kt == FFEINFO_kindtypeNONE)
- { /* Not valid kind type. */
- ffebad_start (FFEBAD_KINDTYPE);
- ffebad_here (0, ffelex_token_where_line (kindt),
- ffelex_token_where_column (kindt));
- ffebad_here (1, ffelex_token_where_line (typet),
- ffelex_token_where_column (typet));
- ffebad_finish ();
- kt = ktd;
- }
- }
-
- ffestc_local_.decl.basic_type = bt;
- ffestc_local_.decl.stmt_kind_type = kt;
- ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok;
-
- /* Now check length specification for CHARACTER data type. */
-
- if (((len == NULL) && (lent == NULL))
- || (type != FFESTP_typeCHARACTER))
- val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
- else
- {
- if (len == NULL)
- {
- assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
- val = atol (ffelex_token_text (lent));
- }
- else if (ffebld_op (len) == FFEBLD_opSTAR)
- val = FFETARGET_charactersizeNONE;
- else if (ffebld_op (len) == FFEBLD_opANY)
- val = FFETARGET_charactersizeNONE;
- else
- {
- assert (ffebld_op (len) == FFEBLD_opCONTER);
- assert (ffeinfo_basictype (ffebld_info (len))
- == FFEINFO_basictypeINTEGER);
- assert (ffeinfo_kindtype (ffebld_info (len))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- val = ffebld_constant_integerdefault (ffebld_conter (len));
- }
- }
-
- if ((val == 0) && !(0 && ffe_is_90 ()))
- {
- val = 1;
- ffebad_start (FFEBAD_ZERO_SIZE);
- ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
- ffebad_finish ();
- }
- ffestc_local_.decl.stmt_size = val;
-}
-
-/* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)
-
- ffestc_establish_impletter_(first_letter_token,last_letter_token); */
-
-static void
-ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
-{
- bool ok = FALSE; /* Stays FALSE if first letter > last. */
- char c;
-
- if (last == NULL)
- ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)),
- ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- ffestc_local_.decl.size);
- else
- {
- for (c = *(ffelex_token_text (first));
- c <= *(ffelex_token_text (last));
- c++)
- {
- ok = ffeimplic_establish_initial (c,
- ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- ffestc_local_.decl.size);
- if (!ok)
- break;
- }
- }
-
- if (!ok)
- {
- char cs[2];
-
- cs[0] = c;
- cs[1] = '\0';
-
- ffebad_start (FFEBAD_BAD_IMPLICIT);
- ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
- ffebad_string (cs);
- ffebad_finish ();
- }
-}
-
-/* ffestc_init_3 -- Initialize ffestc for new program unit
-
- ffestc_init_3(); */
-
-void
-ffestc_init_3 ()
-{
- ffestv_save_state_ = FFESTV_savestateNONE;
- ffestc_entry_num_ = 0;
- ffestv_num_label_defines_ = 0;
-}
-
-/* ffestc_init_4 -- Initialize ffestc for new scoping unit
-
- ffestc_init_4();
-
- For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
- defs, and statement function defs. */
-
-void
-ffestc_init_4 ()
-{
- ffestc_saved_entry_num_ = ffestc_entry_num_;
- ffestc_entry_num_ = 0;
-}
-
-/* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value
-
- ffeinfoKindtype kt;
- ffeinfoBasictype bt;
- ffetargetCharacterSize val;
- kt = ffestc_kindtype_kind_(bt,val);
- if (kt == FFEINFO_kindtypeNONE)
- // unsupported/invalid KIND= value for type */
-
-static ffeinfoKindtype
-ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
-{
- ffetype type;
- ffetype base_type;
- ffeinfoKindtype kt;
-
- base_type = ffeinfo_type (bt, 1); /* ~~ */
- assert (base_type != NULL);
-
- type = ffetype_lookup_kind (base_type, (int) val);
- if (type == NULL)
- return FFEINFO_kindtypeNONE;
-
- for (kt = 1; kt < FFEINFO_kindtype; ++kt)
- if (ffeinfo_type (bt, kt) == type)
- return kt;
-
- return FFEINFO_kindtypeNONE;
-}
-
-/* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value
-
- ffeinfoKindtype kt;
- ffeinfoBasictype bt;
- ffetargetCharacterSize val;
- kt = ffestc_kindtype_star_(bt,val);
- if (kt == FFEINFO_kindtypeNONE)
- // unsupported/invalid * value for type */
-
-static ffeinfoKindtype
-ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
-{
- ffetype type;
- ffetype base_type;
- ffeinfoKindtype kt;
-
- base_type = ffeinfo_type (bt, 1); /* ~~ */
- assert (base_type != NULL);
-
- type = ffetype_lookup_star (base_type, (int) val);
- if (type == NULL)
- return FFEINFO_kindtypeNONE;
-
- for (kt = 1; kt < FFEINFO_kindtype; ++kt)
- if (ffeinfo_type (bt, kt) == type)
- return kt;
-
- return FFEINFO_kindtypeNONE;
-}
-
-/* Define label as usable for anything without complaint. */
-
-static void
-ffestc_labeldef_any_ ()
-{
- if ((ffesta_label_token == NULL)
- || !ffestc_labeldef_begin_ ())
- return;
-
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_labeldef_begin_ -- Define label as unknown, initially
-
- ffestc_labeldef_begin_(); */
-
-static bool
-ffestc_labeldef_begin_ ()
-{
- ffelabValue label_value;
- ffelab label;
-
- label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
- if ((label_value == 0) || (label_value > FFELAB_valueMAX))
- {
- ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
- }
-
- label = ffelab_find (label_value);
- if (label == NULL)
- {
- label = ffestc_label_ = ffelab_new (label_value);
- ffestv_num_label_defines_++;
- ffelab_set_definition_line (label,
- ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
- ffelab_set_definition_column (label,
- ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
-
- return TRUE;
- }
-
- if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
- {
- ffestv_num_label_defines_++;
- ffestc_label_ = label;
- ffelab_set_definition_line (label,
- ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
- ffelab_set_definition_column (label,
- ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));
-
- return TRUE;
- }
-
- ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_definition_line (label),
- ffelab_definition_column (label));
- ffebad_string (ffelex_token_text (ffesta_label_token));
- ffebad_finish ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
- return FALSE;
-}
-
-/* ffestc_labeldef_branch_begin_ -- Define label as a branch target one
-
- ffestc_labeldef_branch_begin_(); */
-
-static void
-ffestc_labeldef_branch_begin_ ()
-{
- if ((ffesta_label_token == NULL)
- || (ffestc_shriek_after1_ != NULL)
- || !ffestc_labeldef_begin_ ())
- return;
-
- switch (ffelab_type (ffestc_label_))
- {
- case FFELAB_typeUNKNOWN:
- case FFELAB_typeASSIGNABLE:
- ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_stack_top ()));
- ffestd_labeldef_branch (ffestc_label_);
- break;
-
- case FFELAB_typeNOTLOOP:
- if (ffelab_blocknum (ffestc_label_)
- < ffestw_blocknum (ffestw_stack_top ()))
- {
- ffebad_start (FFEBAD_LABEL_BLOCK);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- }
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_stack_top ()));
- ffestd_labeldef_branch (ffestc_label_);
- break;
-
- case FFELAB_typeLOOPEND:
- if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
- || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
- { /* Unterminated block. */
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
- ffebad_here (0, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
- break;
- }
- ffestd_labeldef_branch (ffestc_label_);
- /* Leave something around for _branch_end_() to handle. */
- return;
-
- case FFELAB_typeFORMAT:
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- break;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* Define possible end of labeled-DO-loop. Call only after calling
- ffestc_labeldef_branch_begin_, or when other branch_* functions
- recognize that a label might also be serving as a branch end (in
- which case they must issue a diagnostic). */
-
-static void
-ffestc_labeldef_branch_end_ ()
-{
- if (ffesta_label_token == NULL)
- return;
-
- assert (ffestc_label_ != NULL);
- assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND)
- || (ffelab_type (ffestc_label_) == FFELAB_typeANY));
-
- while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
- && (ffestw_label (ffestw_stack_top ()) == ffestc_label_))
- ffestc_shriek_do_ (TRUE);
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* ffestc_labeldef_endif_ -- Define label as an END IF one
-
- ffestc_labeldef_endif_(); */
-
-static void
-ffestc_labeldef_endif_ ()
-{
- if ((ffesta_label_token == NULL)
- || (ffestc_shriek_after1_ != NULL)
- || !ffestc_labeldef_begin_ ())
- return;
-
- switch (ffelab_type (ffestc_label_))
- {
- case FFELAB_typeUNKNOWN:
- case FFELAB_typeASSIGNABLE:
- ffelab_set_type (ffestc_label_, FFELAB_typeENDIF);
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
- ffestd_labeldef_endif (ffestc_label_);
- break;
-
- case FFELAB_typeNOTLOOP:
- if (ffelab_blocknum (ffestc_label_)
- < ffestw_blocknum (ffestw_previous (ffestw_stack_top ())))
- {
- ffebad_start (FFEBAD_LABEL_BLOCK);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- }
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_previous (ffestw_stack_top ())));
- ffestd_labeldef_endif (ffestc_label_);
- break;
-
- case FFELAB_typeLOOPEND:
- if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
- || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
- { /* Unterminated block. */
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
- ffebad_here (0, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
- break;
- }
- ffestd_labeldef_endif (ffestc_label_);
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_finish ();
- ffestc_labeldef_branch_end_ ();
- return;
-
- case FFELAB_typeFORMAT:
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- break;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* ffestc_labeldef_format_ -- Define label as a FORMAT one
-
- ffestc_labeldef_format_(); */
-
-static void
-ffestc_labeldef_format_ ()
-{
- if ((ffesta_label_token == NULL)
- || (ffestc_shriek_after1_ != NULL))
- {
- ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- return;
- }
-
- if (!ffestc_labeldef_begin_ ())
- return;
-
- switch (ffelab_type (ffestc_label_))
- {
- case FFELAB_typeUNKNOWN:
- case FFELAB_typeASSIGNABLE:
- ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT);
- ffestd_labeldef_format (ffestc_label_);
- break;
-
- case FFELAB_typeFORMAT:
- ffestd_labeldef_format (ffestc_label_);
- break;
-
- case FFELAB_typeLOOPEND:
- if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
- || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
- { /* Unterminated block. */
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
- ffebad_here (0, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
- break;
- }
- ffestd_labeldef_format (ffestc_label_);
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_finish ();
- ffestc_labeldef_branch_end_ ();
- return;
-
- case FFELAB_typeNOTLOOP:
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- break;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present
-
- ffestc_labeldef_invalid_(); */
-
-static void
-ffestc_labeldef_invalid_ ()
-{
- if ((ffesta_label_token == NULL)
- || (ffestc_shriek_after1_ != NULL)
- || !ffestc_labeldef_begin_ ())
- return;
-
- ffebad_start (FFEBAD_INVALID_LABEL_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
-
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* Define label as a non-loop-ending one on a statement that can't
- be in the "then" part of a logical IF, such as a block-IF statement. */
-
-static void
-ffestc_labeldef_notloop_ ()
-{
- if (ffesta_label_token == NULL)
- return;
-
- assert (ffestc_shriek_after1_ == NULL);
-
- if (!ffestc_labeldef_begin_ ())
- return;
-
- switch (ffelab_type (ffestc_label_))
- {
- case FFELAB_typeUNKNOWN:
- case FFELAB_typeASSIGNABLE:
- ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_stack_top ()));
- ffestd_labeldef_notloop (ffestc_label_);
- break;
-
- case FFELAB_typeNOTLOOP:
- if (ffelab_blocknum (ffestc_label_)
- < ffestw_blocknum (ffestw_stack_top ()))
- {
- ffebad_start (FFEBAD_LABEL_BLOCK);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- }
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_stack_top ()));
- ffestd_labeldef_notloop (ffestc_label_);
- break;
-
- case FFELAB_typeLOOPEND:
- if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
- || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
- { /* Unterminated block. */
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
- ffebad_here (0, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
- break;
- }
- ffestd_labeldef_notloop (ffestc_label_);
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_finish ();
- ffestc_labeldef_branch_end_ ();
- return;
-
- case FFELAB_typeFORMAT:
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- break;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* Define label as a non-loop-ending one. Use this when it is
- possible that the pending label is inhibited because we're in
- the midst of a logical-IF, and thus _branch_end_ is going to
- be called after the current statement to resolve a potential
- loop-ending label. */
-
-static void
-ffestc_labeldef_notloop_begin_ ()
-{
- if ((ffesta_label_token == NULL)
- || (ffestc_shriek_after1_ != NULL)
- || !ffestc_labeldef_begin_ ())
- return;
-
- switch (ffelab_type (ffestc_label_))
- {
- case FFELAB_typeUNKNOWN:
- case FFELAB_typeASSIGNABLE:
- ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_stack_top ()));
- ffestd_labeldef_notloop (ffestc_label_);
- break;
-
- case FFELAB_typeNOTLOOP:
- if (ffelab_blocknum (ffestc_label_)
- < ffestw_blocknum (ffestw_stack_top ()))
- {
- ffebad_start (FFEBAD_LABEL_BLOCK);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- }
- ffelab_set_blocknum (ffestc_label_,
- ffestw_blocknum (ffestw_stack_top ()));
- ffestd_labeldef_notloop (ffestc_label_);
- break;
-
- case FFELAB_typeLOOPEND:
- if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
- || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
- { /* Unterminated block. */
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
- ffebad_here (0, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
- break;
- }
- ffestd_labeldef_branch (ffestc_label_);
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_finish ();
- return;
-
- case FFELAB_typeFORMAT:
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- break;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* ffestc_labeldef_useless_ -- Define label as a useless one
-
- ffestc_labeldef_useless_(); */
-
-static void
-ffestc_labeldef_useless_ ()
-{
- if ((ffesta_label_token == NULL)
- || (ffestc_shriek_after1_ != NULL)
- || !ffestc_labeldef_begin_ ())
- return;
-
- switch (ffelab_type (ffestc_label_))
- {
- case FFELAB_typeUNKNOWN:
- ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS);
- ffestd_labeldef_useless (ffestc_label_);
- break;
-
- case FFELAB_typeLOOPEND:
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
- || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
- { /* Unterminated block. */
- ffebad_start (FFEBAD_LABEL_DO_BLOCK_END);
- ffebad_here (0, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_here (2, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_finish ();
- break;
- }
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_doref_line (ffestc_label_),
- ffelab_doref_column (ffestc_label_));
- ffebad_finish ();
- ffestc_labeldef_branch_end_ ();
- return;
-
- case FFELAB_typeASSIGNABLE:
- case FFELAB_typeFORMAT:
- case FFELAB_typeNOTLOOP:
- ffelab_set_type (ffestc_label_, FFELAB_typeANY);
- ffestd_labeldef_any (ffestc_label_);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
- ffelex_token_where_column (ffesta_label_token));
- ffebad_here (1, ffelab_firstref_line (ffestc_label_),
- ffelab_firstref_column (ffestc_label_));
- ffebad_finish ();
- break;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- ffestc_try_shriek_do_ ();
-
- ffelex_token_kill (ffesta_label_token);
- ffesta_label_token = NULL;
-}
-
-/* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt
-
- if (ffestc_labelref_is_assignable_(label_token,&label))
- // label ref is ok, label is filled in with ffelab object */
-
-static bool
-ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label)
-{
- ffelab label;
- ffelabValue label_value;
-
- label_value = (ffelabValue) atol (ffelex_token_text (label_token));
- if ((label_value == 0) || (label_value > FFELAB_valueMAX))
- {
- ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
- ffebad_here (0, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
- return FALSE;
- }
-
- label = ffelab_find (label_value);
- if (label == NULL)
- {
- label = ffelab_new (label_value);
- ffelab_set_firstref_line (label,
- ffewhere_line_use (ffelex_token_where_line (label_token)));
- ffelab_set_firstref_column (label,
- ffewhere_column_use (ffelex_token_where_column (label_token)));
- }
-
- switch (ffelab_type (label))
- {
- case FFELAB_typeUNKNOWN:
- ffelab_set_type (label, FFELAB_typeASSIGNABLE);
- break;
-
- case FFELAB_typeASSIGNABLE:
- case FFELAB_typeLOOPEND:
- case FFELAB_typeFORMAT:
- case FFELAB_typeNOTLOOP:
- case FFELAB_typeENDIF:
- break;
-
- case FFELAB_typeUSELESS:
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- *x_label = label;
- return TRUE;
-}
-
-/* ffestc_labelref_is_branch_ -- Reference to label in branch stmt
-
- if (ffestc_labelref_is_branch_(label_token,&label))
- // label ref is ok, label is filled in with ffelab object */
-
-static bool
-ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label)
-{
- ffelab label;
- ffelabValue label_value;
- ffestw block;
- unsigned long blocknum;
-
- label_value = (ffelabValue) atol (ffelex_token_text (label_token));
- if ((label_value == 0) || (label_value > FFELAB_valueMAX))
- {
- ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
- ffebad_here (0, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
- return FALSE;
- }
-
- label = ffelab_find (label_value);
- if (label == NULL)
- {
- label = ffelab_new (label_value);
- ffelab_set_firstref_line (label,
- ffewhere_line_use (ffelex_token_where_line (label_token)));
- ffelab_set_firstref_column (label,
- ffewhere_column_use (ffelex_token_where_column (label_token)));
- }
-
- switch (ffelab_type (label))
- {
- case FFELAB_typeUNKNOWN:
- case FFELAB_typeASSIGNABLE:
- ffelab_set_type (label, FFELAB_typeNOTLOOP);
- ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ()));
- break;
-
- case FFELAB_typeLOOPEND:
- if (ffelab_blocknum (label) != 0)
- break; /* Already taken care of. */
- for (block = ffestw_top_do (ffestw_stack_top ());
- (block != NULL) && (ffestw_label (block) != label);
- block = ffestw_top_do (ffestw_previous (block)))
- ; /* Find most recent DO <label> ancestor. */
- if (block == NULL)
- { /* Reference to within a (dead) block. */
- ffebad_start (FFEBAD_LABEL_BLOCK);
- ffebad_here (0, ffelab_definition_line (label),
- ffelab_definition_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
- break;
- }
- ffelab_set_blocknum (label, ffestw_blocknum (block));
- ffelab_set_firstref_line (label,
- ffewhere_line_use (ffelex_token_where_line (label_token)));
- ffelab_set_firstref_column (label,
- ffewhere_column_use (ffelex_token_where_column (label_token)));
- break;
-
- case FFELAB_typeNOTLOOP:
- case FFELAB_typeENDIF:
- if (ffelab_blocknum (label) == ffestw_blocknum (ffestw_stack_top ()))
- break;
- blocknum = ffelab_blocknum (label);
- for (block = ffestw_stack_top ();
- ffestw_blocknum (block) > blocknum;
- block = ffestw_previous (block))
- ; /* Find most recent common ancestor. */
- if (ffelab_blocknum (label) == ffestw_blocknum (block))
- break; /* Check again. */
- if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
- { /* Reference to within a (dead) block. */
- ffebad_start (FFEBAD_LABEL_BLOCK);
- ffebad_here (0, ffelab_definition_line (label),
- ffelab_definition_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
- break;
- }
- ffelab_set_blocknum (label, ffestw_blocknum (block));
- break;
-
- case FFELAB_typeFORMAT:
- if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
- {
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_USE);
- ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
- }
- /* Fall through. */
- case FFELAB_typeUSELESS:
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- *x_label = label;
- return TRUE;
-}
-
-/* ffestc_labelref_is_format_ -- Reference to label in [FMT=] specification
-
- if (ffestc_labelref_is_format_(label_token,&label))
- // label ref is ok, label is filled in with ffelab object */
-
-static bool
-ffestc_labelref_is_format_ (ffelexToken label_token, ffelab *x_label)
-{
- ffelab label;
- ffelabValue label_value;
-
- label_value = (ffelabValue) atol (ffelex_token_text (label_token));
- if ((label_value == 0) || (label_value > FFELAB_valueMAX))
- {
- ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
- ffebad_here (0, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
- return FALSE;
- }
-
- label = ffelab_find (label_value);
- if (label == NULL)
- {
- label = ffelab_new (label_value);
- ffelab_set_firstref_line (label,
- ffewhere_line_use (ffelex_token_where_line (label_token)));
- ffelab_set_firstref_column (label,
- ffewhere_column_use (ffelex_token_where_column (label_token)));
- }
-
- switch (ffelab_type (label))
- {
- case FFELAB_typeUNKNOWN:
- case FFELAB_typeASSIGNABLE:
- ffelab_set_type (label, FFELAB_typeFORMAT);
- break;
-
- case FFELAB_typeFORMAT:
- break;
-
- case FFELAB_typeLOOPEND:
- case FFELAB_typeNOTLOOP:
- if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
- {
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_USE);
- ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
- }
- /* Fall through. */
- case FFELAB_typeUSELESS:
- case FFELAB_typeENDIF:
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- ffestc_try_shriek_do_ ();
-
- *x_label = label;
- return TRUE;
-}
-
-/* ffestc_labelref_is_loopend_ -- Reference to label in DO stmt
-
- if (ffestc_labelref_is_loopend_(label_token,&label))
- // label ref is ok, label is filled in with ffelab object */
-
-static bool
-ffestc_labelref_is_loopend_ (ffelexToken label_token, ffelab *x_label)
-{
- ffelab label;
- ffelabValue label_value;
-
- label_value = (ffelabValue) atol (ffelex_token_text (label_token));
- if ((label_value == 0) || (label_value > FFELAB_valueMAX))
- {
- ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
- ffebad_here (0, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
- return FALSE;
- }
-
- label = ffelab_find (label_value);
- if (label == NULL)
- {
- label = ffelab_new (label_value);
- ffelab_set_doref_line (label,
- ffewhere_line_use (ffelex_token_where_line (label_token)));
- ffelab_set_doref_column (label,
- ffewhere_column_use (ffelex_token_where_column (label_token)));
- }
-
- switch (ffelab_type (label))
- {
- case FFELAB_typeASSIGNABLE:
- ffelab_set_doref_line (label,
- ffewhere_line_use (ffelex_token_where_line (label_token)));
- ffelab_set_doref_column (label,
- ffewhere_column_use (ffelex_token_where_column (label_token)));
- ffewhere_line_kill (ffelab_firstref_line (label));
- ffelab_set_firstref_line (label, ffewhere_line_unknown ());
- ffewhere_column_kill (ffelab_firstref_column (label));
- ffelab_set_firstref_column (label, ffewhere_column_unknown ());
- /* Fall through. */
- case FFELAB_typeUNKNOWN:
- ffelab_set_type (label, FFELAB_typeLOOPEND);
- ffelab_set_blocknum (label, 0);
- break;
-
- case FFELAB_typeLOOPEND:
- if (!ffewhere_line_is_unknown (ffelab_definition_line (label)))
- { /* Def must follow all refs. */
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_DEF_DO);
- ffebad_here (0, ffelab_definition_line (label),
- ffelab_definition_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
- }
- if (ffelab_blocknum (label) != 0)
- { /* Had a branch ref earlier, can't go inside
- this new block! */
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_USE);
- ffebad_here (0, ffelab_firstref_line (label),
- ffelab_firstref_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
- }
- if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
- || (ffestw_label (ffestw_stack_top ()) != label))
- { /* Top of stack interrupts flow between two
- DOs specifying label. */
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_DO_BLOCK_DO);
- ffebad_here (0, ffelab_doref_line (label),
- ffelab_doref_column (label));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_here (2, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
- }
- break;
-
- case FFELAB_typeNOTLOOP:
- case FFELAB_typeFORMAT:
- if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
- {
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_USE);
- ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
- }
- /* Fall through. */
- case FFELAB_typeUSELESS:
- case FFELAB_typeENDIF:
- ffelab_set_type (label, FFELAB_typeANY);
- ffestd_labeldef_any (label);
-
- ffebad_start (FFEBAD_LABEL_USE_DEF);
- ffebad_here (0, ffelab_definition_line (label), ffelab_definition_column (label));
- ffebad_here (1, ffelex_token_where_line (label_token),
- ffelex_token_where_column (label_token));
- ffebad_finish ();
-
- ffestc_try_shriek_do_ ();
-
- return FALSE;
-
- default:
- assert ("bad label" == NULL);
- /* Fall through. */
- case FFELAB_typeANY:
- break;
- }
-
- *x_label = label;
- return TRUE;
-}
-
-/* ffestc_order_access_ -- Check ordering on <access> statement
-
- if (ffestc_order_access_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_access_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_actiondo_ -- Check ordering on <actiondo> statement
-
- if (ffestc_order_actiondo_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_actiondo_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateDO:
- return FFESTC_orderOK_;
-
- case FFESTV_stateIFTHEN:
- case FFESTV_stateSELECT1:
- if (ffestw_top_do (ffestw_stack_top ()) == NULL)
- break;
- return FFESTC_orderOK_;
-
- case FFESTV_stateIF:
- if (ffestw_top_do (ffestw_stack_top ()) == NULL)
- break;
- ffestc_shriek_after1_ = ffestc_shriek_if_;
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- default:
- break;
- }
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
-}
-
-/* ffestc_order_actionif_ -- Check ordering on <actionif> statement
-
- if (ffestc_order_actionif_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_actionif_ ()
-{
- bool update;
-
-recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
- update = TRUE;
- break;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
- update = TRUE;
- break;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
- update = TRUE;
- break;
-
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- update = FALSE;
- break;
-
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateIF:
- ffestc_shriek_after1_ = ffestc_shriek_if_;
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-
- switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
- {
- case FFESTV_stateINTERFACE0:
- ffestc_order_bad_ ();
- if (update)
- ffestw_update (NULL);
- return FFESTC_orderBAD_;
-
- default:
- if (update)
- ffestw_update (NULL);
- return FFESTC_orderOK_;
- }
-}
-
-/* ffestc_order_actionwhere_ -- Check ordering on <actionwhere> statement
-
- if (ffestc_order_actionwhere_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_actionwhere_ ()
-{
- bool update;
-
-recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
- update = TRUE;
- break;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
- update = TRUE;
- break;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
- update = TRUE;
- break;
-
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- update = FALSE;
- break;
-
- case FFESTV_stateWHERETHEN:
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
-#if FFESTR_F90
- ffestc_shriek_after1_ = ffestc_shriek_where_;
-#endif
- return FFESTC_orderOK_;
-
- case FFESTV_stateIF:
- ffestc_shriek_after1_ = ffestc_shriek_if_;
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-
- switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
- {
- case FFESTV_stateINTERFACE0:
- ffestc_order_bad_ ();
- if (update)
- ffestw_update (NULL);
- return FFESTC_orderBAD_;
-
- default:
- if (update)
- ffestw_update (NULL);
- return FFESTC_orderOK_;
- }
-}
-
-/* Check ordering on "any" statement. Like _actionwhere_, but
- doesn't produce any diagnostics. */
-
-static void
-ffestc_order_any_ ()
-{
- bool update;
-
-recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
- update = TRUE;
- break;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
- update = TRUE;
- break;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
- update = TRUE;
- break;
-
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- update = FALSE;
- break;
-
- case FFESTV_stateWHERETHEN:
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT1:
- return;
-
- case FFESTV_stateWHERE:
-#if FFESTR_F90
- ffestc_shriek_after1_ = ffestc_shriek_where_;
-#endif
- return;
-
- case FFESTV_stateIF:
- ffestc_shriek_after1_ = ffestc_shriek_if_;
- return;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- default:
- return;
- }
-
- switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
- {
- case FFESTV_stateINTERFACE0:
- if (update)
- ffestw_update (NULL);
- return;
-
- default:
- if (update)
- ffestw_update (NULL);
- return;
- }
-}
-
-/* ffestc_order_bad_ -- Whine about statement ordering violation
-
- ffestc_order_bad_();
-
- Uses current ffesta_tokens[0] and, if available, info on where current
- state started to produce generic message. Someday we should do
- fancier things than this, but this just gets things creaking along for
- now. */
-
-static void
-ffestc_order_bad_ ()
-{
- if (ffewhere_line_is_unknown (ffestw_line (ffestw_stack_top ())))
- {
- ffebad_start (FFEBAD_ORDER_1);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- else
- {
- ffebad_start (FFEBAD_ORDER_2);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- ffestc_labeldef_useless_ (); /* Any label definition is useless. */
-}
-
-/* ffestc_order_blockdata_ -- Check ordering on <blockdata> statement
-
- if (ffestc_order_blockdata_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_blockdata_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateBLOCKDATA4:
- case FFESTV_stateBLOCKDATA5:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_blockspec_ -- Check ordering on <blockspec> statement
-
- if (ffestc_order_blockspec_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_blockspec_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_component_ -- Check ordering on <component-decl> statement
-
- if (ffestc_order_component_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_component_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateTYPE:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_contains_ -- Check ordering on CONTAINS statement
-
- if (ffestc_order_contains_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_contains_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- case FFESTV_statePROGRAM4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM5);
- break;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateSUBROUTINE4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE5);
- break;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateFUNCTION4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION5);
- break;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- case FFESTV_stateMODULE3:
- case FFESTV_stateMODULE4:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE5);
- break;
-
- case FFESTV_stateUSE:
- ffestc_shriek_end_uses_ (TRUE);
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-
- switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
- {
- case FFESTV_stateNIL:
- ffestw_update (NULL);
- return FFESTC_orderOK_;
-
- default:
- ffestc_order_bad_ ();
- ffestw_update (NULL);
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_data_ -- Check ordering on DATA statement
-
- if (ffestc_order_data_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_data_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateBLOCKDATA4:
- case FFESTV_stateWHERETHEN:
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT0:
- case FFESTV_stateSELECT1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_data77_ -- Check ordering on pedantic-F77 DATA statement
-
- if (ffestc_order_data77_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_data77_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_stateBLOCKDATA3:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA4);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateBLOCKDATA4:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERETHEN:
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT0:
- case FFESTV_stateSELECT1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_derivedtype_ -- Check ordering on derived TYPE statement
-
- if (ffestc_order_derivedtype_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_derivedtype_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
- ffestc_shriek_end_uses_ (TRUE);
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_do_ -- Check ordering on <do> statement
-
- if (ffestc_order_do_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_do_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateDO:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_entry_ -- Check ordering on ENTRY statement
-
- if (ffestc_order_entry_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_entry_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateSUBROUTINE0:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
- break;
-
- case FFESTV_stateFUNCTION0:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
- break;
-
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- break;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-
- switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
- {
- case FFESTV_stateNIL:
- case FFESTV_stateMODULE5:
- ffestw_update (NULL);
- return FFESTC_orderOK_;
-
- default:
- ffestc_order_bad_ ();
- ffestw_update (NULL);
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_exec_ -- Check ordering on <exec> statement
-
- if (ffestc_order_exec_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_exec_ ()
-{
- bool update;
-
-recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM4);
- update = TRUE;
- break;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE4);
- update = TRUE;
- break;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION4);
- update = TRUE;
- break;
-
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- update = FALSE;
- break;
-
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-
- switch (ffestw_state (ffestw_previous (ffestw_stack_top ())))
- {
- case FFESTV_stateINTERFACE0:
- ffestc_order_bad_ ();
- if (update)
- ffestw_update (NULL);
- return FFESTC_orderBAD_;
-
- default:
- if (update)
- ffestw_update (NULL);
- return FFESTC_orderOK_;
- }
-}
-
-/* ffestc_order_format_ -- Check ordering on FORMAT statement
-
- if (ffestc_order_format_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_format_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateWHERETHEN:
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT0:
- case FFESTV_stateSELECT1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_function_ -- Check ordering on <function> statement
-
- if (ffestc_order_function_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_function_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateFUNCTION5:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_iface_ -- Check ordering on <iface> statement
-
- if (ffestc_order_iface_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_iface_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- case FFESTV_statePROGRAM5:
- case FFESTV_stateSUBROUTINE5:
- case FFESTV_stateFUNCTION5:
- case FFESTV_stateMODULE5:
- case FFESTV_stateINTERFACE0:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_ifthen_ -- Check ordering on <ifthen> statement
-
- if (ffestc_order_ifthen_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_ifthen_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateIFTHEN:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_implicit_ -- Check ordering on IMPLICIT statement
-
- if (ffestc_order_implicit_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_implicit_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateMODULE2:
- case FFESTV_stateBLOCKDATA2:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_implicitnone_ -- Check ordering on IMPLICIT NONE statement
-
- if (ffestc_order_implicitnone_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_implicitnone_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_interface_ -- Check ordering on <interface> statement
-
- if (ffestc_order_interface_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_interface_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateINTERFACE0:
- case FFESTV_stateINTERFACE1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_map_ -- Check ordering on <map> statement
-
- if (ffestc_order_map_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_map_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_module_ -- Check ordering on <module> statement
-
- if (ffestc_order_module_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_module_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- case FFESTV_stateMODULE3:
- case FFESTV_stateMODULE4:
- case FFESTV_stateMODULE5:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
- ffestc_shriek_end_uses_ (TRUE);
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_parameter_ -- Check ordering on <parameter> statement
-
- if (ffestc_order_parameter_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_parameter_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE2);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateMODULE2:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateTYPE: /* GNU extension here! */
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateUNION:
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_program_ -- Check ordering on <program> statement
-
- if (ffestc_order_program_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_program_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- case FFESTV_statePROGRAM3:
- case FFESTV_statePROGRAM4:
- case FFESTV_statePROGRAM5:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_progspec_ -- Check ordering on <progspec> statement
-
- if (ffestc_order_progspec_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_progspec_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA2);
- if (ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_BLOCKDATA_STMT);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_record_ -- Check ordering on RECORD statement
-
- if (ffestc_order_record_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_record_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_selectcase_ -- Check ordering on <selectcase> statement
-
- if (ffestc_order_selectcase_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_selectcase_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSELECT0:
- case FFESTV_stateSELECT1:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_sfunc_ -- Check ordering on statement-function definition
-
- if (ffestc_order_sfunc_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_sfunc_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_spec_ -- Check ordering on <spec> statement
-
- if (ffestc_order_spec_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_spec_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_structure_ -- Check ordering on <structure> statement
-
- if (ffestc_order_structure_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_structure_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSTRUCTURE:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_subroutine_ -- Check ordering on <subroutine> statement
-
- if (ffestc_order_subroutine_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_subroutine_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateSUBROUTINE5:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_type_ -- Check ordering on <type> statement
-
- if (ffestc_order_type_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_type_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateTYPE:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_typedecl_ -- Check ordering on <typedecl> statement
-
- if (ffestc_order_typedecl_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_typedecl_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_union_ -- Check ordering on <union> statement
-
- if (ffestc_order_union_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_union_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateUNION:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_unit_ -- Check ordering on <unit> statement
-
- if (ffestc_order_unit_() != FFESTC_orderOK_)
- return; */
-
-static ffestcOrder_
-ffestc_order_unit_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-/* ffestc_order_use_ -- Check ordering on USE statement
-
- if (ffestc_order_use_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_use_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateSUBROUTINE0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateFUNCTION0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateMODULE0:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE1);
- ffestc_shriek_begin_uses_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateUSE:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_vxtstructure_ -- Check ordering on STRUCTURE statement
-
- if (ffestc_order_vxtstructure_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_VXT
-static ffestcOrder_
-ffestc_order_vxtstructure_ ()
-{
- recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_statePROGRAM1:
- case FFESTV_statePROGRAM2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_statePROGRAM3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSUBROUTINE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateFUNCTION3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateMODULE3);
- return FFESTC_orderOK_;
-
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- ffestw_update (NULL);
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateBLOCKDATA3);
- return FFESTC_orderOK_;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- return FFESTC_orderOK_;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
-#if FFESTR_F90
- ffestc_shriek_where_ (FALSE);
-#endif
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* ffestc_order_where_ -- Check ordering on <where> statement
-
- if (ffestc_order_where_() != FFESTC_orderOK_)
- return; */
-
-#if FFESTR_F90
-static ffestcOrder_
-ffestc_order_where_ ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateWHERETHEN:
- return FFESTC_orderOK_;
-
- case FFESTV_stateWHERE:
- ffestc_order_bad_ ();
- ffestc_shriek_where_ (FALSE);
- return FFESTC_orderBAD_;
-
- case FFESTV_stateIF:
- ffestc_order_bad_ ();
- ffestc_shriek_if_ (FALSE);
- return FFESTC_orderBAD_;
-
- default:
- ffestc_order_bad_ ();
- return FFESTC_orderBAD_;
- }
-}
-
-#endif
-/* Invoked for each token in dummy arg list of FUNCTION, SUBROUTINE, and
- ENTRY (prior to the first executable statement). */
-
-static void
-ffestc_promote_dummy_ (ffelexToken t)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffebld e;
- bool sfref_ok;
-
- assert (t != NULL);
-
- if (ffelex_token_type (t) == FFELEX_typeASTERISK)
- {
- ffebld_append_item (&ffestc_local_.dummy.list_bottom,
- ffebld_new_star ());
- return; /* Don't bother with alternate returns! */
- }
-
- s = ffesymbol_declare_local (t, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- sfref_ok = FALSE;
-
- if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (sa & FFESYMBOL_attrsDUMMY)
- {
- if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
- { /* Seen this one twice in this list! */
- na = FFESYMBOL_attrsetNONE;
- }
- else
- na = sa;
- sfref_ok = TRUE; /* Ok for sym to be ref'd in sfuncdef
- previously, since already declared as a
- dummy arg. */
- }
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsANY
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsDUMMY;
- else
- na = FFESYMBOL_attrsetNONE;
-
- if (!ffesymbol_is_specable (s)
- && (!sfref_ok
- || (ffesymbol_where (s) != FFEINFO_whereDUMMY)))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
- ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
- ffesymbol_signal_unreported (s);
- }
-}
-
-/* ffestc_promote_execdummy_ -- Declare token as dummy variable in exec context
-
- ffestc_promote_execdummy_(t);
-
- Invoked for each token in dummy arg list of ENTRY when the statement
- follows the first executable statement. */
-
-static void
-ffestc_promote_execdummy_ (ffelexToken t)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffesymbolState ss;
- ffesymbolState ns;
- ffeinfoKind kind;
- ffeinfoWhere where;
- ffebld e;
-
- assert (t != NULL);
-
- if (ffelex_token_type (t) == FFELEX_typeASTERISK)
- {
- ffebld_append_item (&ffestc_local_.dummy.list_bottom,
- ffebld_new_star ());
- return; /* Don't bother with alternate returns! */
- }
-
- s = ffesymbol_declare_local (t, FALSE);
- na = sa = ffesymbol_attrs (s);
- ss = ffesymbol_state (s);
- kind = ffesymbol_kind (s);
- where = ffesymbol_where (s);
-
- if (ffestc_entry_num_ == ffesymbol_maxentrynum (s))
- { /* Seen this one twice in this list! */
- na = FFESYMBOL_attrsetNONE;
- }
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- ns = FFESYMBOL_stateUNDERSTOOD; /* Assume we know it all know. */
-
- switch (kind)
- {
- case FFEINFO_kindENTITY:
- case FFEINFO_kindFUNCTION:
- case FFEINFO_kindSUBROUTINE:
- break; /* These are fine, as far as we know. */
-
- case FFEINFO_kindNONE:
- if (sa & FFESYMBOL_attrsDUMMY)
- ns = FFESYMBOL_stateUNCERTAIN; /* Learned nothing new. */
- else if (sa & FFESYMBOL_attrsANYLEN)
- {
- kind = FFEINFO_kindENTITY;
- where = FFEINFO_whereDUMMY;
- }
- else if (sa & FFESYMBOL_attrsACTUALARG)
- na = FFESYMBOL_attrsetNONE;
- else
- {
- na = sa | FFESYMBOL_attrsDUMMY;
- ns = FFESYMBOL_stateUNCERTAIN;
- }
- break;
-
- default:
- na = FFESYMBOL_attrsetNONE; /* Error. */
- break;
- }
-
- switch (where)
- {
- case FFEINFO_whereDUMMY:
- break; /* This is fine. */
-
- case FFEINFO_whereNONE:
- where = FFEINFO_whereDUMMY;
- break;
-
- default:
- na = FFESYMBOL_attrsetNONE; /* Error. */
- break;
- }
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, t);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, ns);
- ffesymbol_set_maxentrynum (s, ffestc_entry_num_);
- ffesymbol_set_numentries (s, ffesymbol_numentries (s) + 1);
- if ((ns == FFESYMBOL_stateUNDERSTOOD)
- && (kind != FFEINFO_kindSUBROUTINE)
- && !ffeimplic_establish_symbol (s))
- {
- ffesymbol_error (s, t);
- return;
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- ffesymbol_rank (s),
- kind,
- where,
- ffesymbol_size (s)));
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
- ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
-}
-
-/* ffestc_promote_sfdummy_ -- Declare token as stmt-func dummy variable
-
- ffestc_promote_sfdummy_(t);
-
- Invoked for each token in dummy arg list of statement function.
-
- 22-Oct-91 JCB 1.1
- Reject arg if CHARACTER*(*). */
-
-static void
-ffestc_promote_sfdummy_ (ffelexToken t)
-{
- ffesymbol s;
- ffesymbol sp; /* Parent symbol. */
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffebld e;
-
- assert (t != NULL);
-
- s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
- also sets sfa_dummy_parent to
- parent symbol. */
- if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
- {
- ffesymbol_error (s, t); /* Dummy already in list. */
- return;
- }
-
- sp = ffesymbol_sfdummyparent (s); /* Now flag dummy's parent as used
- for dummy. */
- sa = ffesymbol_attrs (sp);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (sp)
- && ((ffesymbol_kind (sp) != FFEINFO_kindENTITY)
- || ((ffesymbol_where (sp) != FFEINFO_whereLOCAL)
- && (ffesymbol_where (sp) != FFEINFO_whereCOMMON)
- && (ffesymbol_where (sp) != FFEINFO_whereDUMMY)
- && (ffesymbol_where (sp) != FFEINFO_whereNONE))))
- na = FFESYMBOL_attrsetNONE; /* Can't be PARAMETER etc., must be a var. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsRESULT
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsSFARG;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- {
- ffesymbol_error (sp, t);
- ffesymbol_set_info (s, ffeinfo_new_any ());
- }
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
- ffesymbol_set_attrs (sp, na);
- if (!ffeimplic_establish_symbol (sp)
- || ((ffesymbol_basictype (sp) == FFEINFO_basictypeCHARACTER)
- && (ffesymbol_size (sp) == FFETARGET_charactersizeNONE)))
- ffesymbol_error (sp, t);
- else
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (sp),
- ffesymbol_kindtype (sp),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereDUMMY,
- ffesymbol_size (sp)));
-
- ffesymbol_signal_unreported (sp);
- }
-
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_maxentrynum (s, ffestc_sfdummy_argno_++);
- ffesymbol_signal_unreported (s);
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e, ffeinfo_use (ffesymbol_info (s)));
- ffebld_append_item (&ffestc_local_.dummy.list_bottom, e);
-}
-
-/* ffestc_shriek_begin_program_ -- Implicit PROGRAM statement
-
- ffestc_shriek_begin_program_();
-
- Invoked only when a PROGRAM statement is NOT present at the beginning
- of a main program unit. */
-
-static void
-ffestc_shriek_begin_program_ ()
-{
- ffestw b;
- ffesymbol s;
-
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_statePROGRAM0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_end_program_);
- ffestw_set_name (b, NULL);
-
- s = ffesymbol_declare_programunit (NULL,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
-
- /* Special case: this is one symbol that won't go through
- ffestu_exec_transition_ when the first statement in a main program is
- executable, because the transition happens in ffest before ffestc is
- reached and triggers the implicit generation of a main program. So we
- do the exec transition for the implicit main program right here, just
- for cleanliness' sake (at the very least). */
-
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindPROGRAM,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
-
- ffesymbol_signal_unreported (s);
-
- ffestd_R1102 (s, NULL);
-}
-
-/* ffestc_shriek_begin_uses_ -- Start a bunch of USE statements
-
- ffestc_shriek_begin_uses_();
-
- Invoked before handling the first USE statement in a block of one or
- more USE statements. _end_uses_(bool ok) is invoked before handling
- the first statement after the block (there are no BEGIN USE and END USE
- statements, but the semantics of USE statements effectively requires
- handling them as a single block rather than one statement at a time). */
-
-#if FFESTR_F90
-static void
-ffestc_shriek_begin_uses_ ()
-{
- ffestw b;
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateUSE);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_end_uses_);
-
- ffestd_begin_uses ();
-}
-
-#endif
-/* ffestc_shriek_blockdata_ -- End a BLOCK DATA
-
- ffestc_shriek_blockdata_(TRUE); */
-
-static void
-ffestc_shriek_blockdata_ (bool ok)
-{
- if (!ffesta_seen_first_exec)
- {
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
-
- ffestd_R1112 (ok);
-
- ffestd_exec_end ();
-
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
-
- ffe_terminate_2 ();
- ffe_init_2 ();
-}
-
-/* ffestc_shriek_do_ -- End of statement following DO-term-stmt etc
-
- ffestc_shriek_do_(TRUE);
-
- Also invoked by _labeldef_branch_end_ (or, in cases
- of errors, other _labeldef_ functions) when the label definition is
- for a DO-target (LOOPEND) label, once per matching/outstanding DO
- block on the stack. These cases invoke this function with ok==TRUE, so
- only forced stack popping (via ffestc_eof()) invokes it with ok==FALSE. */
-
-static void
-ffestc_shriek_do_ (bool ok)
-{
- ffelab l;
-
- if (((l = ffestw_label (ffestw_stack_top ())) != NULL)
- && (ffewhere_line_is_unknown (ffelab_definition_line (l))))
- { /* DO target is label that is still
- undefined. */
- assert ((ffelab_type (l) == FFELAB_typeLOOPEND)
- || (ffelab_type (l) == FFELAB_typeANY));
- if (ffelab_type (l) != FFELAB_typeANY)
- {
- ffelab_set_definition_line (l,
- ffewhere_line_use (ffelab_doref_line (l)));
- ffelab_set_definition_column (l,
- ffewhere_column_use (ffelab_doref_column (l)));
- ffestv_num_label_defines_++;
- }
- ffestd_labeldef_branch (l);
- }
-
- ffestd_do (ok);
-
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- if (ffestw_do_iter_var_t (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_do_iter_var_t (ffestw_stack_top ()));
- if (ffestw_do_iter_var (ffestw_stack_top ()) != NULL)
- ffesymbol_set_is_doiter (ffestw_do_iter_var (ffestw_stack_top ()), FALSE);
- ffestw_kill (ffestw_pop ());
-}
-
-/* ffestc_shriek_end_program_ -- End a PROGRAM
-
- ffestc_shriek_end_program_(); */
-
-static void
-ffestc_shriek_end_program_ (bool ok)
-{
- if (!ffesta_seen_first_exec)
- {
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
-
- ffestd_R1103 (ok);
-
- ffestd_exec_end ();
-
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
-
- ffe_terminate_2 ();
- ffe_init_2 ();
-}
-
-/* ffestc_shriek_end_uses_ -- End a bunch of USE statements
-
- ffestc_shriek_end_uses_(TRUE);
-
- ok==TRUE means simply not popping due to ffestc_eof()
- being called, because there is no formal END USES statement in Fortran. */
-
-#if FFESTR_F90
-static void
-ffestc_shriek_end_uses_ (bool ok)
-{
- ffestd_end_uses (ok);
-
- ffestw_kill (ffestw_pop ());
-}
-
-#endif
-/* ffestc_shriek_function_ -- End a FUNCTION
-
- ffestc_shriek_function_(TRUE); */
-
-static void
-ffestc_shriek_function_ (bool ok)
-{
- if (!ffesta_seen_first_exec)
- {
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
-
- ffestd_R1221 (ok);
-
- ffestd_exec_end ();
-
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
- ffesta_is_entry_valid = FALSE;
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffe_terminate_2 ();
- ffe_init_2 ();
- break;
-
- default:
- ffe_terminate_3 ();
- ffe_init_3 ();
- break;
-
- case FFESTV_stateINTERFACE0:
- ffe_terminate_4 ();
- ffe_init_4 ();
- break;
- }
-}
-
-/* ffestc_shriek_if_ -- End of statement following logical IF
-
- ffestc_shriek_if_(TRUE);
-
- Applies ONLY to logical IF, not to IF-THEN. For example, does not
- ffelex_token_kill the construct name for an IF-THEN block (the name
- field is invalid for logical IF). ok==TRUE iff statement following
- logical IF (substatement) is valid; else, statement is invalid or
- stack forcibly popped due to ffestc_eof(). */
-
-static void
-ffestc_shriek_if_ (bool ok)
-{
- ffestd_end_R807 (ok);
-
- ffestw_kill (ffestw_pop ());
- ffestc_shriek_after1_ = NULL;
-
- ffestc_try_shriek_do_ ();
-}
-
-/* ffestc_shriek_ifthen_ -- End an IF-THEN
-
- ffestc_shriek_ifthen_(TRUE); */
-
-static void
-ffestc_shriek_ifthen_ (bool ok)
-{
- ffestd_R806 (ok);
-
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-/* ffestc_shriek_interface_ -- End an INTERFACE
-
- ffestc_shriek_interface_(TRUE); */
-
-#if FFESTR_F90
-static void
-ffestc_shriek_interface_ (bool ok)
-{
- ffestd_R1203 (ok);
-
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-#endif
-/* ffestc_shriek_map_ -- End a MAP
-
- ffestc_shriek_map_(TRUE); */
-
-#if FFESTR_VXT
-static void
-ffestc_shriek_map_ (bool ok)
-{
- ffestd_V013 (ok);
-
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-#endif
-/* ffestc_shriek_module_ -- End a MODULE
-
- ffestc_shriek_module_(TRUE); */
-
-#if FFESTR_F90
-static void
-ffestc_shriek_module_ (bool ok)
-{
- if (!ffesta_seen_first_exec)
- {
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
-
- ffestd_R1106 (ok);
-
- ffestd_exec_end ();
-
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
-
- ffe_terminate_2 ();
- ffe_init_2 ();
-}
-
-#endif
-/* ffestc_shriek_select_ -- End a SELECT
-
- ffestc_shriek_select_(TRUE); */
-
-static void
-ffestc_shriek_select_ (bool ok)
-{
- ffestwSelect s;
- ffestwCase c;
-
- ffestd_R811 (ok);
-
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- s = ffestw_select (ffestw_stack_top ());
- ffelex_token_kill (s->t);
- for (c = s->first_rel; c != (ffestwCase) &s->first_rel; c = c->next_rel)
- ffelex_token_kill (c->t);
- malloc_pool_kill (s->pool);
-
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-/* ffestc_shriek_structure_ -- End a STRUCTURE
-
- ffestc_shriek_structure_(TRUE); */
-
-#if FFESTR_VXT
-static void
-ffestc_shriek_structure_ (bool ok)
-{
- ffestd_V004 (ok);
-
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-#endif
-/* ffestc_shriek_subroutine_ -- End a SUBROUTINE
-
- ffestc_shriek_subroutine_(TRUE); */
-
-static void
-ffestc_shriek_subroutine_ (bool ok)
-{
- if (!ffesta_seen_first_exec)
- {
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
- }
-
- ffestd_R1225 (ok);
-
- ffestd_exec_end ();
-
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
- ffesta_is_entry_valid = FALSE;
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffe_terminate_2 ();
- ffe_init_2 ();
- break;
-
- default:
- ffe_terminate_3 ();
- ffe_init_3 ();
- break;
-
- case FFESTV_stateINTERFACE0:
- ffe_terminate_4 ();
- ffe_init_4 ();
- break;
- }
-}
-
-/* ffestc_shriek_type_ -- End a TYPE
-
- ffestc_shriek_type_(TRUE); */
-
-#if FFESTR_F90
-static void
-ffestc_shriek_type_ (bool ok)
-{
- ffestd_R425 (ok);
-
- ffe_terminate_4 ();
-
- ffelex_token_kill (ffestw_name (ffestw_stack_top ()));
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-#endif
-/* ffestc_shriek_union_ -- End a UNION
-
- ffestc_shriek_union_(TRUE); */
-
-#if FFESTR_VXT
-static void
-ffestc_shriek_union_ (bool ok)
-{
- ffestd_V010 (ok);
-
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-#endif
-/* ffestc_shriek_where_ -- Implicit END WHERE statement
-
- ffestc_shriek_where_(TRUE);
-
- Implement the end of the current WHERE "block". ok==TRUE iff statement
- following WHERE (substatement) is valid; else, statement is invalid
- or stack forcibly popped due to ffestc_eof(). */
-
-#if FFESTR_F90
-static void
-ffestc_shriek_where_ (bool ok)
-{
- ffestd_R745 (ok);
-
- ffestw_kill (ffestw_pop ());
- ffestc_shriek_after1_ = NULL;
- if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateIF)
- ffestc_shriek_if_ (TRUE); /* "IF (x) WHERE (y) stmt" is only valid
- case. */
-
- ffestc_try_shriek_do_ ();
-}
-
-#endif
-/* ffestc_shriek_wherethen_ -- End a WHERE(-THEN)
-
- ffestc_shriek_wherethen_(TRUE); */
-
-#if FFESTR_F90
-static void
-ffestc_shriek_wherethen_ (bool ok)
-{
- ffestd_end_R740 (ok);
-
- ffestw_kill (ffestw_pop ());
-
- ffestc_try_shriek_do_ ();
-}
-
-#endif
-/* ffestc_subr_binsrch_ -- Binary search of char const in list of strings
-
- i = ffestc_subr_binsrch_(search_list,search_list_size,&spec,"etc");
-
- search_list contains search_list_size char *'s, spec is checked to see
- if it is a char constant and, if so, is binary-searched against the list.
- 0 is returned if not found, else the "classic" index (beginning with 1)
- is returned. Before returning 0 where the search was performed but
- fruitless, if "etc" is a non-NULL char *, an error message is displayed
- using "etc" as the pick-one-of-these string. */
-
-static int
-ffestc_subr_binsrch_ (const char *const *list, int size, ffestpFile *spec,
- const char *whine)
-{
- int lowest_tested;
- int highest_tested;
- int halfway;
- int offset;
- int c;
- const char *str;
- int len;
-
- if (size == 0)
- return 0; /* Nobody should pass size == 0, but for
- elegance.... */
-
- lowest_tested = -1;
- highest_tested = size;
- halfway = size >> 1;
-
- list += halfway;
-
- c = ffestc_subr_speccmp_ (*list, spec, &str, &len);
- if (c == 2)
- return 0;
- c = -c; /* Sigh. */
-
-next: /* :::::::::::::::::::: */
- switch (c)
- {
- case -1:
- offset = (halfway - lowest_tested) >> 1;
- if (offset == 0)
- goto nope; /* :::::::::::::::::::: */
- highest_tested = halfway;
- list -= offset;
- halfway -= offset;
- c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
- goto next; /* :::::::::::::::::::: */
-
- case 0:
- return halfway + 1;
-
- case 1:
- offset = (highest_tested - halfway) >> 1;
- if (offset == 0)
- goto nope; /* :::::::::::::::::::: */
- lowest_tested = halfway;
- list += offset;
- halfway += offset;
- c = ffesrc_strcmp_1ns2i (ffe_case_match (), str, len, *list);
- goto next; /* :::::::::::::::::::: */
-
- default:
- assert ("unexpected return from ffesrc_strcmp_1ns2i" == NULL);
- break;
- }
-
-nope: /* :::::::::::::::::::: */
- ffebad_start (FFEBAD_SPEC_VALUE);
- ffebad_here (0, ffelex_token_where_line (spec->value),
- ffelex_token_where_column (spec->value));
- ffebad_string (whine);
- ffebad_finish ();
- return 0;
-}
-
-/* ffestc_subr_format_ -- Return summary of format specifier
-
- ffestc_subr_format_(&specifier); */
-
-static ffestvFormat
-ffestc_subr_format_ (ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return FFESTV_formatNONE;
- assert (spec->value_present);
- if (spec->value_is_label)
- return FFESTV_formatLABEL; /* Ok if not a label. */
-
- assert (spec->value != NULL);
- if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
- return FFESTV_formatASTERISK;
-
- if (ffeinfo_kind (ffebld_info (spec->u.expr)) == FFEINFO_kindNAMELIST)
- return FFESTV_formatNAMELIST;
-
- if (ffeinfo_rank (ffebld_info (spec->u.expr)) != 0)
- return FFESTV_formatCHAREXPR; /* F77 C5. */
-
- switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
- {
- case FFEINFO_basictypeINTEGER:
- return FFESTV_formatINTEXPR;
-
- case FFEINFO_basictypeCHARACTER:
- return FFESTV_formatCHAREXPR;
-
- case FFEINFO_basictypeANY:
- return FFESTV_formatASTERISK;
-
- default:
- assert ("bad basictype" == NULL);
- return FFESTV_formatINTEXPR;
- }
-}
-
-/* ffestc_subr_is_branch_ -- Handle specifier as branch target label
-
- ffestc_subr_is_branch_(&specifier); */
-
-static bool
-ffestc_subr_is_branch_ (ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return TRUE;
- assert (spec->value_present);
- assert (spec->value_is_label);
- spec->value_is_label++; /* For checking purposes only; 1=>2. */
- return ffestc_labelref_is_branch_ (spec->value, &spec->u.label);
-}
-
-/* ffestc_subr_is_format_ -- Handle specifier as format target label
-
- ffestc_subr_is_format_(&specifier); */
-
-static bool
-ffestc_subr_is_format_ (ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return TRUE;
- assert (spec->value_present);
- if (!spec->value_is_label)
- return TRUE; /* Ok if not a label. */
-
- spec->value_is_label++; /* For checking purposes only; 1=>2. */
- return ffestc_labelref_is_format_ (spec->value, &spec->u.label);
-}
-
-/* ffestc_subr_is_present_ -- Ensure specifier is present, else error
-
- ffestc_subr_is_present_("SPECIFIER",&specifier); */
-
-static bool
-ffestc_subr_is_present_ (const char *name, ffestpFile *spec)
-{
- if (spec->kw_or_val_present)
- {
- assert (spec->value_present);
- return TRUE;
- }
-
- ffebad_start (FFEBAD_MISSING_SPECIFIER);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_string (name);
- ffebad_finish ();
- return FALSE;
-}
-
-/* ffestc_subr_speccmp_ -- Compare string to constant expression, if present
-
- if (ffestc_subr_speccmp_("Constant",&specifier,NULL,NULL) == 0)
- // specifier value is present and is a char constant "CONSTANT"
-
- Like strcmp, except the return values are defined as: -1 returned in place
- of strcmp's generic negative value, 1 in place of it's generic positive
- value, and 2 when there is no character constant string to compare. Also,
- a case-insensitive comparison is performed, where string is assumed to
- already be in InitialCaps form.
-
- If a non-NULL pointer is provided as the char **target, then *target is
- written with NULL if 2 is returned, a pointer to the constant string
- value of the specifier otherwise. Similarly, length is written with
- 0 if 2 is returned, the length of the constant string value otherwise. */
-
-static int
-ffestc_subr_speccmp_ (const char *string, ffestpFile *spec, const char **target,
- int *length)
-{
- ffebldConstant c;
- int i;
-
- if (!spec->kw_or_val_present || !spec->value_present
- || (spec->u.expr == NULL)
- || (ffebld_op (spec->u.expr) != FFEBLD_opCONTER))
- {
- if (target != NULL)
- *target = NULL;
- if (length != NULL)
- *length = 0;
- return 2;
- }
-
- if (ffebld_constant_type (c = ffebld_conter (spec->u.expr))
- != FFEBLD_constCHARACTERDEFAULT)
- {
- if (target != NULL)
- *target = NULL;
- if (length != NULL)
- *length = 0;
- return 2;
- }
-
- if (target != NULL)
- *target = ffebld_constant_characterdefault (c).text;
- if (length != NULL)
- *length = ffebld_constant_characterdefault (c).length;
-
- i = ffesrc_strcmp_1ns2i (ffe_case_match (),
- ffebld_constant_characterdefault (c).text,
- ffebld_constant_characterdefault (c).length,
- string);
- if (i == 0)
- return 0;
- if (i > 0)
- return -1; /* Yes indeed, we reverse the strings to
- _strcmpin_. */
- return 1;
-}
-
-/* ffestc_subr_unit_ -- Return summary of unit specifier
-
- ffestc_subr_unit_(&specifier); */
-
-static ffestvUnit
-ffestc_subr_unit_ (ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return FFESTV_unitNONE;
- assert (spec->value_present);
- assert (spec->value != NULL);
-
- if (ffebld_op (spec->u.expr) == FFEBLD_opSTAR)
- return FFESTV_unitASTERISK;
-
- switch (ffeinfo_basictype (ffebld_info (spec->u.expr)))
- {
- case FFEINFO_basictypeINTEGER:
- return FFESTV_unitINTEXPR;
-
- case FFEINFO_basictypeCHARACTER:
- return FFESTV_unitCHAREXPR;
-
- case FFEINFO_basictypeANY:
- return FFESTV_unitASTERISK;
-
- default:
- assert ("bad basictype" == NULL);
- return FFESTV_unitINTEXPR;
- }
-}
-
-/* Call this function whenever it's possible that one or more top
- stack items are label-targeting DO blocks that have had their
- labels defined, but at a time when they weren't at the top of the
- stack. This prevents uninformative diagnostics for programs
- like "DO 10", "IF (...) THEN", "10 ELSE", "END IF", "END". */
-
-static void
-ffestc_try_shriek_do_ ()
-{
- ffelab lab;
- ffelabType ty;
-
- while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO)
- && ((lab = (ffestw_label (ffestw_stack_top ()))) != NULL)
- && (((ty = (ffelab_type (lab)))
- == FFELAB_typeANY)
- || (ty == FFELAB_typeUSELESS)
- || (ty == FFELAB_typeFORMAT)
- || (ty == FFELAB_typeNOTLOOP)
- || (ty == FFELAB_typeENDIF)))
- ffestc_shriek_do_ (FALSE);
-}
-
-/* ffestc_decl_start -- R426 or R501
-
- ffestc_decl_start(...);
-
- Verify that R426 component-def-stmt or R501 type-declaration-stmt are
- valid here, figure out which one, and implement. */
-
-void
-ffestc_decl_start (ffestpType type, ffelexToken typet, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent)
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- case FFESTV_statePROGRAM0:
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateMODULE0:
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_statePROGRAM1:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateMODULE1:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateMODULE2:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateMODULE3:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateUSE:
- ffestc_local_.decl.is_R426 = 2;
- break;
-
- case FFESTV_stateTYPE:
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestc_local_.decl.is_R426 = 1;
- break;
-
- default:
- ffestc_order_bad_ ();
- ffestc_labeldef_useless_ ();
- ffestc_local_.decl.is_R426 = 0;
- return;
- }
-
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_start (type, typet, kind, kindt, len, lent);
- break;
-#endif
-
- case 2:
- ffestc_R501_start (type, typet, kind, kindt, len, lent);
- break;
-
- default:
- ffestc_labeldef_useless_ ();
- break;
- }
-}
-
-/* ffestc_decl_attrib -- R426 or R501 type attribute
-
- ffestc_decl_attrib(...);
-
- Verify that R426 component-def-stmt or R501 type-declaration-stmt attribute
- is valid here and implement. */
-
-void
-ffestc_decl_attrib (ffestpAttrib attrib UNUSED,
- ffelexToken attribt UNUSED,
- ffestrOther intent_kw UNUSED,
- ffesttDimList dims UNUSED)
-{
-#if FFESTR_F90
- switch (ffestc_local_.decl.is_R426)
- {
- case 1:
- ffestc_R426_attrib (attrib, attribt, intent_kw, dims);
- break;
-
- case 2:
- ffestc_R501_attrib (attrib, attribt, intent_kw, dims);
- break;
-
- default:
- break;
- }
-#else
- ffebad_start (FFEBAD_F90);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- return;
-#endif
-}
-
-/* ffestc_decl_item -- R426 or R501
-
- ffestc_decl_item(...);
-
- Establish type for a particular object. */
-
-void
-ffestc_decl_item (ffelexToken name, ffebld kind, ffelexToken kindt,
- ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
- ffelexToken initt, bool clist)
-{
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_item (name, kind, kindt, dims, len, lent, init, initt,
- clist);
- break;
-#endif
-
- case 2:
- ffestc_R501_item (name, kind, kindt, dims, len, lent, init, initt,
- clist);
- break;
-
- default:
- break;
- }
-}
-
-/* ffestc_decl_itemstartvals -- R426 or R501 start list of values
-
- ffestc_decl_itemstartvals();
-
- Gonna specify values for the object now. */
-
-void
-ffestc_decl_itemstartvals ()
-{
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_itemstartvals ();
- break;
-#endif
-
- case 2:
- ffestc_R501_itemstartvals ();
- break;
-
- default:
- break;
- }
-}
-
-/* ffestc_decl_itemvalue -- R426 or R501 source value
-
- ffestc_decl_itemvalue(repeat,repeat_token,value,value_token);
-
- Make sure repeat and value are valid for the object being initialized. */
-
-void
-ffestc_decl_itemvalue (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
-{
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_itemvalue (repeat, repeat_token, value, value_token);
- break;
-#endif
-
- case 2:
- ffestc_R501_itemvalue (repeat, repeat_token, value, value_token);
- break;
-
- default:
- break;
- }
-}
-
-/* ffestc_decl_itemendvals -- R426 or R501 end list of values
-
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_decl_itemendvals(t);
-
- No more values, might specify more objects now. */
-
-void
-ffestc_decl_itemendvals (ffelexToken t)
-{
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_itemendvals (t);
- break;
-#endif
-
- case 2:
- ffestc_R501_itemendvals (t);
- break;
-
- default:
- break;
- }
-}
-
-/* ffestc_decl_finish -- R426 or R501
-
- ffestc_decl_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_decl_finish ()
-{
- switch (ffestc_local_.decl.is_R426)
- {
-#if FFESTR_F90
- case 1:
- ffestc_R426_finish ();
- break;
-#endif
-
- case 2:
- ffestc_R501_finish ();
- break;
-
- default:
- break;
- }
-}
-
-/* ffestc_elsewhere -- Generic ELSE WHERE statement
-
- ffestc_end();
-
- Decide whether ELSEWHERE or ELSE w/if-construct-name=="WHERE" is meant. */
-
-void
-ffestc_elsewhere (ffelexToken where)
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateIFTHEN:
- ffestc_R805 (where);
- break;
-
- default:
-#if FFESTR_F90
- ffestc_R744 ();
-#endif
- break;
- }
-}
-
-/* ffestc_end -- Generic END statement
-
- ffestc_end();
-
- Make sure a generic END is valid in the current context, and implement
- it. */
-
-void
-ffestc_end ()
-{
- ffestw b;
-
- b = ffestw_stack_top ();
-
-recurse:
-
- switch (ffestw_state (b))
- {
- case FFESTV_stateBLOCKDATA0:
- case FFESTV_stateBLOCKDATA1:
- case FFESTV_stateBLOCKDATA2:
- case FFESTV_stateBLOCKDATA3:
- case FFESTV_stateBLOCKDATA4:
- case FFESTV_stateBLOCKDATA5:
- ffestc_R1112 (NULL);
- break;
-
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateFUNCTION5:
- if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
- && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
- {
- ffebad_start (FFEBAD_END_WO);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
- ffebad_string ("FUNCTION");
- ffebad_finish ();
- }
- ffestc_R1221 (NULL);
- break;
-
- case FFESTV_stateMODULE0:
- case FFESTV_stateMODULE1:
- case FFESTV_stateMODULE2:
- case FFESTV_stateMODULE3:
- case FFESTV_stateMODULE4:
- case FFESTV_stateMODULE5:
-#if FFESTR_F90
- ffestc_R1106 (NULL);
-#endif
- break;
-
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateSUBROUTINE5:
- if ((ffestw_state (ffestw_previous (b)) != FFESTV_stateNIL)
- && (ffestw_state (ffestw_previous (b)) != FFESTV_stateINTERFACE0))
- {
- ffebad_start (FFEBAD_END_WO);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_previous (b)), ffestw_col (ffestw_previous (b)));
- ffebad_string ("SUBROUTINE");
- ffebad_finish ();
- }
- ffestc_R1225 (NULL);
- break;
-
- case FFESTV_stateUSE:
- b = ffestw_previous (ffestw_stack_top ());
- goto recurse; /* :::::::::::::::::::: */
-
- default:
- ffestc_R1103 (NULL);
- break;
- }
-}
-
-/* ffestc_eof -- Generic EOF
-
- ffestc_eof();
-
- Make sure we're at state NIL, or issue an error message and use each
- block's shriek function to clean up to state NIL. */
-
-void
-ffestc_eof ()
-{
- if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL)
- {
- ffebad_start (FFEBAD_EOF_BEFORE_BLOCK_END);
- ffebad_here (0, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- do
- (*ffestw_shriek (ffestw_stack_top ()))(FALSE);
- while (ffestw_state (ffestw_stack_top ()) != FFESTV_stateNIL);
- }
-}
-
-/* ffestc_exec_transition -- Check if ok and move stmt state to executable
-
- if (ffestc_exec_transition())
- // Transition successful (kind of like a CONTINUE stmt was seen).
-
- If the current statement state is a non-nested specification state in
- which, say, a CONTINUE statement would be valid, then enter the state
- we'd be in after seeing CONTINUE (without, of course, generating any
- CONTINUE code), call ffestd_exec_begin, and return TRUE. Otherwise
- return FALSE.
-
- This function cannot be invoked once the first executable statement
- is seen. This function may choose to always return TRUE by shrieking
- away any interceding state stack entries to reach the base level of
- specification state, but right now it doesn't, and it is (or should
- be) purely an issue of how one wishes errors to be handled (for example,
- an unrecognized statement in the middle of a STRUCTURE construct: after
- the error message, should subsequent statements still be interpreted as
- being within the construct, or should the construct be terminated upon
- seeing the unrecognized statement? we do the former at the moment). */
-
-bool
-ffestc_exec_transition ()
-{
- bool update;
-
-recurse:
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- ffestc_shriek_begin_program_ ();
- goto recurse; /* :::::::::::::::::::: */
-
- case FFESTV_statePROGRAM0:
- case FFESTV_stateSUBROUTINE0:
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateBLOCKDATA0:
- ffestw_state (ffestw_stack_top ()) += 4; /* To state UNIT4. */
- update = TRUE;
- break;
-
- case FFESTV_statePROGRAM1:
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateBLOCKDATA1:
- ffestw_state (ffestw_stack_top ()) += 3; /* To state UNIT4. */
- update = TRUE;
- break;
-
- case FFESTV_statePROGRAM2:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateBLOCKDATA2:
- ffestw_state (ffestw_stack_top ()) += 2; /* To state UNIT4. */
- update = TRUE;
- break;
-
- case FFESTV_statePROGRAM3:
- case FFESTV_stateSUBROUTINE3:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateBLOCKDATA3:
- ffestw_state (ffestw_stack_top ()) += 1; /* To state UNIT4. */
- update = TRUE;
- break;
-
- case FFESTV_stateUSE:
-#if FFESTR_F90
- ffestc_shriek_end_uses_ (TRUE);
-#endif
- goto recurse; /* :::::::::::::::::::: */
-
- default:
- return FALSE;
- }
-
- if (update)
- ffestw_update (NULL); /* Update state line/col info. */
-
- ffesta_seen_first_exec = TRUE;
- ffestd_exec_begin ();
-
- return TRUE;
-}
-
-/* ffestc_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var
-
- ffesymbol s;
- // call ffebad_start first, of course.
- ffestc_ffebad_here_doiter(0,s);
- // call ffebad_finish afterwards, naturally.
-
- Searches the stack of blocks backwards for a DO loop that has s
- as its iteration variable, then calls ffebad_here with pointers to
- that particular reference to the variable. Crashes if the DO loop
- can't be found. */
-
-void
-ffestc_ffebad_here_doiter (ffebadIndex i, ffesymbol s)
-{
- ffestw block;
-
- for (block = ffestw_top_do (ffestw_stack_top ());
- (block != NULL) && (ffestw_blocknum (block) != 0);
- block = ffestw_top_do (ffestw_previous (block)))
- {
- if (ffestw_do_iter_var (block) == s)
- {
- ffebad_here (i, ffelex_token_where_line (ffestw_do_iter_var_t (block)),
- ffelex_token_where_column (ffestw_do_iter_var_t (block)));
- return;
- }
- }
- assert ("no do block found" == NULL);
-}
-
-/* ffestc_is_decl_not_R1219 -- Context information for FFESTB
-
- if (ffestc_is_decl_not_R1219()) ...
-
- When a statement with the form "type[RECURSIVE]FUNCTIONname(name-list)"
- is seen, call this function. It returns TRUE if the statement's context
- is such that it is a declaration of an object named
- "[RECURSIVE]FUNCTIONname" with an array-decl spec of "name-list", FALSE
- if the statement's context is such that it begins the definition of a
- function named "name" havin the dummy argument list "name-list" (this
- is the R1219 function-stmt case). */
-
-bool
-ffestc_is_decl_not_R1219 ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateNIL:
- case FFESTV_statePROGRAM5:
- case FFESTV_stateSUBROUTINE5:
- case FFESTV_stateFUNCTION5:
- case FFESTV_stateMODULE5:
- case FFESTV_stateINTERFACE0:
- return FALSE;
-
- default:
- return TRUE;
- }
-}
-
-/* ffestc_is_entry_in_subr -- Context information for FFESTB
-
- if (ffestc_is_entry_in_subr()) ...
-
- When a statement with the form "ENTRY name(name-list)"
- is seen, call this function. It returns TRUE if the statement's context
- is such that it may have "*", meaning alternate return, in place of
- names in the name list (i.e. if the ENTRY is in a subroutine context).
- It also returns TRUE if the ENTRY is not in a function context (invalid
- but prevents extra complaints about "*", if present). It returns FALSE
- if the ENTRY is in a function context. */
-
-bool
-ffestc_is_entry_in_subr ()
-{
- ffestvState s;
-
- s = ffestw_state (ffestw_stack_top ());
-
-recurse:
-
- switch (s)
- {
- case FFESTV_stateFUNCTION0:
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- case FFESTV_stateFUNCTION4:
- return FALSE;
-
- case FFESTV_stateUSE:
- s = ffestw_state (ffestw_previous (ffestw_stack_top ()));
- goto recurse; /* :::::::::::::::::::: */
-
- default:
- return TRUE;
- }
-}
-
-/* ffestc_is_let_not_V027 -- Context information for FFESTB
-
- if (ffestc_is_let_not_V027()) ...
-
- When a statement with the form "PARAMETERname=expr"
- is seen, call this function. It returns TRUE if the statement's context
- is such that it is an assignment to an object named "PARAMETERname", FALSE
- if the statement's context is such that it is a V-extension PARAMETER
- statement that is like a PARAMETER(name=expr) statement except that the
- type of name is determined by the type of expr, not the implicit or
- explicit typing of name. */
-
-bool
-ffestc_is_let_not_V027 ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- case FFESTV_stateWHERETHEN:
- case FFESTV_stateIFTHEN:
- case FFESTV_stateDO:
- case FFESTV_stateSELECT0:
- case FFESTV_stateSELECT1:
- case FFESTV_stateWHERE:
- case FFESTV_stateIF:
- return TRUE;
-
- default:
- return FALSE;
- }
-}
-
-/* ffestc_module -- MODULE or MODULE PROCEDURE statement
-
- ffestc_module(module_name_token,procedure_name_token);
-
- Decide which is intended, and implement it by calling _R1105_ or
- _R1205_. */
-
-#if FFESTR_F90
-void
-ffestc_module (ffelexToken module, ffelexToken procedure)
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateINTERFACE0:
- case FFESTV_stateINTERFACE1:
- ffestc_R1205_start ();
- ffestc_R1205_item (procedure);
- ffestc_R1205_finish ();
- break;
-
- default:
- ffestc_R1105 (module);
- break;
- }
-}
-
-#endif
-/* ffestc_private -- Generic PRIVATE statement
-
- ffestc_end();
-
- This is either a PRIVATE within R422 derived-type statement or an
- R521 PRIVATE statement. Figure it out based on context and implement
- it, or produce an error. */
-
-#if FFESTR_F90
-void
-ffestc_private ()
-{
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateTYPE:
- ffestc_R423A ();
- break;
-
- default:
- ffestc_R521B ();
- break;
- }
-}
-
-#endif
-/* ffestc_terminate_4 -- Terminate ffestc after scoping unit
-
- ffestc_terminate_4();
-
- For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
- defs, and statement function defs. */
-
-void
-ffestc_terminate_4 ()
-{
- ffestc_entry_num_ = ffestc_saved_entry_num_;
-}
-
-/* ffestc_R423A -- PRIVATE statement (in R422 derived-type statement)
-
- ffestc_R423A(); */
-
-#if FFESTR_F90
-void
-ffestc_R423A ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_type_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return;
- }
-
- if (ffestw_state (ffestw_previous (ffestw_stack_top ())) != FFESTV_stateMODULE3)
- {
- ffebad_start (FFEBAD_DERIVTYP_ACCESS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- return;
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
- private-sequence-stmt. */
-
- ffestd_R423A ();
-}
-
-/* ffestc_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
-
- ffestc_R423B(); */
-
-void
-ffestc_R423B ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_type_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_DERIVTYP_ACCESS_FIRST);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return;
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen
- private-sequence-stmt. */
-
- ffestd_R423B ();
-}
-
-/* ffestc_R424 -- derived-TYPE-def statement
-
- ffestc_R424(access_token,access_kw,name_token);
-
- Handle a derived-type definition. */
-
-void
-ffestc_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
-{
- ffestw b;
-
- assert (name != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_derivedtype_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if ((access != NULL)
- && (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE3))
- {
- ffebad_start (FFEBAD_DERIVTYP_ACCESS);
- ffebad_here (0, ffelex_token_where_line (access),
- ffelex_token_where_column (access));
- ffebad_finish ();
- access = NULL;
- }
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateTYPE);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_type_);
- ffestw_set_name (b, ffelex_token_use (name));
- ffestw_set_substate (b, 0); /* Awaiting private-sequence-stmt and one
- component-def-stmt. */
-
- ffestd_R424 (access, access_kw, name);
-
- ffe_init_4 ();
-}
-
-/* ffestc_R425 -- END TYPE statement
-
- ffestc_R425(name_token);
-
- Make sure ffestc_kind_ identifies a TYPE definition. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the type definition. */
-
-void
-ffestc_R425 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_type_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 2)
- {
- ffebad_start (FFEBAD_DERIVTYP_NO_COMPONENTS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
- {
- ffebad_start (FFEBAD_TYPE_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
-
- ffestc_shriek_type_ (TRUE);
-}
-
-/* ffestc_R426_start -- component-declaration-stmt
-
- ffestc_R426_start(...);
-
- Verify that R426 component-declaration-stmt is
- valid here and implement. */
-
-void
-ffestc_R426_start (ffestpType type, ffelexToken typet, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent)
-{
- ffestc_check_start_ ();
- if (ffestc_order_component_ () != FFESTC_orderOK_)
- {
- ffestc_local_.decl.is_R426 = 0;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
- member. */
- break;
-
- case FFESTV_stateTYPE:
- ffestw_set_substate (ffestw_stack_top (), 2);
- break;
-
- default:
- assert ("Component parent state invalid" == NULL);
- break;
- }
-}
-
-/* ffestc_R426_attrib -- type attribute
-
- ffestc_R426_attrib(...);
-
- Verify that R426 component-declaration-stmt attribute
- is valid here and implement. */
-
-void
-ffestc_R426_attrib (ffestpAttrib attrib, ffelexToken attribt,
- ffestrOther intent_kw, ffesttDimList dims)
-{
- ffestc_check_attrib_ ();
-}
-
-/* ffestc_R426_item -- declared object
-
- ffestc_R426_item(...);
-
- Establish type for a particular object. */
-
-void
-ffestc_R426_item (ffelexToken name, ffebld kind, ffelexToken kindt,
- ffesttDimList dims, ffebld len, ffelexToken lent, ffebld init,
- ffelexToken initt, bool clist)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
- assert (kind == NULL); /* No way an expression should get here. */
-
- if ((dims != NULL) || (init != NULL) || clist)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-}
-
-/* ffestc_R426_itemstartvals -- Start list of values
-
- ffestc_R426_itemstartvals();
-
- Gonna specify values for the object now. */
-
-void
-ffestc_R426_itemstartvals ()
-{
- ffestc_check_item_startvals_ ();
-}
-
-/* ffestc_R426_itemvalue -- Source value
-
- ffestc_R426_itemvalue(repeat,repeat_token,value,value_token);
-
- Make sure repeat and value are valid for the object being initialized. */
-
-void
-ffestc_R426_itemvalue (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
-{
- ffestc_check_item_value_ ();
-}
-
-/* ffestc_R426_itemendvals -- End list of values
-
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_R426_itemendvals(t);
-
- No more values, might specify more objects now. */
-
-void
-ffestc_R426_itemendvals (ffelexToken t)
-{
- ffestc_check_item_endvals_ ();
-}
-
-/* ffestc_R426_finish -- Done
-
- ffestc_R426_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R426_finish ()
-{
- ffestc_check_finish_ ();
-}
-
-#endif
-/* ffestc_R501_start -- type-declaration-stmt
-
- ffestc_R501_start(...);
-
- Verify that R501 type-declaration-stmt is
- valid here and implement. */
-
-void
-ffestc_R501_start (ffestpType type, ffelexToken typet, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent)
-{
- ffestc_check_start_ ();
- if (ffestc_order_typedecl_ () != FFESTC_orderOK_)
- {
- ffestc_local_.decl.is_R426 = 0;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestc_establish_declstmt_ (type, typet, kind, kindt, len, lent);
-}
-
-/* ffestc_R501_attrib -- type attribute
-
- ffestc_R501_attrib(...);
-
- Verify that R501 type-declaration-stmt attribute
- is valid here and implement. */
-
-void
-ffestc_R501_attrib (ffestpAttrib attrib, ffelexToken attribt,
- ffestrOther intent_kw UNUSED,
- ffesttDimList dims UNUSED)
-{
- ffestc_check_attrib_ ();
-
- switch (attrib)
- {
-#if FFESTR_F90
- case FFESTP_attribALLOCATABLE:
- break;
-#endif
-
- case FFESTP_attribDIMENSION:
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- break;
-
- case FFESTP_attribEXTERNAL:
- break;
-
-#if FFESTR_F90
- case FFESTP_attribINTENT:
- break;
-#endif
-
- case FFESTP_attribINTRINSIC:
- break;
-
-#if FFESTR_F90
- case FFESTP_attribOPTIONAL:
- break;
-#endif
-
- case FFESTP_attribPARAMETER:
- break;
-
-#if FFESTR_F90
- case FFESTP_attribPOINTER:
- break;
-#endif
-
-#if FFESTR_F90
- case FFESTP_attribPRIVATE:
- break;
-
- case FFESTP_attribPUBLIC:
- break;
-#endif
-
- case FFESTP_attribSAVE:
- switch (ffestv_save_state_)
- {
- case FFESTV_savestateNONE:
- ffestv_save_state_ = FFESTV_savestateSPECIFIC;
- ffestv_save_line_
- = ffewhere_line_use (ffelex_token_where_line (attribt));
- ffestv_save_col_
- = ffewhere_column_use (ffelex_token_where_column (attribt));
- break;
-
- case FFESTV_savestateSPECIFIC:
- case FFESTV_savestateANY:
- break;
-
- case FFESTV_savestateALL:
- if (ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_CONFLICTING_SAVES);
- ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
- ffebad_here (1, ffelex_token_where_line (attribt),
- ffelex_token_where_column (attribt));
- ffebad_finish ();
- }
- ffestv_save_state_ = FFESTV_savestateANY;
- break;
-
- default:
- assert ("unexpected save state" == NULL);
- break;
- }
- break;
-
-#if FFESTR_F90
- case FFESTP_attribTARGET:
- break;
-#endif
-
- default:
- assert ("unexpected attribute" == NULL);
- break;
- }
-}
-
-/* ffestc_R501_item -- declared object
-
- ffestc_R501_item(...);
-
- Establish type for a particular object. */
-
-void
-ffestc_R501_item (ffelexToken name, ffebld kind, ffelexToken kindt,
- ffesttDimList dims, ffebld len, ffelexToken lent,
- ffebld init, ffelexToken initt, bool clist)
-{
- ffesymbol s;
- ffesymbol sfn; /* FUNCTION symbol. */
- ffebld array_size;
- ffebld extents;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffestpDimtype nd;
- bool is_init = (init != NULL) || clist;
- bool is_assumed;
- bool is_ugly_assumed;
- ffeinfoRank rank;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- assert (ffelex_token_type (name) == FFELEX_typeNAME); /* Not NAMES. */
- assert (kind == NULL); /* No way an expression should get here. */
-
- ffestc_establish_declinfo_ (kind, kindt, len, lent);
-
- is_assumed = (ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
- && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE);
-
- if ((dims != NULL) || is_init)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- s = ffesymbol_declare_local (name, TRUE);
- sa = ffesymbol_attrs (s);
-
- /* First figure out what kind of object this is based solely on the current
- object situation (type params, dimension list, and initialization). */
-
- na = FFESYMBOL_attrsTYPE;
-
- if (is_assumed)
- na |= FFESYMBOL_attrsANYLEN;
-
- is_ugly_assumed = (ffe_is_ugly_assumed ()
- && ((sa & FFESYMBOL_attrsDUMMY)
- || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
-
- nd = ffestt_dimlist_type (dims, is_ugly_assumed);
- switch (nd)
- {
- case FFESTP_dimtypeNONE:
- break;
-
- case FFESTP_dimtypeKNOWN:
- na |= FFESYMBOL_attrsARRAY;
- break;
-
- case FFESTP_dimtypeADJUSTABLE:
- na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
- break;
-
- case FFESTP_dimtypeASSUMED:
- na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
- break;
-
- case FFESTP_dimtypeADJUSTABLEASSUMED:
- na |= FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE;
- break;
-
- default:
- assert ("unexpected dimtype" == NULL);
- na = FFESYMBOL_attrsetNONE;
- break;
- }
-
- if (!ffesta_is_entry_valid
- && (((na & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))
- == (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsARRAY))))
- na = FFESYMBOL_attrsetNONE;
-
- if (is_init)
- {
- if (na == FFESYMBOL_attrsetNONE)
- ;
- else if (na & (FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE))
- na = FFESYMBOL_attrsetNONE;
- else
- na |= FFESYMBOL_attrsINIT;
- }
-
- /* Now figure out what kind of object we've got based on previous
- declarations of or references to the object. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ;
- else if (!ffesymbol_is_specable (s)
- && (((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
- && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))
- || (na & (FFESYMBOL_attrsARRAY | FFESYMBOL_attrsINIT))))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef, and can't
- dimension/init UNDERSTOODs. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if ((sa & na)
- || ((sa & (FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsADJUSTS))
- && (na & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsANYLEN)))
- || ((sa & FFESYMBOL_attrsRESULT)
- && (na & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsINIT)))
- || ((sa & (FFESYMBOL_attrsSFUNC
- | FFESYMBOL_attrsEXTERNAL
- | FFESYMBOL_attrsINTRINSIC
- | FFESYMBOL_attrsINIT))
- && (na & (FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsINIT)))
- || ((sa & FFESYMBOL_attrsARRAY)
- && !ffesta_is_entry_valid
- && (na & FFESYMBOL_attrsANYLEN))
- || ((sa & (FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE
- | FFESYMBOL_attrsDUMMY))
- && (na & FFESYMBOL_attrsINIT))
- || ((sa & (FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV))
- && (na & (FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE))))
- na = FFESYMBOL_attrsetNONE;
- else if ((ffesymbol_kind (s) == FFEINFO_kindENTITY)
- && (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
- && (na & FFESYMBOL_attrsANYLEN))
- { /* If CHARACTER*(*) FOO after PARAMETER FOO. */
- na |= FFESYMBOL_attrsTYPE;
- ffestc_local_.decl.size = ffebld_size (ffesymbol_init (s));
- }
- else
- na |= sa;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- {
- ffesymbol_error (s, name);
- ffestc_parent_ok_ = FALSE;
- }
- else if (na & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
- {
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- rank = ffesymbol_rank (s);
- if (dims != NULL)
- {
- ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
- &array_size,
- &extents,
- is_ugly_assumed));
- ffesymbol_set_arraysize (s, array_size);
- ffesymbol_set_extents (s, extents);
- if (!(0 && ffe_is_90 ())
- && (ffebld_op (array_size) == FFEBLD_opCONTER)
- && (ffebld_constant_integerdefault (ffebld_conter (array_size))
- == 0))
- {
- ffebad_start (FFEBAD_ZERO_ARRAY);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- }
- if (init != NULL)
- {
- ffesymbol_set_init (s,
- ffeexpr_convert (init, initt, name,
- ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- ffestc_local_.decl.size,
- FFEEXPR_contextDATA));
- ffecom_notify_init_symbol (s);
- ffesymbol_update_init (s);
-#if FFEGLOBAL_ENABLED
- if (ffesymbol_common (s) != NULL)
- ffeglobal_init_common (ffesymbol_common (s), initt);
-#endif
- }
- else if (clist)
- {
- ffebld symter;
-
- symter = ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
-
- ffebld_set_info (symter,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- ffestc_local_.decl.size));
- ffestc_local_.decl.initlist = ffebld_new_item (symter, NULL);
- }
- if (ffesymbol_basictype (s) == FFEINFO_basictypeNONE)
- {
- ffesymbol_set_info (s,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffestc_local_.decl.size));
- if ((na & FFESYMBOL_attrsRESULT)
- && ((sfn = ffesymbol_funcresult (s)) != NULL))
- {
- ffesymbol_set_info (sfn,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- rank,
- ffesymbol_kind (sfn),
- ffesymbol_where (sfn),
- ffestc_local_.decl.size));
- ffesymbol_signal_unreported (sfn);
- }
- }
- else if ((ffestc_local_.decl.basic_type != ffesymbol_basictype (s))
- || (ffestc_local_.decl.kind_type != ffesymbol_kindtype (s))
- || ((ffestc_local_.decl.basic_type
- == FFEINFO_basictypeCHARACTER)
- && (ffestc_local_.decl.size != ffesymbol_size (s))))
- { /* Explicit type disagrees with established
- implicit type. */
- ffesymbol_error (s, name);
- }
-
- if ((na & FFESYMBOL_attrsADJUSTS)
- && ((ffestc_local_.decl.basic_type != FFEINFO_basictypeINTEGER)
- || (ffestc_local_.decl.kind_type != FFEINFO_kindtypeINTEGER1)))
- ffesymbol_error (s, name);
-
- ffesymbol_signal_unreported (s);
- ffestc_parent_ok_ = TRUE;
- }
-}
-
-/* ffestc_R501_itemstartvals -- Start list of values
-
- ffestc_R501_itemstartvals();
-
- Gonna specify values for the object now. */
-
-void
-ffestc_R501_itemstartvals ()
-{
- ffestc_check_item_startvals_ ();
-
- if (ffestc_parent_ok_)
- ffedata_begin (ffestc_local_.decl.initlist);
-}
-
-/* ffestc_R501_itemvalue -- Source value
-
- ffestc_R501_itemvalue(repeat,repeat_token,value,value_token);
-
- Make sure repeat and value are valid for the object being initialized. */
-
-void
-ffestc_R501_itemvalue (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
-{
- ffetargetIntegerDefault rpt;
-
- ffestc_check_item_value_ ();
-
- if (!ffestc_parent_ok_)
- return;
-
- if (repeat == NULL)
- rpt = 1;
- else if (ffebld_op (repeat) == FFEBLD_opCONTER)
- rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
- else
- {
- ffestc_parent_ok_ = FALSE;
- ffedata_end (TRUE, NULL);
- return;
- }
-
- if (!(ffestc_parent_ok_ = ffedata_value (rpt, value,
- (repeat_token == NULL) ? value_token : repeat_token)))
- ffedata_end (TRUE, NULL);
-}
-
-/* ffestc_R501_itemendvals -- End list of values
-
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_R501_itemendvals(t);
-
- No more values, might specify more objects now. */
-
-void
-ffestc_R501_itemendvals (ffelexToken t)
-{
- ffestc_check_item_endvals_ ();
-
- if (ffestc_parent_ok_)
- ffestc_parent_ok_ = ffedata_end (FALSE, t);
-
- if (ffestc_parent_ok_)
- ffesymbol_signal_unreported (ffebld_symter (ffebld_head
- (ffestc_local_.decl.initlist)));
-}
-
-/* ffestc_R501_finish -- Done
-
- ffestc_R501_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R501_finish ()
-{
- ffestc_check_finish_ ();
-}
-
-/* ffestc_R519_start -- INTENT statement list begin
-
- ffestc_R519_start();
-
- Verify that INTENT is valid here, and begin accepting items in the list. */
-
-#if FFESTR_F90
-void
-ffestc_R519_start (ffelexToken intent, ffestrOther intent_kw)
-{
- ffestc_check_start_ ();
- if (ffestc_order_spec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R519_start (intent_kw);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R519_item -- INTENT statement for name
-
- ffestc_R519_item(name_token);
-
- Make sure name_token identifies a valid object to be INTENTed. */
-
-void
-ffestc_R519_item (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R519_item (name);
-}
-
-/* ffestc_R519_finish -- INTENT statement list complete
-
- ffestc_R519_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R519_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R519_finish ();
-}
-
-/* ffestc_R520_start -- OPTIONAL statement list begin
-
- ffestc_R520_start();
-
- Verify that OPTIONAL is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R520_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_spec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R520_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R520_item -- OPTIONAL statement for name
-
- ffestc_R520_item(name_token);
-
- Make sure name_token identifies a valid object to be OPTIONALed. */
-
-void
-ffestc_R520_item (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R520_item (name);
-}
-
-/* ffestc_R520_finish -- OPTIONAL statement list complete
-
- ffestc_R520_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R520_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R520_finish ();
-}
-
-/* ffestc_R521A -- PUBLIC statement
-
- ffestc_R521A();
-
- Verify that PUBLIC is valid here. */
-
-void
-ffestc_R521A ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- switch (ffestv_access_state_)
- {
- case FFESTV_accessstateNONE:
- ffestv_access_state_ = FFESTV_accessstatePUBLIC;
- ffestv_access_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_access_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
-
- case FFESTV_accessstateANY:
- break;
-
- case FFESTV_accessstatePUBLIC:
- case FFESTV_accessstatePRIVATE:
- ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
- ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- ffestv_access_state_ = FFESTV_accessstateANY;
- break;
-
- default:
- assert ("unexpected access state" == NULL);
- break;
- }
-
- ffestd_R521A ();
-}
-
-/* ffestc_R521Astart -- PUBLIC statement list begin
-
- ffestc_R521Astart();
-
- Verify that PUBLIC is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R521Astart ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R521Astart ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R521Aitem -- PUBLIC statement for name
-
- ffestc_R521Aitem(name_token);
-
- Make sure name_token identifies a valid object to be PUBLICed. */
-
-void
-ffestc_R521Aitem (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R521Aitem (name);
-}
-
-/* ffestc_R521Afinish -- PUBLIC statement list complete
-
- ffestc_R521Afinish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R521Afinish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R521Afinish ();
-}
-
-/* ffestc_R521B -- PRIVATE statement
-
- ffestc_R521B();
-
- Verify that PRIVATE is valid here (outside a derived-type statement). */
-
-void
-ffestc_R521B ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- switch (ffestv_access_state_)
- {
- case FFESTV_accessstateNONE:
- ffestv_access_state_ = FFESTV_accessstatePRIVATE;
- ffestv_access_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_access_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
-
- case FFESTV_accessstateANY:
- break;
-
- case FFESTV_accessstatePUBLIC:
- case FFESTV_accessstatePRIVATE:
- ffebad_start (FFEBAD_CONFLICTING_ACCESSES);
- ffebad_here (0, ffestv_access_line_, ffestv_access_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- ffestv_access_state_ = FFESTV_accessstateANY;
- break;
-
- default:
- assert ("unexpected access state" == NULL);
- break;
- }
-
- ffestd_R521B ();
-}
-
-/* ffestc_R521Bstart -- PRIVATE statement list begin
-
- ffestc_R521Bstart();
-
- Verify that PRIVATE is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R521Bstart ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_access_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R521Bstart ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R521Bitem -- PRIVATE statement for name
-
- ffestc_R521Bitem(name_token);
-
- Make sure name_token identifies a valid object to be PRIVATEed. */
-
-void
-ffestc_R521Bitem (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R521Bitem (name);
-}
-
-/* ffestc_R521Bfinish -- PRIVATE statement list complete
-
- ffestc_R521Bfinish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R521Bfinish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R521Bfinish ();
-}
-
-#endif
-/* ffestc_R522 -- SAVE statement with no list
-
- ffestc_R522();
-
- Verify that SAVE is valid here, and flag everything as SAVEd. */
-
-void
-ffestc_R522 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- switch (ffestv_save_state_)
- {
- case FFESTV_savestateNONE:
- ffestv_save_state_ = FFESTV_savestateALL;
- ffestv_save_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_save_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
-
- case FFESTV_savestateANY:
- break;
-
- case FFESTV_savestateSPECIFIC:
- case FFESTV_savestateALL:
- if (ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_CONFLICTING_SAVES);
- ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- ffestv_save_state_ = FFESTV_savestateALL;
- break;
-
- default:
- assert ("unexpected save state" == NULL);
- break;
- }
-
- ffe_set_is_saveall (TRUE);
-
- ffestd_R522 ();
-}
-
-/* ffestc_R522start -- SAVE statement list begin
-
- ffestc_R522start();
-
- Verify that SAVE is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R522start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- switch (ffestv_save_state_)
- {
- case FFESTV_savestateNONE:
- ffestv_save_state_ = FFESTV_savestateSPECIFIC;
- ffestv_save_line_
- = ffewhere_line_use (ffelex_token_where_line (ffesta_tokens[0]));
- ffestv_save_col_
- = ffewhere_column_use (ffelex_token_where_column (ffesta_tokens[0]));
- break;
-
- case FFESTV_savestateSPECIFIC:
- case FFESTV_savestateANY:
- break;
-
- case FFESTV_savestateALL:
- if (ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_CONFLICTING_SAVES);
- ffebad_here (0, ffestv_save_line_, ffestv_save_col_);
- ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- ffestv_save_state_ = FFESTV_savestateANY;
- break;
-
- default:
- assert ("unexpected save state" == NULL);
- break;
- }
-
- ffestd_R522start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R522item_object -- SAVE statement for object-name
-
- ffestc_R522item_object(name_token);
-
- Make sure name_token identifies a valid object to be SAVEd. */
-
-void
-ffestc_R522item_object (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s)
- && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
- || (ffesymbol_where (s) != FFEINFO_whereLOCAL)))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (!(sa & ~(FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsSAVE;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_update_save (s);
- ffesymbol_signal_unreported (s);
- }
-
- ffestd_R522item_object (name);
-}
-
-/* ffestc_R522item_cblock -- SAVE statement for common-block-name
-
- ffestc_R522item_cblock(name_token);
-
- Make sure name_token identifies a valid common block to be SAVEd. */
-
-void
-ffestc_R522item_cblock (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- s = ffesymbol_declare_cblock (name, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = sa; /* Already have an error here, say nothing. */
- else if (!(sa & ~(FFESYMBOL_attrsCBLOCK)))
- na = sa | FFESYMBOL_attrsSAVECBLOCK;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, (name == NULL) ? ffesta_tokens[0] : name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_update_save (s);
- ffesymbol_signal_unreported (s);
- }
-
- ffestd_R522item_cblock (name);
-}
-
-/* ffestc_R522finish -- SAVE statement list complete
-
- ffestc_R522finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R522finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R522finish ();
-}
-
-/* ffestc_R524_start -- DIMENSION statement list begin
-
- ffestc_R524_start(bool virtual);
-
- Verify that DIMENSION is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R524_start (bool virtual)
-{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R524_start (virtual);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R524_item -- DIMENSION statement for object-name
-
- ffestc_R524_item(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be DIMENSIONd. */
-
-void
-ffestc_R524_item (ffelexToken name, ffesttDimList dims)
-{
- ffesymbol s;
- ffebld array_size;
- ffebld extents;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffestpDimtype nd;
- ffeinfoRank rank;
- bool is_ugly_assumed;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- assert (dims != NULL);
- if (!ffestc_ok_)
- return;
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* First figure out what kind of object this is based solely on the current
- object situation (dimension list). */
-
- is_ugly_assumed = (ffe_is_ugly_assumed ()
- && ((sa & FFESYMBOL_attrsDUMMY)
- || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
-
- nd = ffestt_dimlist_type (dims, is_ugly_assumed);
- switch (nd)
- {
- case FFESTP_dimtypeKNOWN:
- na = FFESYMBOL_attrsARRAY;
- break;
-
- case FFESTP_dimtypeADJUSTABLE:
- na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE;
- break;
-
- case FFESTP_dimtypeASSUMED:
- na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsANYSIZE;
- break;
-
- case FFESTP_dimtypeADJUSTABLEASSUMED:
- na = FFESYMBOL_attrsARRAY | FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE;
- break;
-
- default:
- assert ("Unexpected dims type" == NULL);
- na = FFESYMBOL_attrsetNONE;
- break;
- }
-
- /* Now figure out what kind of object we've got based on previous
- declarations of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!ffesta_is_entry_valid
- && (sa & FFESYMBOL_attrsANYLEN))
- na = FFESYMBOL_attrsetNONE;
- else if ((sa & FFESYMBOL_attrsARRAY)
- || ((sa & (FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSAVE))
- && (na & (FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYSIZE))))
- na = FFESYMBOL_attrsetNONE;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
- | FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsANYSIZE
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsTYPE)))
- na |= sa;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
- &array_size,
- &extents,
- is_ugly_assumed));
- ffesymbol_set_arraysize (s, array_size);
- ffesymbol_set_extents (s, extents);
- if (!(0 && ffe_is_90 ())
- && (ffebld_op (array_size) == FFEBLD_opCONTER)
- && (ffebld_constant_integerdefault (ffebld_conter (array_size))
- == 0))
- {
- ffebad_start (FFEBAD_ZERO_ARRAY);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- rank,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffesymbol_size (s)));
- }
-
- ffesymbol_signal_unreported (s);
-
- ffestd_R524_item (name, dims);
-}
-
-/* ffestc_R524_finish -- DIMENSION statement list complete
-
- ffestc_R524_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R524_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R524_finish ();
-}
-
-/* ffestc_R525_start -- ALLOCATABLE statement list begin
-
- ffestc_R525_start();
-
- Verify that ALLOCATABLE is valid here, and begin accepting items in the
- list. */
-
-#if FFESTR_F90
-void
-ffestc_R525_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R525_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R525_item -- ALLOCATABLE statement for object-name
-
- ffestc_R525_item(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be ALLOCATABLEd. */
-
-void
-ffestc_R525_item (ffelexToken name, ffesttDimList dims)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_R525_item (name, dims);
-}
-
-/* ffestc_R525_finish -- ALLOCATABLE statement list complete
-
- ffestc_R525_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R525_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R525_finish ();
-}
-
-/* ffestc_R526_start -- POINTER statement list begin
-
- ffestc_R526_start();
-
- Verify that POINTER is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R526_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R526_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R526_item -- POINTER statement for object-name
-
- ffestc_R526_item(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be POINTERd. */
-
-void
-ffestc_R526_item (ffelexToken name, ffesttDimList dims)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_R526_item (name, dims);
-}
-
-/* ffestc_R526_finish -- POINTER statement list complete
-
- ffestc_R526_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R526_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R526_finish ();
-}
-
-/* ffestc_R527_start -- TARGET statement list begin
-
- ffestc_R527_start();
-
- Verify that TARGET is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R527_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R527_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R527_item -- TARGET statement for object-name
-
- ffestc_R527_item(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be TARGETd. */
-
-void
-ffestc_R527_item (ffelexToken name, ffesttDimList dims)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_R527_item (name, dims);
-}
-
-/* ffestc_R527_finish -- TARGET statement list complete
-
- ffestc_R527_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R527_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R527_finish ();
-}
-
-#endif
-/* ffestc_R528_start -- DATA statement list begin
-
- ffestc_R528_start();
-
- Verify that DATA is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R528_start ()
-{
- ffestcOrder_ order;
-
- ffestc_check_start_ ();
- if (ffe_is_pedantic_not_90 ())
- order = ffestc_order_data77_ ();
- else
- order = ffestc_order_data_ ();
- if (order != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
-#if 1
- ffestc_local_.data.objlist = NULL;
-#else
- ffestd_R528_start_ ();
-#endif
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R528_item_object -- DATA statement target object
-
- ffestc_R528_item_object(object,object_token);
-
- Make sure object is valid to be DATAd. */
-
-void
-ffestc_R528_item_object (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
-#if 1
- if (ffestc_local_.data.objlist == NULL)
- ffebld_init_list (&ffestc_local_.data.objlist,
- &ffestc_local_.data.list_bottom);
-
- ffebld_append_item (&ffestc_local_.data.list_bottom, expr);
-#else
- ffestd_R528_item_object_ (expr, expr_token);
-#endif
-}
-
-/* ffestc_R528_item_startvals -- DATA statement start list of values
-
- ffestc_R528_item_startvals();
-
- No more objects, gonna specify values for the list of objects now. */
-
-void
-ffestc_R528_item_startvals ()
-{
- ffestc_check_item_startvals_ ();
- if (!ffestc_ok_)
- return;
-
-#if 1
- assert (ffestc_local_.data.objlist != NULL);
- ffebld_end_list (&ffestc_local_.data.list_bottom);
- ffedata_begin (ffestc_local_.data.objlist);
-#else
- ffestd_R528_item_startvals_ ();
-#endif
-}
-
-/* ffestc_R528_item_value -- DATA statement source value
-
- ffestc_R528_item_value(repeat,repeat_token,value,value_token);
-
- Make sure repeat and value are valid for the objects being initialized. */
-
-void
-ffestc_R528_item_value (ffebld repeat, ffelexToken repeat_token,
- ffebld value, ffelexToken value_token)
-{
- ffetargetIntegerDefault rpt;
-
- ffestc_check_item_value_ ();
- if (!ffestc_ok_)
- return;
-
-#if 1
- if (repeat == NULL)
- rpt = 1;
- else if (ffebld_op (repeat) == FFEBLD_opCONTER)
- rpt = ffebld_constant_integerdefault (ffebld_conter (repeat));
- else
- {
- ffestc_ok_ = FALSE;
- ffedata_end (TRUE, NULL);
- return;
- }
-
- if (!(ffestc_ok_ = ffedata_value (rpt, value,
- (repeat_token == NULL)
- ? value_token
- : repeat_token)))
- ffedata_end (TRUE, NULL);
-
-#else
- ffestd_R528_item_value_ (repeat, value);
-#endif
-}
-
-/* ffestc_R528_item_endvals -- DATA statement start list of values
-
- ffelexToken t; // the SLASH token that ends the list.
- ffestc_R528_item_endvals(t);
-
- No more values, might specify more objects now. */
-
-void
-ffestc_R528_item_endvals (ffelexToken t)
-{
- ffestc_check_item_endvals_ ();
- if (!ffestc_ok_)
- return;
-
-#if 1
- ffedata_end (!ffestc_ok_, t);
- ffestc_local_.data.objlist = NULL;
-#else
- ffestd_R528_item_endvals_ (t);
-#endif
-}
-
-/* ffestc_R528_finish -- DATA statement list complete
-
- ffestc_R528_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R528_finish ()
-{
- ffestc_check_finish_ ();
-
-#if 1
-#else
- ffestd_R528_finish_ ();
-#endif
-}
-
-/* ffestc_R537_start -- PARAMETER statement list begin
-
- ffestc_R537_start();
-
- Verify that PARAMETER is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R537_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_parameter_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_R537_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R537_item -- PARAMETER statement assignment
-
- ffestc_R537_item(dest,dest_token,source,source_token);
-
- Make sure the source is a valid source for the destination; make the
- assignment. */
-
-void
-ffestc_R537_item (ffebld dest, ffelexToken dest_token, ffebld source,
- ffelexToken source_token)
-{
- ffesymbol s;
-
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if ((ffebld_op (dest) == FFEBLD_opANY)
- || (ffebld_op (source) == FFEBLD_opANY))
- {
- if (ffebld_op (dest) == FFEBLD_opSYMTER)
- {
- s = ffebld_symter (dest);
- ffesymbol_set_init (s, ffebld_new_any ());
- ffebld_set_info (ffesymbol_init (s), ffeinfo_new_any ());
- ffesymbol_signal_unreported (s);
- }
- ffestd_R537_item (dest, source);
- return;
- }
-
- assert (ffebld_op (dest) == FFEBLD_opSYMTER);
- assert (ffebld_op (source) == FFEBLD_opCONTER);
-
- s = ffebld_symter (dest);
- if ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
- && (ffesymbol_size (s) == FFETARGET_charactersizeNONE))
- { /* Destination has explicit/implicit
- CHARACTER*(*) type; set length. */
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffebld_size (source)));
- ffebld_set_info (dest, ffeinfo_use (ffesymbol_info (s)));
- }
-
- source = ffeexpr_convert_expr (source, source_token, dest, dest_token,
- FFEEXPR_contextDATA);
-
- ffesymbol_set_init (s, source);
-
- ffesymbol_signal_unreported (s);
-
- ffestd_R537_item (dest, source);
-}
-
-/* ffestc_R537_finish -- PARAMETER statement list complete
-
- ffestc_R537_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R537_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R537_finish ();
-}
-
-/* ffestc_R539 -- IMPLICIT NONE statement
-
- ffestc_R539();
-
- Verify that the IMPLICIT NONE statement is ok here and implement. */
-
-void
-ffestc_R539 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_implicitnone_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffeimplic_none ();
-
- ffestd_R539 ();
-}
-
-/* ffestc_R539start -- IMPLICIT statement
-
- ffestc_R539start();
-
- Verify that the IMPLICIT statement is ok here and implement. */
-
-void
-ffestc_R539start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_implicit_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R539start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R539item -- IMPLICIT statement specification (R540)
-
- ffestc_R539item(...);
-
- Verify that the type and letter list are all ok and implement. */
-
-void
-ffestc_R539item (ffestpType type, ffebld kind, ffelexToken kindt,
- ffebld len, ffelexToken lent, ffesttImpList letters)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if ((type == FFESTP_typeCHARACTER) && (len != NULL)
- && (ffebld_op (len) == FFEBLD_opSTAR))
- { /* Complain and pretend they're CHARACTER
- [*1]. */
- ffebad_start (FFEBAD_IMPLICIT_ADJLEN);
- ffebad_here (0, ffelex_token_where_line (lent),
- ffelex_token_where_column (lent));
- ffebad_finish ();
- len = NULL;
- lent = NULL;
- }
- ffestc_establish_declstmt_ (type, ffesta_tokens[0], kind, kindt, len, lent);
- ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
-
- ffestt_implist_drive (letters, ffestc_establish_impletter_);
-
- ffestd_R539item (type, kind, kindt, len, lent, letters);
-}
-
-/* ffestc_R539finish -- IMPLICIT statement
-
- ffestc_R539finish();
-
- Finish up any local activities. */
-
-void
-ffestc_R539finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R539finish ();
-}
-
-/* ffestc_R542_start -- NAMELIST statement list begin
-
- ffestc_R542_start();
-
- Verify that NAMELIST is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R542_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- if (ffe_is_f2c_library ()
- && (ffe_case_source () == FFE_caseNONE))
- {
- ffebad_start (FFEBAD_NAMELIST_CASE);
- ffesta_ffebad_here_current_stmt (0);
- ffebad_finish ();
- }
-
- ffestd_R542_start ();
-
- ffestc_local_.namelist.symbol = NULL;
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R542_item_nlist -- NAMELIST statement for group-name
-
- ffestc_R542_item_nlist(groupname_token);
-
- Make sure name_token identifies a valid object to be NAMELISTd. */
-
-void
-ffestc_R542_item_nlist (ffelexToken name)
-{
- ffesymbol s;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- if (ffestc_local_.namelist.symbol != NULL)
- ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
-
- s = ffesymbol_declare_local (name, FALSE);
-
- if ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
- || ((ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)))
- {
- ffestc_parent_ok_ = TRUE;
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffebld_init_list (ffesymbol_ptr_to_namelist (s),
- ffesymbol_ptr_to_listbottom (s));
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNAMELIST,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- }
- }
- else
- {
- if (ffesymbol_kind (s) != FFEINFO_kindANY)
- ffesymbol_error (s, name);
- ffestc_parent_ok_ = FALSE;
- }
-
- ffestc_local_.namelist.symbol = s;
-
- ffestd_R542_item_nlist (name);
-}
-
-/* ffestc_R542_item_nitem -- NAMELIST statement for variable-name
-
- ffestc_R542_item_nitem(name_token);
-
- Make sure name_token identifies a valid object to be NAMELISTd. */
-
-void
-ffestc_R542_item_nitem (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffebld e;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s)
- && ((ffesymbol_kind (s) != FFEINFO_kindENTITY)
- || ((ffesymbol_where (s) != FFEINFO_whereLOCAL)
- && (ffesymbol_where (s) != FFEINFO_whereCOMMON))))
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsCOMMON
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSAVE
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsNAMELIST;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_namelisted (s, TRUE);
- ffesymbol_signal_unreported (s);
-#if 0 /* No need to establish type yet! */
- if (!ffeimplic_establish_symbol (s))
- ffesymbol_error (s, name);
-#endif
- }
-
- if (ffestc_parent_ok_)
- {
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE, 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_append_item
- (ffesymbol_ptr_to_listbottom (ffestc_local_.namelist.symbol), e);
- }
-
- ffestd_R542_item_nitem (name);
-}
-
-/* ffestc_R542_finish -- NAMELIST statement list complete
-
- ffestc_R542_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R542_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffesymbol_signal_unreported (ffestc_local_.namelist.symbol);
-
- ffestd_R542_finish ();
-}
-
-/* ffestc_R544_start -- EQUIVALENCE statement list begin
-
- ffestc_R544_start();
-
- Verify that EQUIVALENCE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R544_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R544_item -- EQUIVALENCE statement assignment
-
- ffestc_R544_item(exprlist);
-
- Make sure the equivalence is valid, then implement it. */
-
-void
-ffestc_R544_item (ffesttExprList exprlist)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- /* First we go through the list and come up with one ffeequiv object that
- will describe all items in the list. When an ffeequiv object is first
- found, it is used (else we create one as a "local equiv" for the time
- being). If subsequent ffeequiv objects are found, they are merged with
- the first so we end up with one. However, if more than one COMMON
- variable is involved, then an error condition occurs. */
-
- ffestc_local_.equiv.ok = TRUE;
- ffestc_local_.equiv.t = NULL; /* No token yet. */
- ffestc_local_.equiv.eq = NULL;/* No equiv yet. */
- ffestc_local_.equiv.save = FALSE; /* No SAVEd variables yet. */
-
- ffebld_init_list (&ffestc_local_.equiv.list, &ffestc_local_.equiv.bottom);
- ffestt_exprlist_drive (exprlist, ffestc_R544_equiv_); /* Get one equiv. */
- ffebld_end_list (&ffestc_local_.equiv.bottom);
-
- if (!ffestc_local_.equiv.ok)
- return; /* Something went wrong, stop bothering with
- this stuff. */
-
- if (ffestc_local_.equiv.eq == NULL)
- ffestc_local_.equiv.eq = ffeequiv_new (); /* Make local equivalence. */
-
- /* Append this list of equivalences to list of such lists for this
- equivalence. */
-
- ffeequiv_add (ffestc_local_.equiv.eq, ffestc_local_.equiv.list,
- ffestc_local_.equiv.t);
- if (ffestc_local_.equiv.save)
- ffeequiv_update_save (ffestc_local_.equiv.eq);
-}
-
-/* ffestc_R544_equiv_ -- EQUIVALENCE statement handler for item in list
-
- ffebld expr;
- ffelexToken t;
- ffestc_R544_equiv_(expr,t);
-
- Record information, if any, on symbol in expr; if symbol has equivalence
- object already, merge with outstanding object if present or make it
- the outstanding object. */
-
-static void
-ffestc_R544_equiv_ (ffebld expr, ffelexToken t)
-{
- ffesymbol s;
-
- if (!ffestc_local_.equiv.ok)
- return;
-
- if (ffestc_local_.equiv.t == NULL)
- ffestc_local_.equiv.t = t;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opANY:
- return; /* Don't put this on the list. */
-
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opSUBSTR:
- break; /* All of these are ok. */
-
- default:
- assert ("ffestc_R544_equiv_ bad op" == NULL);
- return;
- }
-
- ffebld_append_item (&ffestc_local_.equiv.bottom, expr);
-
- s = ffeequiv_symbol (expr);
-
- /* See if symbol has an equivalence object already. */
-
- if (ffesymbol_equiv (s) != NULL)
- {
- if (ffestc_local_.equiv.eq == NULL)
- ffestc_local_.equiv.eq = ffesymbol_equiv (s); /* New equiv obj. */
- else if (ffestc_local_.equiv.eq != ffesymbol_equiv (s))
- {
- ffestc_local_.equiv.eq = ffeequiv_merge (ffesymbol_equiv (s),
- ffestc_local_.equiv.eq,
- t);
- if (ffestc_local_.equiv.eq == NULL)
- ffestc_local_.equiv.ok = FALSE; /* Couldn't merge. */
- }
- }
-
- if (ffesymbol_is_save (s))
- ffestc_local_.equiv.save = TRUE;
-}
-
-/* ffestc_R544_finish -- EQUIVALENCE statement list complete
-
- ffestc_R544_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R544_finish ()
-{
- ffestc_check_finish_ ();
-}
-
-/* ffestc_R547_start -- COMMON statement list begin
-
- ffestc_R547_start();
-
- Verify that COMMON is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R547_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_blockspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestc_local_.common.symbol = NULL; /* Blank common is the default. */
- ffestc_parent_ok_ = TRUE;
-
- ffestd_R547_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R547_item_object -- COMMON statement for object-name
-
- ffestc_R547_item_object(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be COMMONd. */
-
-void
-ffestc_R547_item_object (ffelexToken name, ffesttDimList dims)
-{
- ffesymbol s;
- ffebld array_size;
- ffebld extents;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffestpDimtype nd;
- ffebld e;
- ffeinfoRank rank;
- bool is_ugly_assumed;
-
- if (ffestc_parent_ok_ && (ffestc_local_.common.symbol == NULL))
- ffestc_R547_item_cblock (NULL); /* As if "COMMON [//] ...". */
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- if (dims != NULL)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* First figure out what kind of object this is based solely on the current
- object situation (dimension list). */
-
- is_ugly_assumed = (ffe_is_ugly_assumed ()
- && ((sa & FFESYMBOL_attrsDUMMY)
- || (ffesymbol_where (s) == FFEINFO_whereDUMMY)));
-
- nd = ffestt_dimlist_type (dims, is_ugly_assumed);
- switch (nd)
- {
- case FFESTP_dimtypeNONE:
- na = FFESYMBOL_attrsCOMMON;
- break;
-
- case FFESTP_dimtypeKNOWN:
- na = FFESYMBOL_attrsCOMMON | FFESYMBOL_attrsARRAY;
- break;
-
- default:
- na = FFESYMBOL_attrsetNONE;
- break;
- }
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ;
- else if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if ((sa & (FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsSFARG))
- && (na & FFESYMBOL_attrsARRAY))
- na = FFESYMBOL_attrsetNONE;
- else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
- | FFESYMBOL_attrsARRAY
- | FFESYMBOL_attrsEQUIV
- | FFESYMBOL_attrsINIT
- | FFESYMBOL_attrsNAMELIST
- | FFESYMBOL_attrsSFARG
- | FFESYMBOL_attrsTYPE)))
- na |= sa;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if ((ffesymbol_equiv (s) != NULL)
- && (ffeequiv_common (ffesymbol_equiv (s)) != NULL)
- && (ffeequiv_common (ffesymbol_equiv (s))
- != ffestc_local_.common.symbol))
- {
- /* Oops, just COMMONed a symbol to a different area (via equiv). */
- ffebad_start (FFEBAD_EQUIV_COMMON);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_string (ffesymbol_text (ffestc_local_.common.symbol));
- ffebad_string (ffesymbol_text (ffeequiv_common (ffesymbol_equiv (s))));
- ffebad_finish ();
- ffesymbol_set_attr (s, na | FFESYMBOL_attrANY);
- ffesymbol_set_info (s, ffeinfo_new_any ());
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_signal_unreported (s);
- }
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_common (s, ffestc_local_.common.symbol);
-#if FFEGLOBAL_ENABLED
- if (ffesymbol_is_init (s))
- ffeglobal_init_common (ffestc_local_.common.symbol, name);
-#endif
- if (ffesymbol_is_save (ffestc_local_.common.symbol))
- ffesymbol_update_save (s);
- if (ffesymbol_equiv (s) != NULL)
- { /* Is this newly COMMONed symbol involved in
- an equivalence? */
- if (ffeequiv_common (ffesymbol_equiv (s)) == NULL)
- ffeequiv_set_common (ffesymbol_equiv (s), /* Yes, tell equiv obj. */
- ffestc_local_.common.symbol);
-#if FFEGLOBAL_ENABLED
- if (ffeequiv_is_init (ffesymbol_equiv (s)))
- ffeglobal_init_common (ffestc_local_.common.symbol, name);
-#endif
- if (ffesymbol_is_save (ffestc_local_.common.symbol))
- ffeequiv_update_save (ffesymbol_equiv (s));
- }
- if (dims != NULL)
- {
- ffesymbol_set_dims (s, ffestt_dimlist_as_expr (dims, &rank,
- &array_size,
- &extents,
- is_ugly_assumed));
- ffesymbol_set_arraysize (s, array_size);
- ffesymbol_set_extents (s, extents);
- if (!(0 && ffe_is_90 ())
- && (ffebld_op (array_size) == FFEBLD_opCONTER)
- && (ffebld_constant_integerdefault (ffebld_conter (array_size))
- == 0))
- {
- ffebad_start (FFEBAD_ZERO_ARRAY);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- rank,
- ffesymbol_kind (s),
- ffesymbol_where (s),
- ffesymbol_size (s)));
- }
- ffesymbol_signal_unreported (s);
- }
-
- if (ffestc_parent_ok_)
- {
- e = ffebld_new_symter (s, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
- FFEINTRIN_impNONE);
- ffebld_set_info (e,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- FFETARGET_charactersizeNONE));
- ffebld_append_item
- (ffesymbol_ptr_to_listbottom (ffestc_local_.common.symbol), e);
- }
-
- ffestd_R547_item_object (name, dims);
-}
-
-/* ffestc_R547_item_cblock -- COMMON statement for common-block-name
-
- ffestc_R547_item_cblock(name_token);
-
- Make sure name_token identifies a valid common block to be COMMONd. */
-
-void
-ffestc_R547_item_cblock (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_local_.common.symbol != NULL)
- ffesymbol_signal_unreported (ffestc_local_.common.symbol);
-
- s = ffesymbol_declare_cblock (name,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY; /* Already have an error here, say nothing. */
- else if (!(sa & ~(FFESYMBOL_attrsCBLOCK
- | FFESYMBOL_attrsSAVECBLOCK)))
- {
- if (!(sa & FFESYMBOL_attrsCBLOCK))
- ffebld_init_list (ffesymbol_ptr_to_commonlist (s),
- ffesymbol_ptr_to_listbottom (s));
- na = sa | FFESYMBOL_attrsCBLOCK;
- }
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- {
- ffesymbol_error (s, name == NULL ? ffesta_tokens[0] : name);
- ffestc_parent_ok_ = FALSE;
- }
- else if (na & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- if (name == NULL)
- ffesymbol_update_save (s);
- ffestc_parent_ok_ = TRUE;
- }
-
- ffestc_local_.common.symbol = s;
-
- ffestd_R547_item_cblock (name);
-}
-
-/* ffestc_R547_finish -- COMMON statement list complete
-
- ffestc_R547_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R547_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_local_.common.symbol != NULL)
- ffesymbol_signal_unreported (ffestc_local_.common.symbol);
-
- ffestd_R547_finish ();
-}
-
-/* ffestc_R620 -- ALLOCATE statement
-
- ffestc_R620(exprlist,stat,stat_token);
-
- Make sure the expression list is valid, then implement it. */
-
-#if FFESTR_F90
-void
-ffestc_R620 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R620 (exprlist, stat);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R624 -- NULLIFY statement
-
- ffestc_R624(pointer_name_list);
-
- Make sure pointer_name_list identifies valid pointers for a NULLIFY. */
-
-void
-ffestc_R624 (ffesttExprList pointers)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R624 (pointers);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R625 -- DEALLOCATE statement
-
- ffestc_R625(exprlist,stat,stat_token);
-
- Make sure the equivalence is valid, then implement it. */
-
-void
-ffestc_R625 (ffesttExprList exprlist, ffebld stat, ffelexToken stat_token)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R625 (exprlist, stat);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-#endif
-/* ffestc_let -- R1213 or R737
-
- ffestc_let(...);
-
- Verify that R1213 defined-assignment or R737 assignment-stmt are
- valid here, figure out which one, and implement. */
-
-#if FFESTR_F90
-void
-ffestc_let (ffebld dest, ffebld source, ffelexToken source_token)
-{
- ffestc_R737 (dest, source, source_token);
-}
-
-#endif
-/* ffestc_R737 -- Assignment statement
-
- ffestc_R737(dest_expr,source_expr,source_token);
-
- Make sure the assignment is valid. */
-
-void
-ffestc_R737 (ffebld dest, ffebld source, ffelexToken source_token)
-{
- ffestc_check_simple_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
-#if FFESTR_F90
- case FFESTV_stateWHERE:
- case FFESTV_stateWHERETHEN:
- if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestd_R737B (dest, source);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- return;
-#endif
-
- default:
- break;
- }
-
- if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- source = ffeexpr_convert_expr (source, source_token, dest, ffesta_tokens[0],
- FFEEXPR_contextLET);
-
- ffestd_R737A (dest, source);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R738 -- Pointer assignment statement
-
- ffestc_R738(dest_expr,source_expr,source_token);
-
- Make sure the assignment is valid. */
-
-#if FFESTR_F90
-void
-ffestc_R738 (ffebld dest, ffebld source, ffelexToken source_token)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R738 (dest, source);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R740 -- WHERE statement
-
- ffestc_R740(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R740 (ffebld expr, ffelexToken expr_token)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateWHERE);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_where_lost_);
-
- ffestd_R740 (expr);
-
- /* Leave label finishing to next statement. */
-
-}
-
-/* ffestc_R742 -- WHERE-construct statement
-
- ffestc_R742(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R742 (ffebld expr, ffelexToken expr_token)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_probably_this_wont_work_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateWHERETHEN);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_wherethen_);
- ffestw_set_substate (b, 0); /* Haven't seen ELSEWHERE yet. */
-
- ffestd_R742 (expr);
-}
-
-/* ffestc_R744 -- ELSE WHERE statement
-
- ffestc_R744();
-
- Make sure ffestc_kind_ identifies a WHERE block.
- Implement the ELSE of the current WHERE block. */
-
-void
-ffestc_R744 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_where_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_SECOND_ELSE_WHERE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSEWHERE. */
-
- ffestd_R744 ();
-}
-
-/* ffestc_R745 -- END WHERE statement
-
- ffestc_R745();
-
- Make sure ffestc_kind_ identifies a WHERE block.
- Implement the end of the current WHERE block. */
-
-void
-ffestc_R745 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_where_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_shriek_wherethen_ (TRUE);
-}
-
-#endif
-/* ffestc_R803 -- Block IF (IF-THEN) statement
-
- ffestc_R803(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R803 (ffelexToken construct_name, ffebld expr,
- ffelexToken expr_token UNUSED)
-{
- ffestw b;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateIFTHEN);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_ifthen_);
- ffestw_set_substate (b, 0); /* Haven't seen ELSE yet. */
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- ffestd_R803 (construct_name, expr);
-}
-
-/* ffestc_R804 -- ELSE IF statement
-
- ffestc_R804(expr,expr_token,name_token);
-
- Make sure ffestc_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the else
- of the IF block. */
-
-void
-ffestc_R804 (ffebld expr, ffelexToken expr_token UNUSED,
- ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_AFTER_ELSE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return; /* Don't upset back end with ELSEIF
- after ELSE. */
- }
-
- ffestd_R804 (expr, name);
-}
-
-/* ffestc_R805 -- ELSE statement
-
- ffestc_R805(name_token);
-
- Make sure ffestc_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the ELSE
- of the IF block. */
-
-void
-ffestc_R805 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_AFTER_ELSE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- return; /* Tell back end about only one ELSE. */
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
-
- ffestd_R805 (name);
-}
-
-/* ffestc_R806 -- END IF statement
-
- ffestc_R806(name_token);
-
- Make sure ffestc_kind_ identifies an IF block. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the IF block. */
-
-void
-ffestc_R806 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_ifthen_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_endif_ ();
-
- if (name == NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NAMED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- }
- else
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- ffestc_shriek_ifthen_ (TRUE);
-}
-
-/* ffestc_R807 -- Logical IF statement
-
- ffestc_R807(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R807 (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_action_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateIF);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_if_lost_);
-
- ffestd_R807 (expr);
-
- /* Do the label finishing in the next statement. */
-
-}
-
-/* ffestc_R809 -- SELECT CASE statement
-
- ffestc_R809(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R809 (ffelexToken construct_name, ffebld expr, ffelexToken expr_token)
-{
- ffestw b;
- mallocPool pool;
- ffestwSelect s;
- ffesymbol sym;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, ffestw_top_do (ffestw_previous (b)));
- ffestw_set_state (b, FFESTV_stateSELECT0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_select_);
- ffestw_set_substate (b, 0); /* Haven't seen CASE DEFAULT yet. */
-
- /* Init block to manage CASE list. */
-
- pool = malloc_pool_new ("Select", ffe_pool_any_unit (), 1024);
- s = (ffestwSelect) malloc_new_kp (pool, "Select", sizeof (*s));
- s->first_rel = (ffestwCase) &s->first_rel;
- s->last_rel = (ffestwCase) &s->first_rel;
- s->first_stmt = (ffestwCase) &s->first_rel;
- s->last_stmt = (ffestwCase) &s->first_rel;
- s->pool = pool;
- s->cases = 1;
- s->t = ffelex_token_use (expr_token);
- s->type = ffeinfo_basictype (ffebld_info (expr));
- s->kindtype = ffeinfo_kindtype (ffebld_info (expr));
- ffestw_set_select (b, s);
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- sym = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (sym) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (sym, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (sym,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE, 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- sym = ffecom_sym_learned (sym);
- ffesymbol_signal_unreported (sym);
- }
- else
- ffesymbol_error (sym, construct_name);
- }
-
- ffestd_R809 (construct_name, expr);
-}
-
-/* ffestc_R810 -- CASE statement
-
- ffestc_R810(case_value_range_list,name);
-
- If case_value_range_list is NULL, it's CASE DEFAULT. name is the case-
- construct-name. Make sure no more than one CASE DEFAULT is present for
- a given case-construct and that there aren't any overlapping ranges or
- duplicate case values. */
-
-void
-ffestc_R810 (ffesttCaseList cases, ffelexToken name)
-{
- ffesttCaseList caseobj;
- ffestwSelect s;
- ffestwCase c, nc;
- ffebldConstant expr1c, expr2c;
-
- ffestc_check_simple_ ();
- if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- s = ffestw_select (ffestw_stack_top ());
-
- if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateSELECT0)
- {
-#if 0 /* Not sure we want to have msgs point here
- instead of SELECT CASE. */
- ffestw_update (NULL); /* Update state line/col info. */
-#endif
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateSELECT1);
- }
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- if (cases == NULL)
- {
- if (ffestw_substate (ffestw_stack_top ()) != 0)
- {
- ffebad_start (FFEBAD_CASE_SECOND_DEFAULT);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Saw ELSE. */
- }
- else
- { /* For each case, try to fit into sorted list
- of ranges. */
- for (caseobj = cases->next; caseobj != cases; caseobj = caseobj->next)
- {
- if ((caseobj->expr1 == NULL)
- && (!caseobj->range
- || (caseobj->expr2 == NULL)))
- { /* "CASE (:)". */
- ffebad_start (FFEBAD_CASE_BAD_RANGE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_finish ();
- continue;
- }
-
- if (((caseobj->expr1 != NULL)
- && ((ffeinfo_basictype (ffebld_info (caseobj->expr1))
- != s->type)
- || (ffeinfo_kindtype (ffebld_info (caseobj->expr1))
- != s->kindtype)))
- || ((caseobj->range)
- && (caseobj->expr2 != NULL)
- && ((ffeinfo_basictype (ffebld_info (caseobj->expr2))
- != s->type)
- || (ffeinfo_kindtype (ffebld_info (caseobj->expr2))
- != s->kindtype))))
- {
- ffebad_start (FFEBAD_CASE_TYPE_DISAGREE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (s->t),
- ffelex_token_where_column (s->t));
- ffebad_finish ();
- continue;
- }
-
- if ((s->type == FFEINFO_basictypeLOGICAL) && (caseobj->range))
- {
- ffebad_start (FFEBAD_CASE_LOGICAL_RANGE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_finish ();
- continue;
- }
-
- if (caseobj->expr1 == NULL)
- expr1c = NULL;
- else if (ffebld_op (caseobj->expr1) != FFEBLD_opCONTER)
- continue; /* opANY. */
- else
- expr1c = ffebld_conter (caseobj->expr1);
-
- if (!caseobj->range)
- expr2c = expr1c; /* expr1c and expr2c are NOT NULL in this
- case. */
- else if (caseobj->expr2 == NULL)
- expr2c = NULL;
- else if (ffebld_op (caseobj->expr2) != FFEBLD_opCONTER)
- continue; /* opANY. */
- else
- expr2c = ffebld_conter (caseobj->expr2);
-
- if (expr1c == NULL)
- { /* "CASE (:high)", must be first in list. */
- c = s->first_rel;
- if ((c != (ffestwCase) &s->first_rel)
- && ((c->low == NULL)
- || (ffebld_constant_cmp (expr2c, c->low) >= 0)))
- { /* Other "CASE (:high)" or lowest "CASE
- (low[:high])" low. */
- ffebad_start (FFEBAD_CASE_DUPLICATE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (c->t),
- ffelex_token_where_column (c->t));
- ffebad_finish ();
- continue;
- }
- }
- else if (expr2c == NULL)
- { /* "CASE (low:)", must be last in list. */
- c = s->last_rel;
- if ((c != (ffestwCase) &s->first_rel)
- && ((c->high == NULL)
- || (ffebld_constant_cmp (expr1c, c->high) <= 0)))
- { /* Other "CASE (low:)" or lowest "CASE
- ([low:]high)" high. */
- ffebad_start (FFEBAD_CASE_DUPLICATE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (c->t),
- ffelex_token_where_column (c->t));
- ffebad_finish ();
- continue;
- }
- c = c->next_rel; /* Same as c = (ffestwCase) &s->first;. */
- }
- else
- { /* (expr1c != NULL) && (expr2c != NULL). */
- if (ffebld_constant_cmp (expr1c, expr2c) > 0)
- { /* Such as "CASE (3:1)" or "CASE ('B':'A')". */
- ffebad_start (FFEBAD_CASE_RANGE_USELESS); /* Warn/inform only. */
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_finish ();
- continue;
- }
- for (c = s->first_rel;
- (c != (ffestwCase) &s->first_rel)
- && ((c->low == NULL)
- || (ffebld_constant_cmp (expr1c, c->low) > 0));
- c = c->next_rel)
- ;
- nc = c; /* Which one to report? */
- if (((c != (ffestwCase) &s->first_rel)
- && (ffebld_constant_cmp (expr2c, c->low) >= 0))
- || (((nc = c->previous_rel) != (ffestwCase) &s->first_rel)
- && (ffebld_constant_cmp (expr1c, nc->high) <= 0)))
- { /* Interference with range in case nc. */
- ffebad_start (FFEBAD_CASE_DUPLICATE);
- ffebad_here (0, ffelex_token_where_line (caseobj->t),
- ffelex_token_where_column (caseobj->t));
- ffebad_here (1, ffelex_token_where_line (nc->t),
- ffelex_token_where_column (nc->t));
- ffebad_finish ();
- continue;
- }
- }
-
- /* If we reach here for this case range/value, it's ok (sorts into
- the list of ranges/values) so we give it its own case object
- sorted into the list of case statements. */
-
- nc = malloc_new_kp (s->pool, "Case range", sizeof (*nc));
- nc->next_rel = c;
- nc->previous_rel = c->previous_rel;
- nc->next_stmt = (ffestwCase) &s->first_rel;
- nc->previous_stmt = s->last_stmt;
- nc->low = expr1c;
- nc->high = expr2c;
- nc->casenum = s->cases;
- nc->t = ffelex_token_use (caseobj->t);
- nc->next_rel->previous_rel = nc;
- nc->previous_rel->next_rel = nc;
- nc->next_stmt->previous_stmt = nc;
- nc->previous_stmt->next_stmt = nc;
- }
- }
-
- ffestd_R810 ((cases == NULL) ? 0 : s->cases);
-
- s->cases++; /* Increment # of cases. */
-}
-
-/* ffestc_R811 -- END SELECT statement
-
- ffestc_R811(name_token);
-
- Make sure ffestc_kind_ identifies a SELECT block. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the SELECT block. */
-
-void
-ffestc_R811 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_selectcase_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (name == NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NAMED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- }
- else
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- ffestc_shriek_select_ (TRUE);
-}
-
-/* ffestc_R819A -- Iterative labeled DO statement
-
- ffestc_R819A(construct_name,label_token,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R819A (ffelexToken construct_name, ffelexToken label_token, ffebld var,
- ffelexToken var_token, ffebld start, ffelexToken start_token, ffebld end,
- ffelexToken end_token, ffebld incr, ffelexToken incr_token)
-{
- ffestw b;
- ffelab label;
- ffesymbol s;
- ffesymbol varsym;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (!ffestc_labelref_is_loopend_ (label_token, &label))
- return;
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, label);
- switch (ffebld_op (var))
- {
- case FFEBLD_opSYMTER:
- if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
- && ffe_is_warn_surprising ())
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (var_token),
- ffelex_token_where_column (var_token));
- ffebad_string (ffesymbol_text (ffebld_symter (var)));
- ffebad_finish ();
- }
- if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
- { /* Presumably already complained about by
- ffeexpr_lhs_. */
- ffesymbol_set_is_doiter (varsym, TRUE);
- ffestw_set_do_iter_var (b, varsym);
- ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
- break;
- }
- /* Fall through. */
- case FFEBLD_opANY:
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
- break;
-
- default:
- assert ("bad iter var" == NULL);
- break;
- }
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- if (incr == NULL)
- {
- incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
- ffebld_set_info (incr, ffeinfo_new
- (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- }
-
- start = ffeexpr_convert_expr (start, start_token, var, var_token,
- FFEEXPR_contextLET);
- end = ffeexpr_convert_expr (end, end_token, var, var_token,
- FFEEXPR_contextLET);
- incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
- FFEEXPR_contextLET);
-
- ffestd_R819A (construct_name, label, var,
- start, start_token,
- end, end_token,
- incr, incr_token);
-}
-
-/* ffestc_R819B -- Labeled DO WHILE statement
-
- ffestc_R819B(construct_name,label_token,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R819B (ffelexToken construct_name, ffelexToken label_token,
- ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestw b;
- ffelab label;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (!ffestc_labelref_is_loopend_ (label_token, &label))
- return;
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, label);
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- ffestd_R819B (construct_name, label, expr);
-}
-
-/* ffestc_R820A -- Iterative nonlabeled DO statement
-
- ffestc_R820A(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R820A (ffelexToken construct_name, ffebld var, ffelexToken var_token,
- ffebld start, ffelexToken start_token, ffebld end, ffelexToken end_token,
- ffebld incr, ffelexToken incr_token)
-{
- ffestw b;
- ffesymbol s;
- ffesymbol varsym;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, NULL);
- switch (ffebld_op (var))
- {
- case FFEBLD_opSYMTER:
- if ((ffeinfo_basictype (ffebld_info (var)) == FFEINFO_basictypeREAL)
- && ffe_is_warn_surprising ())
- {
- ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
- ffebad_here (0, ffelex_token_where_line (var_token),
- ffelex_token_where_column (var_token));
- ffebad_string (ffesymbol_text (ffebld_symter (var)));
- ffebad_finish ();
- }
- if (!ffesymbol_is_doiter (varsym = ffebld_symter (var)))
- { /* Presumably already complained about by
- ffeexpr_lhs_. */
- ffesymbol_set_is_doiter (varsym, TRUE);
- ffestw_set_do_iter_var (b, varsym);
- ffestw_set_do_iter_var_t (b, ffelex_token_use (var_token));
- break;
- }
- /* Fall through. */
- case FFEBLD_opANY:
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
- break;
-
- default:
- assert ("bad iter var" == NULL);
- break;
- }
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- if (incr == NULL)
- {
- incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
- ffebld_set_info (incr, ffeinfo_new
- (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT,
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- }
-
- start = ffeexpr_convert_expr (start, start_token, var, var_token,
- FFEEXPR_contextLET);
- end = ffeexpr_convert_expr (end, end_token, var, var_token,
- FFEEXPR_contextLET);
- incr = ffeexpr_convert_expr (incr, incr_token, var, var_token,
- FFEEXPR_contextLET);
-
-#if 0
- if ((ffebld_op (incr) == FFEBLD_opCONTER)
- && (ffebld_constant_is_zero (ffebld_conter (incr))))
- {
- ffebad_start (FFEBAD_DO_STEP_ZERO);
- ffebad_here (0, ffelex_token_where_line (incr_token),
- ffelex_token_where_column (incr_token));
- ffebad_string ("Iterative DO loop");
- ffebad_finish ();
- }
-#endif
-
- ffestd_R819A (construct_name, NULL, var,
- start, start_token,
- end, end_token,
- incr, incr_token);
-}
-
-/* ffestc_R820B -- Nonlabeled DO WHILE statement
-
- ffestc_R820B(construct_name,expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R820B (ffelexToken construct_name, ffebld expr,
- ffelexToken expr_token UNUSED)
-{
- ffestw b;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_exec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, b);
- ffestw_set_state (b, FFESTV_stateDO);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_do_);
- ffestw_set_label (b, NULL);
- ffestw_set_do_iter_var (b, NULL);
- ffestw_set_do_iter_var_t (b, NULL);
-
- if (construct_name == NULL)
- ffestw_set_name (b, NULL);
- else
- {
- ffestw_set_name (b, ffelex_token_use (construct_name));
-
- s = ffesymbol_declare_local (construct_name, FALSE);
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindCONSTRUCT,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- s = ffecom_sym_learned (s);
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, construct_name);
- }
-
- ffestd_R819B (construct_name, NULL, expr);
-}
-
-/* ffestc_R825 -- END DO statement
-
- ffestc_R825(name_token);
-
- Make sure ffestc_kind_ identifies a DO block. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the DO block. */
-
-void
-ffestc_R825 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_do_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (name == NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) != NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NAMED);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- }
- else
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_CONSTRUCT_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name,
- ffestw_name (ffestw_stack_top ()))
- != 0)
- {
- ffebad_start (FFEBAD_CONSTRUCT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- if (ffesta_label_token == NULL)
- { /* If top of stack has label, its an error! */
- if (ffestw_label (ffestw_stack_top ()) != NULL)
- {
- ffebad_start (FFEBAD_DO_HAD_LABEL);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestc_shriek_do_ (TRUE);
-
- ffestc_try_shriek_do_ ();
-
- return;
- }
-
- ffestd_R825 (name);
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R834 -- CYCLE statement
-
- ffestc_R834(name_token);
-
- Handle a CYCLE within a loop. */
-
-void
-ffestc_R834 (ffelexToken name)
-{
- ffestw block;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (name == NULL)
- block = ffestw_top_do (ffestw_stack_top ());
- else
- { /* Search for name. */
- for (block = ffestw_top_do (ffestw_stack_top ());
- (block != NULL) && (ffestw_blocknum (block) != 0);
- block = ffestw_top_do (ffestw_previous (block)))
- {
- if ((ffestw_name (block) != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
- break;
- }
- if ((block == NULL) || (ffestw_blocknum (block) == 0))
- {
- block = ffestw_top_do (ffestw_stack_top ());
- ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- }
-
- ffestd_R834 (block);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) CYCLE". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R835 -- EXIT statement
-
- ffestc_R835(name_token);
-
- Handle a EXIT within a loop. */
-
-void
-ffestc_R835 (ffelexToken name)
-{
- ffestw block;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actiondo_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (name == NULL)
- block = ffestw_top_do (ffestw_stack_top ());
- else
- { /* Search for name. */
- for (block = ffestw_top_do (ffestw_stack_top ());
- (block != NULL) && (ffestw_blocknum (block) != 0);
- block = ffestw_top_do (ffestw_previous (block)))
- {
- if ((ffestw_name (block) != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (block)) == 0))
- break;
- }
- if ((block == NULL) || (ffestw_blocknum (block) == 0))
- {
- block = ffestw_top_do (ffestw_stack_top ());
- ffebad_start (FFEBAD_CONSTRUCT_NO_DO_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- }
-
- ffestd_R835 (block);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) EXIT". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R836 -- GOTO statement
-
- ffestc_R836(label_token);
-
- Make sure label_token identifies a valid label for a GOTO. Update
- that label's info to indicate it is the target of a GOTO. */
-
-void
-ffestc_R836 (ffelexToken label_token)
-{
- ffelab label;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (ffestc_labelref_is_branch_ (label_token, &label))
- ffestd_R836 (label);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) GOTO 100". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R837 -- Computed GOTO statement
-
- ffestc_R837(label_list,expr,expr_token);
-
- Make sure label_list identifies valid labels for a GOTO. Update
- each label's info to indicate it is the target of a GOTO. */
-
-void
-ffestc_R837 (ffesttTokenList label_toks, ffebld expr,
- ffelexToken expr_token UNUSED)
-{
- ffesttTokenItem ti;
- bool ok = TRUE;
- int i;
- ffelab *labels;
-
- assert (label_toks != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
- sizeof (*labels)
- * ffestt_tokenlist_count (label_toks));
-
- for (ti = label_toks->first, i = 0;
- ti != (ffesttTokenItem) &label_toks->first;
- ti = ti->next, ++i)
- {
- if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
- {
- ok = FALSE;
- break;
- }
- }
-
- if (ok)
- ffestd_R837 (labels, ffestt_tokenlist_count (label_toks), expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R838 -- ASSIGN statement
-
- ffestc_R838(label_token,target_variable,target_token);
-
- Make sure label_token identifies a valid label for an assignment. Update
- that label's info to indicate it is the source of an assignment. Update
- target_variable's info to indicate it is the target the assignment of that
- label. */
-
-void
-ffestc_R838 (ffelexToken label_token, ffebld target,
- ffelexToken target_token UNUSED)
-{
- ffelab label;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- /* Mark target symbol as target of an ASSIGN. */
- if (ffebld_op (target) == FFEBLD_opSYMTER)
- ffesymbol_set_assigned (ffebld_symter (target), TRUE);
-
- if (ffestc_labelref_is_assignable_ (label_token, &label))
- ffestd_R838 (label, target);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R839 -- Assigned GOTO statement
-
- ffestc_R839(target,target_token,label_list);
-
- Make sure label_list identifies valid labels for a GOTO. Update
- each label's info to indicate it is the target of a GOTO. */
-
-void
-ffestc_R839 (ffebld target, ffelexToken target_token UNUSED,
- ffesttTokenList label_toks)
-{
- ffesttTokenItem ti;
- bool ok = TRUE;
- int i;
- ffelab *labels;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (label_toks == NULL)
- {
- labels = NULL;
- i = 0;
- }
- else
- {
- labels = malloc_new_kp (ffesta_output_pool, "FFESTC labels",
- sizeof (*labels) * ffestt_tokenlist_count (label_toks));
-
- for (ti = label_toks->first, i = 0;
- ti != (ffesttTokenItem) &label_toks->first;
- ti = ti->next, ++i)
- {
- if (!ffestc_labelref_is_branch_ (ti->t, &labels[i]))
- {
- ok = FALSE;
- break;
- }
- }
- }
-
- if (ok)
- ffestd_R839 (target, labels, i);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) GOTO I". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R840 -- Arithmetic IF statement
-
- ffestc_R840(expr,expr_token,neg,zero,pos);
-
- Make sure the labels are valid; implement. */
-
-void
-ffestc_R840 (ffebld expr, ffelexToken expr_token UNUSED,
- ffelexToken neg_token, ffelexToken zero_token,
- ffelexToken pos_token)
-{
- ffelab neg;
- ffelab zero;
- ffelab pos;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- if (ffestc_labelref_is_branch_ (neg_token, &neg)
- && ffestc_labelref_is_branch_ (zero_token, &zero)
- && ffestc_labelref_is_branch_ (pos_token, &pos))
- ffestd_R840 (expr, neg, zero, pos);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) GOTO (100,200,300), I". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R841 -- CONTINUE statement
-
- ffestc_R841(); */
-
-void
-ffestc_R841 ()
-{
- ffestc_check_simple_ ();
-
- if (ffestc_order_actionwhere_ () != FFESTC_orderOK_)
- return;
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
-#if FFESTR_F90
- case FFESTV_stateWHERE:
- case FFESTV_stateWHERETHEN:
- ffestc_labeldef_useless_ ();
-
- ffestd_R841 (TRUE);
-
- /* It's okay that we call ffestc_labeldef_branch_end_ () below,
- since that will be a no-op after calling _useless_ () above. */
- break;
-#endif
-
- default:
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R841 (FALSE);
-
- break;
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R842 -- STOP statement
-
- ffestc_R842(expr,expr_token);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
-
-void
-ffestc_R842 (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- ffestd_R842 (expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) STOP". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R843 -- PAUSE statement
-
- ffestc_R843(expr,expr_token);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
-
-void
-ffestc_R843 (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R843 (expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R904 -- OPEN statement
-
- ffestc_R904();
-
- Make sure an OPEN is valid in the current context, and implement it. */
-
-void
-ffestc_R904 ()
-{
- int i;
- int expect_file;
- static const char *const status_strs[] =
- {
- "New",
- "Old",
- "Replace",
- "Scratch",
- "Unknown"
- };
- static const char *const access_strs[] =
- {
- "Append",
- "Direct",
- "Keyed",
- "Sequential"
- };
- static const char *const blank_strs[] =
- {
- "Null",
- "Zero"
- };
- static const char *const carriagecontrol_strs[] =
- {
- "Fortran",
- "List",
- "None"
- };
- static const char *const dispose_strs[] =
- {
- "Delete",
- "Keep",
- "Print",
- "Print/Delete",
- "Save",
- "Submit",
- "Submit/Delete"
- };
- static const char *const form_strs[] =
- {
- "Formatted",
- "Unformatted"
- };
- static const char *const organization_strs[] =
- {
- "Indexed",
- "Relative",
- "Sequential"
- };
- static const char *const position_strs[] =
- {
- "Append",
- "AsIs",
- "Rewind"
- };
- static const char *const action_strs[] =
- {
- "Read",
- "ReadWrite",
- "Write"
- };
- static const char *const delim_strs[] =
- {
- "Apostrophe",
- "None",
- "Quote"
- };
- static const char *const recordtype_strs[] =
- {
- "Fixed",
- "Segmented",
- "Stream",
- "Stream_CR",
- "Stream_LF",
- "Variable"
- };
- static const char *const pad_strs[] =
- {
- "No",
- "Yes"
- };
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.open.open_spec[FFESTP_openixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.open.open_spec[FFESTP_openixUNIT]))
- {
- i = ffestc_subr_binsrch_ (status_strs,
- ARRAY_SIZE (status_strs),
- &ffestp_file.open.open_spec[FFESTP_openixSTATUS],
- "NEW, OLD, REPLACE, SCRATCH, or UNKNOWN");
- switch (i)
- {
- case 0: /* Unknown. */
- case 5: /* UNKNOWN. */
- expect_file = 2; /* Unknown, don't care about FILE=. */
- break;
-
- case 1: /* NEW. */
- case 2: /* OLD. */
- if (ffe_is_pedantic ())
- expect_file = 1; /* Yes, need FILE=. */
- else
- expect_file = 2; /* f2clib doesn't care about FILE=. */
- break;
-
- case 3: /* REPLACE. */
- expect_file = 1; /* Yes, need FILE=. */
- break;
-
- case 4: /* SCRATCH. */
- expect_file = 0; /* No, disallow FILE=. */
- break;
-
- default:
- assert ("invalid _binsrch_ result" == NULL);
- expect_file = 0;
- break;
- }
- if ((expect_file == 0)
- && ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present);
- if (ffestp_file.open.open_spec[FFESTP_openixFILE].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixFILE].kw),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixFILE].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixFILE].value),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixFILE].value));
- }
- assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
- if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
- }
- ffebad_finish ();
- }
- else if ((expect_file == 1)
- && !ffestp_file.open.open_spec[FFESTP_openixFILE].kw_or_val_present)
- {
- ffebad_start (FFEBAD_MISSING_SPECIFIER);
- assert (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_or_val_present);
- if (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value),
- ffelex_token_where_column
- (ffestp_file.open.open_spec[FFESTP_openixSTATUS].value));
- }
- ffebad_string ("FILE=");
- ffebad_finish ();
- }
-
- ffestc_subr_binsrch_ (access_strs, ARRAY_SIZE (access_strs),
- &ffestp_file.open.open_spec[FFESTP_openixACCESS],
- "APPEND, DIRECT, KEYED, or SEQUENTIAL");
-
- ffestc_subr_binsrch_ (blank_strs, ARRAY_SIZE (blank_strs),
- &ffestp_file.open.open_spec[FFESTP_openixBLANK],
- "NULL or ZERO");
-
- ffestc_subr_binsrch_ (carriagecontrol_strs,
- ARRAY_SIZE (carriagecontrol_strs),
- &ffestp_file.open.open_spec[FFESTP_openixCARRIAGECONTROL],
- "FORTRAN, LIST, or NONE");
-
- ffestc_subr_binsrch_ (dispose_strs, ARRAY_SIZE (dispose_strs),
- &ffestp_file.open.open_spec[FFESTP_openixDISPOSE],
- "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
-
- ffestc_subr_binsrch_ (form_strs, ARRAY_SIZE (form_strs),
- &ffestp_file.open.open_spec[FFESTP_openixFORM],
- "FORMATTED or UNFORMATTED");
-
- ffestc_subr_binsrch_ (organization_strs, ARRAY_SIZE (organization_strs),
- &ffestp_file.open.open_spec[FFESTP_openixORGANIZATION],
- "INDEXED, RELATIVE, or SEQUENTIAL");
-
- ffestc_subr_binsrch_ (position_strs, ARRAY_SIZE (position_strs),
- &ffestp_file.open.open_spec[FFESTP_openixPOSITION],
- "APPEND, ASIS, or REWIND");
-
- ffestc_subr_binsrch_ (action_strs, ARRAY_SIZE (action_strs),
- &ffestp_file.open.open_spec[FFESTP_openixACTION],
- "READ, READWRITE, or WRITE");
-
- ffestc_subr_binsrch_ (delim_strs, ARRAY_SIZE (delim_strs),
- &ffestp_file.open.open_spec[FFESTP_openixDELIM],
- "APOSTROPHE, NONE, or QUOTE");
-
- ffestc_subr_binsrch_ (recordtype_strs, ARRAY_SIZE (recordtype_strs),
- &ffestp_file.open.open_spec[FFESTP_openixRECORDTYPE],
- "FIXED, SEGMENTED, STREAM, STREAM_CR, STREAM_LF, or VARIABLE");
-
- ffestc_subr_binsrch_ (pad_strs, ARRAY_SIZE (pad_strs),
- &ffestp_file.open.open_spec[FFESTP_openixPAD],
- "NO or YES");
-
- ffestd_R904 ();
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R907 -- CLOSE statement
-
- ffestc_R907();
-
- Make sure a CLOSE is valid in the current context, and implement it. */
-
-void
-ffestc_R907 ()
-{
- static const char *const status_strs[] =
- {
- "Delete",
- "Keep",
- "Print",
- "Print/Delete",
- "Save",
- "Submit",
- "Submit/Delete"
- };
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.close.close_spec[FFESTP_closeixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.close.close_spec[FFESTP_closeixUNIT]))
- {
- ffestc_subr_binsrch_ (status_strs, ARRAY_SIZE (status_strs),
- &ffestp_file.close.close_spec[FFESTP_closeixSTATUS],
- "DELETE, KEEP, PRINT, PRINT/DELETE, SAVE, SUBMIT, or SUBMIT/DELETE");
-
- ffestd_R907 ();
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R909_start -- READ(...) statement list begin
-
- ffestc_R909_start(FALSE);
-
- Verify that READ is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R909_start (bool only_format)
-{
- ffestvUnit unit;
- ffestvFormat format;
- bool rec;
- bool key;
- ffestpReadIx keyn;
- ffestpReadIx spec1;
- ffestpReadIx spec2;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_format_
- (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.read.read_spec[FFESTP_readixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- if (only_format)
- {
- ffestd_R909_start (TRUE, FFESTV_unitNONE, format, FALSE, FALSE);
-
- ffestc_ok_ = TRUE;
- return;
- }
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.read.read_spec[FFESTP_readixEOR])
- || !ffestc_subr_is_branch_
- (&ffestp_file.read.read_spec[FFESTP_readixERR])
- || !ffestc_subr_is_branch_
- (&ffestp_file.read.read_spec[FFESTP_readixEND]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- unit = ffestc_subr_unit_
- (&ffestp_file.read.read_spec[FFESTP_readixUNIT]);
- if (unit == FFESTV_unitNONE)
- {
- ffebad_start (FFEBAD_NO_UNIT_SPEC);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
-
- rec = ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present;
-
- if (ffestp_file.read.read_spec[FFESTP_readixKEYEQ].kw_or_val_present)
- {
- key = TRUE;
- keyn = spec1 = FFESTP_readixKEYEQ;
- }
- else
- {
- key = FALSE;
- keyn = spec1 = FFESTP_readix;
- }
-
- if (ffestp_file.read.read_spec[FFESTP_readixKEYGT].kw_or_val_present)
- {
- if (key)
- {
- spec2 = FFESTP_readixKEYGT;
- whine: /* :::::::::::::::::::: */
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.read.read_spec[spec1].kw_or_val_present);
- if (ffestp_file.read.read_spec[spec1].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].value),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].value));
- }
- assert (ffestp_file.read.read_spec[spec2].kw_or_val_present);
- if (ffestp_file.read.read_spec[spec2].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec2].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec2].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec2].value),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec2].value));
- }
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
- key = TRUE;
- keyn = spec1 = FFESTP_readixKEYGT;
- }
-
- if (ffestp_file.read.read_spec[FFESTP_readixKEYGE].kw_or_val_present)
- {
- if (key)
- {
- spec2 = FFESTP_readixKEYGT;
- goto whine; /* :::::::::::::::::::: */
- }
- key = TRUE;
- keyn = FFESTP_readixKEYGT;
- }
-
- if (rec)
- {
- spec1 = FFESTP_readixREC;
- if (key)
- {
- spec2 = keyn;
- goto whine; /* :::::::::::::::::::: */
- }
- if (unit == FFESTV_unitCHAREXPR)
- {
- spec2 = FFESTP_readixUNIT;
- goto whine; /* :::::::::::::::::::: */
- }
- if ((format == FFESTV_formatASTERISK)
- || (format == FFESTV_formatNAMELIST))
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_readixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
- {
- spec2 = FFESTP_readixEND;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
- {
- spec2 = FFESTP_readixNULLS;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- else if (key)
- {
- spec1 = keyn;
- if (unit == FFESTV_unitCHAREXPR)
- {
- spec2 = FFESTP_readixUNIT;
- goto whine; /* :::::::::::::::::::: */
- }
- if ((format == FFESTV_formatASTERISK)
- || (format == FFESTV_formatNAMELIST))
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_readixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEND].kw_or_val_present)
- {
- spec2 = FFESTP_readixEND;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
- {
- spec2 = FFESTP_readixEOR;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
- {
- spec2 = FFESTP_readixNULLS;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixREC].kw_or_val_present)
- {
- spec2 = FFESTP_readixREC;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
- {
- spec2 = FFESTP_readixSIZE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- else
- { /* Sequential/Internal. */
- if (unit == FFESTV_unitCHAREXPR)
- { /* Internal file. */
- spec1 = FFESTP_readixUNIT;
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_readixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw_or_val_present)
- { /* ADVANCE= specified. */
- spec1 = FFESTP_readixADVANCE;
- if (format == FFESTV_formatNONE)
- {
- ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- ffebad_finish ();
-
- ffestc_ok_ = FALSE;
- return;
- }
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixEOR].kw_or_val_present)
- { /* EOR= specified. */
- spec1 = FFESTP_readixEOR;
- if (ffestc_subr_speccmp_ ("No",
- &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
- NULL, NULL) != 0)
- {
- goto whine_advance; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixNULLS].kw_or_val_present)
- { /* NULLS= specified. */
- spec1 = FFESTP_readixNULLS;
- if (format != FFESTV_formatASTERISK)
- {
- spec2 = FFESTP_readixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.read.read_spec[FFESTP_readixSIZE].kw_or_val_present)
- { /* SIZE= specified. */
- spec1 = FFESTP_readixSIZE;
- if (ffestc_subr_speccmp_ ("No",
- &ffestp_file.read.read_spec[FFESTP_readixADVANCE],
- NULL, NULL) != 0)
- {
- whine_advance: /* :::::::::::::::::::: */
- if (ffestp_file.read.read_spec[FFESTP_readixADVANCE]
- .kw_or_val_present)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[FFESTP_readixADVANCE].kw));
- ffebad_finish ();
- }
- else
- {
- ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.read.read_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.read.read_spec[spec1].kw));
- ffebad_finish ();
- }
-
- ffestc_ok_ = FALSE;
- return;
- }
- }
- }
-
- if (unit == FFESTV_unitCHAREXPR)
- ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
- else
- ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
-
- ffestd_R909_start (FALSE, unit, format, rec, key);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R909_item -- READ statement i/o item
-
- ffestc_R909_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R909_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_R909_item (expr, expr_token);
-}
-
-/* ffestc_R909_finish -- READ statement list complete
-
- ffestc_R909_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R909_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R909_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R910_start -- WRITE(...) statement list begin
-
- ffestc_R910_start();
-
- Verify that WRITE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R910_start ()
-{
- ffestvUnit unit;
- ffestvFormat format;
- bool rec;
- ffestpWriteIx spec1;
- ffestpWriteIx spec2;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.write.write_spec[FFESTP_writeixEOR])
- || !ffestc_subr_is_branch_
- (&ffestp_file.write.write_spec[FFESTP_writeixERR])
- || !ffestc_subr_is_format_
- (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.write.write_spec[FFESTP_writeixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- unit = ffestc_subr_unit_
- (&ffestp_file.write.write_spec[FFESTP_writeixUNIT]);
- if (unit == FFESTV_unitNONE)
- {
- ffebad_start (FFEBAD_NO_UNIT_SPEC);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
-
- rec = ffestp_file.write.write_spec[FFESTP_writeixREC].kw_or_val_present;
-
- if (rec)
- {
- spec1 = FFESTP_writeixREC;
- if (unit == FFESTV_unitCHAREXPR)
- {
- spec2 = FFESTP_writeixUNIT;
- whine: /* :::::::::::::::::::: */
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.write.write_spec[spec1].kw_or_val_present);
- if (ffestp_file.write.write_spec[spec1].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].value),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].value));
- }
- assert (ffestp_file.write.write_spec[spec2].kw_or_val_present);
- if (ffestp_file.write.write_spec[spec2].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec2].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec2].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec2].value),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec2].value));
- }
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
- if ((format == FFESTV_formatASTERISK)
- || (format == FFESTV_formatNAMELIST))
- {
- spec2 = FFESTP_writeixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_writeixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- else
- { /* Sequential/Indexed/Internal. */
- if (unit == FFESTV_unitCHAREXPR)
- { /* Internal file. */
- spec1 = FFESTP_writeixUNIT;
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_writeixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
- {
- spec2 = FFESTP_writeixADVANCE;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw_or_val_present)
- { /* ADVANCE= specified. */
- spec1 = FFESTP_writeixADVANCE;
- if (format == FFESTV_formatNONE)
- {
- ffebad_start (FFEBAD_MISSING_FORMAT_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- ffebad_finish ();
-
- ffestc_ok_ = FALSE;
- return;
- }
- if (format == FFESTV_formatNAMELIST)
- {
- spec2 = FFESTP_writeixFORMAT;
- goto whine; /* :::::::::::::::::::: */
- }
- }
- if (ffestp_file.write.write_spec[FFESTP_writeixEOR].kw_or_val_present)
- { /* EOR= specified. */
- spec1 = FFESTP_writeixEOR;
- if (ffestc_subr_speccmp_ ("No",
- &ffestp_file.write.write_spec[FFESTP_writeixADVANCE],
- NULL, NULL) != 0)
- {
- if (ffestp_file.write.write_spec[FFESTP_writeixADVANCE]
- .kw_or_val_present)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[FFESTP_writeixADVANCE].kw));
- ffebad_finish ();
- }
- else
- {
- ffebad_start (FFEBAD_MISSING_ADVANCE_SPEC);
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.write.write_spec[spec1].kw),
- ffelex_token_where_column
- (ffestp_file.write.write_spec[spec1].kw));
- ffebad_finish ();
- }
-
- ffestc_ok_ = FALSE;
- return;
- }
- }
- }
-
- if (unit == FFESTV_unitCHAREXPR)
- ffestc_iolist_context_ = FFEEXPR_contextIOLISTDF;
- else
- ffestc_iolist_context_ = FFEEXPR_contextIOLIST;
-
- ffestd_R910_start (unit, format, rec);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R910_item -- WRITE statement i/o item
-
- ffestc_R910_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R910_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_R910_item (expr, expr_token);
-}
-
-/* ffestc_R910_finish -- WRITE statement list complete
-
- ffestc_R910_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R910_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R910_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R911_start -- PRINT(...) statement list begin
-
- ffestc_R911_start();
-
- Verify that PRINT is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R911_start ()
-{
- ffestvFormat format;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_format_
- (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.print.print_spec[FFESTP_printixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- ffestd_R911_start (format);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R911_item -- PRINT statement i/o item
-
- ffestc_R911_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R911_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_R911_item (expr, expr_token);
-}
-
-/* ffestc_R911_finish -- PRINT statement list complete
-
- ffestc_R911_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R911_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R911_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R919 -- BACKSPACE statement
-
- ffestc_R919();
-
- Make sure a BACKSPACE is valid in the current context, and implement it. */
-
-void
-ffestc_R919 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_R919 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R920 -- ENDFILE statement
-
- ffestc_R920();
-
- Make sure a ENDFILE is valid in the current context, and implement it. */
-
-void
-ffestc_R920 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_R920 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R921 -- REWIND statement
-
- ffestc_R921();
-
- Make sure a REWIND is valid in the current context, and implement it. */
-
-void
-ffestc_R921 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_R921 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R923A -- INQUIRE statement (non-IOLENGTH version)
-
- ffestc_R923A();
-
- Make sure an INQUIRE is valid in the current context, and implement it. */
-
-void
-ffestc_R923A ()
-{
- bool by_file;
- bool by_unit;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.inquire.inquire_spec[FFESTP_inquireixERR]))
- {
- by_file = ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE]
- .kw_or_val_present;
- by_unit = ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT]
- .kw_or_val_present;
- if (by_file && by_unit)
- {
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present);
- if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw));
- }
- else
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value));
- }
- assert (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_or_val_present);
- if (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw_present)
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value),
- ffelex_token_where_column
- (ffestp_file.inquire.inquire_spec[FFESTP_inquireixFILE].value));
- }
- ffebad_finish ();
- }
- else if (!by_file && !by_unit)
- {
- ffebad_start (FFEBAD_MISSING_SPECIFIER);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_string ("UNIT= or FILE=");
- ffebad_finish ();
- }
- else
- ffestd_R923A (by_file);
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
-
- ffestc_R923B_start();
-
- Verify that INQUIRE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_R923B_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R923B_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R923B_item -- INQUIRE statement i/o item
-
- ffestc_R923B_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_R923B_item (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R923B_item (expr);
-}
-
-/* ffestc_R923B_finish -- INQUIRE statement list complete
-
- ffestc_R923B_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R923B_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R923B_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R1001 -- FORMAT statement
-
- ffestc_R1001(format_list);
-
- Make sure format_list is valid. Update label's info to indicate it is a
- FORMAT label, and (perhaps) warn if there is no label! */
-
-void
-ffestc_R1001 (ffesttFormatList f)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_format_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_format_ ();
-
- ffestd_R1001 (f);
-}
-
-/* ffestc_R1102 -- PROGRAM statement
-
- ffestc_R1102(name_token);
-
- Make sure ffestc_kind_ identifies an empty block. Make sure name_token
- gives a valid name. Implement the beginning of a main program. */
-
-void
-ffestc_R1102 (ffelexToken name)
-{
- ffestw b;
- ffesymbol s;
-
- assert (name != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_unit_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_statePROGRAM0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_end_program_);
-
- ffestw_set_name (b, ffelex_token_use (name));
-
- s = ffesymbol_declare_programunit (name,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindPROGRAM,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, name);
-
- ffestd_R1102 (s, name);
-}
-
-/* ffestc_R1103 -- END PROGRAM statement
-
- ffestc_R1103(name_token);
-
- Make sure ffestc_kind_ identifies the current kind of program unit. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
-
-void
-ffestc_R1103 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_program_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_PROGRAM_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- ffestc_shriek_end_program_ (TRUE);
-}
-
-/* ffestc_R1105 -- MODULE statement
-
- ffestc_R1105(name_token);
-
- Make sure ffestc_kind_ identifies an empty block. Make sure name_token
- gives a valid name. Implement the beginning of a module. */
-
-#if FFESTR_F90
-void
-ffestc_R1105 (ffelexToken name)
-{
- ffestw b;
-
- assert (name != NULL);
-
- ffestc_check_simple_ ();
- if (ffestc_order_unit_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateMODULE0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_module_);
- ffestw_set_name (b, ffelex_token_use (name));
-
- ffestd_R1105 (name);
-}
-
-/* ffestc_R1106 -- END MODULE statement
-
- ffestc_R1106(name_token);
-
- Make sure ffestc_kind_ identifies the current kind of program unit. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
-
-void
-ffestc_R1106 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_module_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
-
- ffestc_shriek_module_ (TRUE);
-}
-
-/* ffestc_R1107_start -- USE statement list begin
-
- ffestc_R1107_start();
-
- Verify that USE is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R1107_start (ffelexToken name, bool only)
-{
- ffestc_check_start_ ();
- if (ffestc_order_use_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R1107_start (name, only);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R1107_item -- USE statement for name
-
- ffestc_R1107_item(local_token,use_token);
-
- Make sure name_token identifies a valid object to be USEed. local_token
- may be NULL if _start_ was called with only==TRUE. */
-
-void
-ffestc_R1107_item (ffelexToken local, ffelexToken use)
-{
- ffestc_check_item_ ();
- assert (use != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R1107_item (local, use);
-}
-
-/* ffestc_R1107_finish -- USE statement list complete
-
- ffestc_R1107_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R1107_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R1107_finish ();
-}
-
-#endif
-/* ffestc_R1111 -- BLOCK DATA statement
-
- ffestc_R1111(name_token);
-
- Make sure ffestc_kind_ identifies no current program unit. If not
- NULL, make sure name_token gives a valid name. Implement the beginning
- of a block data program unit. */
-
-void
-ffestc_R1111 (ffelexToken name)
-{
- ffestw b;
- ffesymbol s;
-
- ffestc_check_simple_ ();
- if (ffestc_order_unit_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateBLOCKDATA0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_blockdata_);
-
- if (name == NULL)
- ffestw_set_name (b, NULL);
- else
- ffestw_set_name (b, ffelex_token_use (name));
-
- s = ffesymbol_declare_blockdataunit (name,
- ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
-
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindBLOCKDATA,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffesymbol_signal_unreported (s);
- }
- else
- ffesymbol_error (s, name);
-
- ffestd_R1111 (s, name);
-}
-
-/* ffestc_R1112 -- END BLOCK DATA statement
-
- ffestc_R1112(name_token);
-
- Make sure ffestc_kind_ identifies the current kind of program unit. If not
- NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
-
-void
-ffestc_R1112 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_blockdata_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (name != NULL)
- {
- if (ffestw_name (ffestw_stack_top ()) == NULL)
- {
- ffebad_start (FFEBAD_BLOCKDATA_NOT_NAMED);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
- else if (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0)
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
- }
-
- ffestc_shriek_blockdata_ (TRUE);
-}
-
-/* ffestc_R1202 -- INTERFACE statement
-
- ffestc_R1202(operator,defined_name);
-
- Make sure ffestc_kind_ identifies an INTERFACE block.
- Implement the end of the current interface.
-
- 15-May-90 JCB 1.1
- Allow no operator or name to mean INTERFACE by itself; missed this
- valid form when originally doing syntactic analysis code. */
-
-#if FFESTR_F90
-void
-ffestc_R1202 (ffestpDefinedOperator operator, ffelexToken name)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_interfacespec_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateINTERFACE0);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_interface_);
-
- if ((operator == FFESTP_definedoperatorNone) && (name == NULL))
- ffestw_set_substate (b, 0); /* No generic-spec, so disallow MODULE
- PROCEDURE. */
- else
- ffestw_set_substate (b, 1); /* MODULE PROCEDURE ok. */
-
- ffestd_R1202 (operator, name);
-
- ffe_init_4 ();
-}
-
-/* ffestc_R1203 -- END INTERFACE statement
-
- ffestc_R1203();
-
- Make sure ffestc_kind_ identifies an INTERFACE block.
- Implement the end of the current interface. */
-
-void
-ffestc_R1203 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_interface_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_shriek_interface_ (TRUE);
-
- ffe_terminate_4 ();
-}
-
-/* ffestc_R1205_start -- MODULE PROCEDURE statement list begin
-
- ffestc_R1205_start();
-
- Verify that MODULE PROCEDURE is valid here, and begin accepting items in
- the list. */
-
-void
-ffestc_R1205_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_interface_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) == 0)
- {
- ffebad_start (FFEBAD_INVALID_MODULE_PROCEDURE);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
- }
-
- if (ffestw_state (ffestw_stack_top ()) == FFESTV_stateINTERFACE0)
- {
- ffestw_update (NULL); /* Update state line/col info. */
- ffestw_set_state (ffestw_stack_top (), FFESTV_stateINTERFACE1);
- }
-
- ffestd_R1205_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R1205_item -- MODULE PROCEDURE statement for name
-
- ffestc_R1205_item(name_token);
-
- Make sure name_token identifies a valid object to be MODULE PROCEDUREed. */
-
-void
-ffestc_R1205_item (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_R1205_item (name);
-}
-
-/* ffestc_R1205_finish -- MODULE PROCEDURE statement list complete
-
- ffestc_R1205_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R1205_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R1205_finish ();
-}
-
-#endif
-/* ffestc_R1207_start -- EXTERNAL statement list begin
-
- ffestc_R1207_start();
-
- Verify that EXTERNAL is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R1207_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R1207_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R1207_item -- EXTERNAL statement for name
-
- ffestc_R1207_item(name_token);
-
- Make sure name_token identifies a valid object to be EXTERNALd. */
-
-void
-ffestc_R1207_item (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!(sa & ~(FFESYMBOL_attrsDUMMY
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsEXTERNAL;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_explicitwhere (s, TRUE);
- ffesymbol_reference (s, name, FALSE);
- ffesymbol_signal_unreported (s);
- }
-
- ffestd_R1207_item (name);
-}
-
-/* ffestc_R1207_finish -- EXTERNAL statement list complete
-
- ffestc_R1207_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R1207_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R1207_finish ();
-}
-
-/* ffestc_R1208_start -- INTRINSIC statement list begin
-
- ffestc_R1208_start();
-
- Verify that INTRINSIC is valid here, and begin accepting items in the list. */
-
-void
-ffestc_R1208_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_R1208_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R1208_item -- INTRINSIC statement for name
-
- ffestc_R1208_item(name_token);
-
- Make sure name_token identifies a valid object to be INTRINSICd. */
-
-void
-ffestc_R1208_item (ffelexToken name)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffeintrinGen gen;
- ffeintrinSpec spec;
- ffeintrinImp imp;
-
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- s = ffesymbol_declare_local (name, TRUE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = sa;
- else if (!(sa & ~FFESYMBOL_attrsTYPE))
- {
- if (ffeintrin_is_intrinsic (ffelex_token_text (name), name, TRUE,
- &gen, &spec, &imp)
- && ((imp == FFEINTRIN_impNONE)
-#if 0 /* Don't bother with this for now. */
- || ((ffeintrin_basictype (spec)
- == ffesymbol_basictype (s))
- && (ffeintrin_kindtype (spec)
- == ffesymbol_kindtype (s)))
-#else
- || 1
-#endif
- || !(sa & FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsINTRINSIC;
- else
- na = FFESYMBOL_attrsetNONE;
- }
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- ffesymbol_error (s, name);
- else if (!(na & FFESYMBOL_attrsANY))
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_generic (s, gen);
- ffesymbol_set_specific (s, spec);
- ffesymbol_set_implementation (s, imp);
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereINTRINSIC,
- ffesymbol_size (s)));
- ffesymbol_set_explicitwhere (s, TRUE);
- ffesymbol_reference (s, name, TRUE);
- }
-
- ffesymbol_signal_unreported (s);
-
- ffestd_R1208_item (name);
-}
-
-/* ffestc_R1208_finish -- INTRINSIC statement list complete
-
- ffestc_R1208_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_R1208_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_R1208_finish ();
-}
-
-/* ffestc_R1212 -- CALL statement
-
- ffestc_R1212(expr,expr_token);
-
- Make sure statement is valid here; implement. */
-
-void
-ffestc_R1212 (ffebld expr, ffelexToken expr_token UNUSED)
-{
- ffebld item; /* ITEM. */
- ffebld labexpr; /* LABTOK=>LABTER. */
- ffelab label;
- bool ok; /* TRUE if all LABTOKs were ok. */
- bool ok1; /* TRUE if a particular LABTOK is ok. */
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffebld_op (expr) != FFEBLD_opSUBRREF)
- ffestd_R841 (FALSE); /* CONTINUE. */
- else
- {
- ok = TRUE;
-
- for (item = ffebld_right (expr);
- item != NULL;
- item = ffebld_trail (item))
- {
- if (((labexpr = ffebld_head (item)) != NULL)
- && (ffebld_op (labexpr) == FFEBLD_opLABTOK))
- {
- ok1 = ffestc_labelref_is_branch_ (ffebld_labtok (labexpr),
- &label);
- ffelex_token_kill (ffebld_labtok (labexpr));
- if (!ok1)
- {
- label = NULL;
- ok = FALSE;
- }
- ffebld_set_op (labexpr, FFEBLD_opLABTER);
- ffebld_set_labter (labexpr, label);
- }
- }
-
- if (ok)
- ffestd_R1212 (expr);
- }
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R1213 -- Defined assignment statement
-
- ffestc_R1213(dest_expr,source_expr,source_token);
-
- Make sure the assignment is valid. */
-
-#if FFESTR_F90
-void
-ffestc_R1213 (ffebld dest, ffebld source, ffelexToken source_token)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_R1213 (dest, source);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-#endif
-/* ffestc_R1219 -- FUNCTION statement
-
- ffestc_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
- recursive);
-
- Make sure statement is valid here, register arguments for the
- function name, and so on.
-
- 06-Apr-90 JCB 2.0
- Added the kind, len, and recursive arguments. */
-
-void
-ffestc_R1219 (ffelexToken funcname, ffesttTokenList args,
- ffelexToken final UNUSED, ffestpType type, ffebld kind,
- ffelexToken kindt, ffebld len, ffelexToken lent,
- ffelexToken recursive, ffelexToken result)
-{
- ffestw b;
- ffesymbol s;
- ffesymbol fs; /* FUNCTION symbol when dealing with RESULT
- symbol. */
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- ffelexToken res;
- bool separate_result;
-
- assert ((funcname != NULL)
- && (ffelex_token_type (funcname) == FFELEX_typeNAME));
-
- ffestc_check_simple_ ();
- if (ffestc_order_iface_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- ffesta_is_entry_valid =
- (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateFUNCTION0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_function_);
- ffestw_set_name (b, ffelex_token_use (funcname));
-
- if (type == FFESTP_typeNone)
- {
- ffestc_local_.decl.basic_type = FFEINFO_basictypeNONE;
- ffestc_local_.decl.kind_type = FFEINFO_kindtypeNONE;
- ffestc_local_.decl.size = FFETARGET_charactersizeNONE;
- }
- else
- {
- ffestc_establish_declstmt_ (type, ffesta_tokens[0],
- kind, kindt, len, lent);
- ffestc_establish_declinfo_ (NULL, NULL, NULL, NULL);
- }
-
- separate_result = (result != NULL)
- && (ffelex_token_strcmp (funcname, result) != 0);
-
- if (separate_result)
- fs = ffesymbol_declare_funcnotresunit (funcname); /* Global/local. */
- else
- fs = ffesymbol_declare_funcunit (funcname); /* Global only. */
-
- if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_signal_unreported (fs);
-
- /* Note that .basic_type and .kind_type might be NONE here. */
-
- ffesymbol_set_info (fs,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- 0,
- FFEINFO_kindFUNCTION,
- FFEINFO_whereLOCAL,
- ffestc_local_.decl.size));
-
- /* Check whether the type info fits the filewide expectations;
- set ok flag accordingly. */
-
- ffesymbol_reference (fs, funcname, FALSE);
- if (ffesymbol_attrs (fs) & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
- ffestc_parent_ok_ = TRUE;
- }
- else
- {
- if (ffesymbol_kind (fs) != FFEINFO_kindANY)
- ffesymbol_error (fs, funcname);
- ffestc_parent_ok_ = FALSE;
- }
-
- if (ffestc_parent_ok_)
- {
- ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
- ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
- }
-
- if (result == NULL)
- res = funcname;
- else
- res = result;
-
- s = ffesymbol_declare_funcresult (res);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (ffesymbol_state (s) != FFESYMBOL_stateNONE)
- na = FFESYMBOL_attrsetNONE;
- else
- {
- na = FFESYMBOL_attrsRESULT;
- if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
- {
- na |= FFESYMBOL_attrsTYPE;
- if ((ffestc_local_.decl.basic_type == FFEINFO_basictypeCHARACTER)
- && (ffestc_local_.decl.size == FFETARGET_charactersizeNONE))
- na |= FFESYMBOL_attrsANYLEN;
- }
- }
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if ((na & ~FFESYMBOL_attrsANY) == FFESYMBOL_attrsetNONE)
- {
- if (!(na & FFESYMBOL_attrsANY))
- ffesymbol_error (s, res);
- ffesymbol_set_funcresult (fs, NULL);
- ffesymbol_set_funcresult (s, NULL);
- ffestc_parent_ok_ = FALSE;
- }
- else
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- ffesymbol_set_funcresult (fs, s);
- ffesymbol_set_funcresult (s, fs);
- if (ffestc_local_.decl.basic_type != FFEINFO_basictypeNONE)
- {
- ffesymbol_set_info (s,
- ffeinfo_new (ffestc_local_.decl.basic_type,
- ffestc_local_.decl.kind_type,
- 0,
- FFEINFO_kindNONE,
- FFEINFO_whereNONE,
- ffestc_local_.decl.size));
- }
- }
-
- ffesymbol_signal_unreported (fs);
-
- ffestd_R1219 (fs, funcname, args, type, kind, kindt, len, lent,
- (recursive != NULL), result, separate_result);
-}
-
-/* ffestc_R1221 -- END FUNCTION statement
-
- ffestc_R1221(name_token);
-
- Make sure ffestc_kind_ identifies the current kind of program unit. If
- not NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
-
-void
-ffestc_R1221 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_function_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
-
- ffestc_shriek_function_ (TRUE);
-}
-
-/* ffestc_R1223 -- SUBROUTINE statement
-
- ffestc_R1223(subrname,arglist,ending_token,recursive_token);
-
- Make sure statement is valid here, register arguments for the
- subroutine name, and so on.
-
- 06-Apr-90 JCB 2.0
- Added the recursive argument. */
-
-void
-ffestc_R1223 (ffelexToken subrname, ffesttTokenList args,
- ffelexToken final, ffelexToken recursive)
-{
- ffestw b;
- ffesymbol s;
-
- assert ((subrname != NULL)
- && (ffelex_token_type (subrname) == FFELEX_typeNAME));
-
- ffestc_check_simple_ ();
- if (ffestc_order_iface_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestc_blocknum_ = 0;
- ffesta_is_entry_valid
- = (ffestw_state (ffestw_stack_top ()) == FFESTV_stateNIL);
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateSUBROUTINE0);
- ffestw_set_blocknum (b, ffestc_blocknum_++);
- ffestw_set_shriek (b, ffestc_shriek_subroutine_);
- ffestw_set_name (b, ffelex_token_use (subrname));
-
- s = ffesymbol_declare_subrunit (subrname);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindSUBROUTINE,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- ffestc_parent_ok_ = TRUE;
- }
- else
- {
- if (ffesymbol_kind (s) != FFEINFO_kindANY)
- ffesymbol_error (s, subrname);
- ffestc_parent_ok_ = FALSE;
- }
-
- if (ffestc_parent_ok_)
- {
- ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
- ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
- }
-
- ffesymbol_signal_unreported (s);
-
- ffestd_R1223 (s, subrname, args, final, (recursive != NULL));
-}
-
-/* ffestc_R1225 -- END SUBROUTINE statement
-
- ffestc_R1225(name_token);
-
- Make sure ffestc_kind_ identifies the current kind of program unit. If
- not NULL, make sure name_token gives the correct name. Implement the end
- of the current program unit. */
-
-void
-ffestc_R1225 (ffelexToken name)
-{
- ffestc_check_simple_ ();
- if (ffestc_order_subroutine_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_ ();
-
- if ((name != NULL)
- && (ffelex_token_strcmp (name, ffestw_name (ffestw_stack_top ())) != 0))
- {
- ffebad_start (FFEBAD_UNIT_WRONG_NAME);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_here (1, ffelex_token_where_line (ffestw_name (ffestw_stack_top ())),
- ffelex_token_where_column (ffestw_name (ffestw_stack_top ())));
- ffebad_finish ();
- }
-
- ffestc_shriek_subroutine_ (TRUE);
-}
-
-/* ffestc_R1226 -- ENTRY statement
-
- ffestc_R1226(entryname,arglist,ending_token);
-
- Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
- entry point name, and so on. */
-
-void
-ffestc_R1226 (ffelexToken entryname, ffesttTokenList args,
- ffelexToken final UNUSED)
-{
- ffesymbol s;
- ffesymbol fs;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
- bool in_spec; /* TRUE if further specification statements
- may follow, FALSE if executable stmts. */
- bool in_func; /* TRUE if ENTRY is a FUNCTION, not
- SUBROUTINE. */
-
- assert ((entryname != NULL)
- && (ffelex_token_type (entryname) == FFELEX_typeNAME));
-
- ffestc_check_simple_ ();
- if (ffestc_order_entry_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateFUNCTION1:
- case FFESTV_stateFUNCTION2:
- case FFESTV_stateFUNCTION3:
- in_func = TRUE;
- in_spec = TRUE;
- break;
-
- case FFESTV_stateFUNCTION4:
- in_func = TRUE;
- in_spec = FALSE;
- break;
-
- case FFESTV_stateSUBROUTINE1:
- case FFESTV_stateSUBROUTINE2:
- case FFESTV_stateSUBROUTINE3:
- in_func = FALSE;
- in_spec = TRUE;
- break;
-
- case FFESTV_stateSUBROUTINE4:
- in_func = FALSE;
- in_spec = FALSE;
- break;
-
- default:
- assert ("ENTRY not in FUNCTION or SUBROUTINE?" == NULL);
- in_func = FALSE;
- in_spec = FALSE;
- break;
- }
-
- if (in_func)
- fs = ffesymbol_declare_funcunit (entryname);
- else
- fs = ffesymbol_declare_subrunit (entryname);
-
- if (ffesymbol_state (fs) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (fs, FFESYMBOL_stateUNDERSTOOD);
- else
- {
- if (ffesymbol_kind (fs) != FFEINFO_kindANY)
- ffesymbol_error (fs, entryname);
- }
-
- ++ffestc_entry_num_;
-
- ffebld_init_list (&fs->dummy_args, &ffestc_local_.dummy.list_bottom);
- if (in_spec)
- ffestt_tokenlist_drive (args, ffestc_promote_dummy_);
- else
- ffestt_tokenlist_drive (args, ffestc_promote_execdummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
-
- if (in_func)
- {
- s = ffesymbol_declare_funcresult (entryname);
- ffesymbol_set_funcresult (fs, s);
- ffesymbol_set_funcresult (s, fs);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous
- declarations of or references to the object. */
-
- if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
- na = FFESYMBOL_attrsetNONE;
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!(sa & ~(FFESYMBOL_attrsANYLEN
- | FFESYMBOL_attrsTYPE)))
- na = sa | FFESYMBOL_attrsRESULT;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error
- cropped up; ANY means an old error to be ignored; otherwise,
- everything's ok, update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- {
- ffesymbol_error (s, entryname);
- ffestc_parent_ok_ = FALSE;
- }
- else if (na & FFESYMBOL_attrsANY)
- {
- ffestc_parent_ok_ = FALSE;
- }
- else
- {
- ffesymbol_set_attrs (s, na);
- if (ffesymbol_state (s) == FFESYMBOL_stateNONE)
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- else if (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)
- {
- ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
- ffesymbol_set_info (s,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindENTITY,
- FFEINFO_whereRESULT,
- ffesymbol_size (s)));
- ffesymbol_resolve_intrin (s);
- ffestorag_exec_layout (s);
- }
- }
-
- /* Since ENTRY might appear after executable stmts, do what would have
- been done if it hadn't -- give symbol implicit type and
- exec-transition it. */
-
- if (!in_spec && ffesymbol_is_specable (s))
- {
- if (!ffeimplic_establish_symbol (s)) /* Do implicit typing. */
- ffesymbol_error (s, entryname);
- s = ffecom_sym_exec_transition (s);
- }
-
- /* Use whatever type info is available for ENTRY to set up type for its
- global-name-space function symbol relative. */
-
- ffesymbol_set_info (fs,
- ffeinfo_new (ffesymbol_basictype (s),
- ffesymbol_kindtype (s),
- 0,
- FFEINFO_kindFUNCTION,
- FFEINFO_whereLOCAL,
- ffesymbol_size (s)));
-
-
- /* Check whether the type info fits the filewide expectations;
- set ok flag accordingly. */
-
- ffesymbol_reference (fs, entryname, FALSE);
-
- /* ~~Question??:
- When ENTRY FOO() RESULT(IBAR) is supported, what will the typing be
- if FOO and IBAR would normally end up with different types? I think
- the answer is that FOO is always given whatever type would be chosen
- for IBAR, rather than the other way around, and I think it ends up
- working that way for FUNCTION FOO() RESULT(IBAR), but this should be
- checked out in all its different combos. Related question is, is
- there any way that FOO in either case ends up without type info
- filled in? Does anyone care? */
-
- ffesymbol_signal_unreported (s);
- }
- else
- {
- ffesymbol_set_info (fs,
- ffeinfo_new (FFEINFO_basictypeNONE,
- FFEINFO_kindtypeNONE,
- 0,
- FFEINFO_kindSUBROUTINE,
- FFEINFO_whereLOCAL,
- FFETARGET_charactersizeNONE));
- }
-
- if (!in_spec)
- fs = ffecom_sym_exec_transition (fs);
-
- ffesymbol_signal_unreported (fs);
-
- ffestd_R1226 (fs);
-}
-
-/* ffestc_R1227 -- RETURN statement
-
- ffestc_R1227(expr,expr_token);
-
- Make sure statement is valid here; implement. expr and expr_token are
- both NULL if there was no expression. */
-
-void
-ffestc_R1227 (ffebld expr, ffelexToken expr_token)
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_notloop_begin_ ();
-
- for (b = ffestw_stack_top (); ; b = ffestw_previous (b))
- {
- switch (ffestw_state (b))
- {
- case FFESTV_statePROGRAM4:
- case FFESTV_stateSUBROUTINE4:
- case FFESTV_stateFUNCTION4:
- goto base; /* :::::::::::::::::::: */
-
- case FFESTV_stateNIL:
- assert ("bad state" == NULL);
- break;
-
- default:
- break;
- }
- }
-
- base:
- switch (ffestw_state (b))
- {
- case FFESTV_statePROGRAM4:
- if (ffe_is_pedantic ())
- {
- ffebad_start (FFEBAD_RETURN_IN_MAIN);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- if (expr != NULL)
- {
- ffebad_start (FFEBAD_ALTRETURN_IN_PROGRAM);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- expr = NULL;
- }
- break;
-
- case FFESTV_stateSUBROUTINE4:
- break;
-
- case FFESTV_stateFUNCTION4:
- if (expr != NULL)
- {
- ffebad_start (FFEBAD_ALTRETURN_IN_FUNCTION);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- expr = NULL;
- }
- break;
-
- default:
- assert ("bad state #2" == NULL);
- break;
- }
-
- ffestd_R1227 (expr);
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
-
- /* notloop's that are actionif's can be the target of a loop-end
- statement if they're in the "then" part of a logical IF, as
- in "DO 10", "10 IF (...) RETURN". */
-
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_R1228 -- CONTAINS statement
-
- ffestc_R1228(); */
-
-#if FFESTR_F90
-void
-ffestc_R1228 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_contains_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestd_R1228 ();
-
- ffe_terminate_3 ();
- ffe_init_3 ();
-}
-
-#endif
-/* ffestc_R1229_start -- STMTFUNCTION statement begin
-
- ffestc_R1229_start(func_name,func_arg_list,close_paren);
-
- Verify that STMTFUNCTION is valid here, establish func_arg_list in a new
- "live" scope within the current scope, and expect the actual expression
- (or NULL) in ffestc_R1229_finish. The reason there are two ffestc
- functions to handle this is so the scope can be established, allowing
- ffeexpr to assign proper characteristics to references to the dummy
- arguments. */
-
-void
-ffestc_R1229_start (ffelexToken name, ffesttTokenList args,
- ffelexToken final UNUSED)
-{
- ffesymbol s;
- ffesymbolAttrs sa;
- ffesymbolAttrs na;
-
- ffestc_check_start_ ();
- if (ffestc_order_sfunc_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- assert (name != NULL);
- assert (args != NULL);
-
- s = ffesymbol_declare_local (name, FALSE);
- sa = ffesymbol_attrs (s);
-
- /* Figure out what kind of object we've got based on previous declarations
- of or references to the object. */
-
- if (!ffesymbol_is_specable (s))
- na = FFESYMBOL_attrsetNONE; /* Can't dcl sym ref'd in sfuncdef. */
- else if (sa & FFESYMBOL_attrsANY)
- na = FFESYMBOL_attrsANY;
- else if (!(sa & ~FFESYMBOL_attrsTYPE))
- na = sa | FFESYMBOL_attrsSFUNC;
- else
- na = FFESYMBOL_attrsetNONE;
-
- /* Now see what we've got for a new object: NONE means a new error cropped
- up; ANY means an old error to be ignored; otherwise, everything's ok,
- update the object (symbol) and continue on. */
-
- if (na == FFESYMBOL_attrsetNONE)
- {
- ffesymbol_error (s, name);
- ffestc_parent_ok_ = FALSE;
- }
- else if (na & FFESYMBOL_attrsANY)
- ffestc_parent_ok_ = FALSE;
- else
- {
- ffesymbol_set_attrs (s, na);
- ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
- if (!ffeimplic_establish_symbol (s)
- || ((ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
- && (ffesymbol_size (s) == FFETARGET_charactersizeNONE)))
- {
- ffesymbol_error (s, ffesta_tokens[0]);
- ffestc_parent_ok_ = FALSE;
- }
- else
- {
- /* Tell ffeexpr that sfunc def is in progress. */
- ffesymbol_set_sfexpr (s, ffebld_new_any ());
- ffebld_set_info (ffesymbol_sfexpr (s), ffeinfo_new_any ());
- ffestc_parent_ok_ = TRUE;
- }
- }
-
- ffe_init_4 ();
-
- if (ffestc_parent_ok_)
- {
- ffebld_init_list (&s->dummy_args, &ffestc_local_.dummy.list_bottom);
- ffestc_sfdummy_argno_ = 0;
- ffestt_tokenlist_drive (args, ffestc_promote_sfdummy_);
- ffebld_end_list (&ffestc_local_.dummy.list_bottom);
- }
-
- ffestc_local_.sfunc.symbol = s;
-
- ffestd_R1229_start (name, args);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_R1229_finish -- STMTFUNCTION statement list complete
-
- ffestc_R1229_finish(expr,expr_token);
-
- If expr is NULL, an error occurred parsing the expansion expression, so
- just cancel the effects of ffestc_R1229_start and pretend nothing
- happened. Otherwise, install the expression as the expansion for the
- statement function named in _start_, then clean up. */
-
-void
-ffestc_R1229_finish (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_parent_ok_ && (expr != NULL))
- ffesymbol_set_sfexpr (ffestc_local_.sfunc.symbol,
- ffeexpr_convert_to_sym (expr,
- expr_token,
- ffestc_local_.sfunc.symbol,
- ffesta_tokens[0]));
-
- ffestd_R1229_finish (ffestc_local_.sfunc.symbol);
-
- ffesymbol_signal_unreported (ffestc_local_.sfunc.symbol);
-
- ffe_terminate_4 ();
-}
-
-/* ffestc_S3P4 -- INCLUDE line
-
- ffestc_S3P4(filename,filename_token);
-
- Make sure INCLUDE not preceded by any semicolons or a label def; implement. */
-
-void
-ffestc_S3P4 (ffebld filename, ffelexToken filename_token UNUSED)
-{
- ffestc_check_simple_ ();
- ffestc_labeldef_invalid_ ();
-
- ffestd_S3P4 (filename);
-}
-
-/* ffestc_V003_start -- STRUCTURE statement list begin
-
- ffestc_V003_start(structure_name);
-
- Verify that STRUCTURE is valid here, and begin accepting items in the list. */
-
-#if FFESTR_VXT
-void
-ffestc_V003_start (ffelexToken structure_name)
-{
- ffestw b;
-
- ffestc_check_start_ ();
- if (ffestc_order_vxtstructure_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestc_local_.V003.list_state = 2; /* Require at least one field
- name. */
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
- member. */
- break;
-
- default:
- ffestc_local_.V003.list_state = 0; /* No field names required. */
- if (structure_name == NULL)
- {
- ffebad_start (FFEBAD_STRUCT_MISSING_NAME);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_finish ();
- }
- break;
- }
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateSTRUCTURE);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_structure_);
- ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
-
- ffestd_V003_start (structure_name);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V003_item -- STRUCTURE statement for object-name
-
- ffestc_V003_item(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be STRUCTUREd. */
-
-void
-ffestc_V003_item (ffelexToken name, ffesttDimList dims)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- if (ffestc_local_.V003.list_state < 2)
- {
- if (ffestc_local_.V003.list_state == 0)
- {
- ffestc_local_.V003.list_state = 1;
- ffebad_start (FFEBAD_STRUCT_IGNORING_FIELD);
- ffebad_here (0, ffelex_token_where_line (name),
- ffelex_token_where_column (name));
- ffebad_finish ();
- }
- return;
- }
- ffestc_local_.V003.list_state = 3; /* Have at least one field name. */
-
- if (dims != NULL)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_V003_item (name, dims);
-}
-
-/* ffestc_V003_finish -- STRUCTURE statement list complete
-
- ffestc_V003_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V003_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_local_.V003.list_state == 2)
- {
- ffebad_start (FFEBAD_STRUCT_MISSING_FIELD);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_previous (ffestw_stack_top ())),
- ffestw_col (ffestw_previous (ffestw_stack_top ())));
- ffebad_finish ();
- }
-
- ffestd_V003_finish ();
-}
-
-/* ffestc_V004 -- END STRUCTURE statement
-
- ffestc_V004();
-
- Make sure ffestc_kind_ identifies a STRUCTURE block.
- Implement the end of the current STRUCTURE block. */
-
-void
-ffestc_V004 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_structure_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 1)
- {
- ffebad_start (FFEBAD_STRUCT_NO_COMPONENTS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestc_shriek_structure_ (TRUE);
-}
-
-/* ffestc_V009 -- UNION statement
-
- ffestc_V009(); */
-
-void
-ffestc_V009 ()
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_structure_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one member. */
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateUNION);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_union_);
- ffestw_set_substate (b, 0); /* No map decls seen yet. */
-
- ffestd_V009 ();
-}
-
-/* ffestc_V010 -- END UNION statement
-
- ffestc_V010();
-
- Make sure ffestc_kind_ identifies a UNION block.
- Implement the end of the current UNION block. */
-
-void
-ffestc_V010 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_union_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 2)
- {
- ffebad_start (FFEBAD_UNION_NO_TWO_MAPS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestc_shriek_union_ (TRUE);
-}
-
-/* ffestc_V012 -- MAP statement
-
- ffestc_V012(); */
-
-void
-ffestc_V012 ()
-{
- ffestw b;
-
- ffestc_check_simple_ ();
- if (ffestc_order_union_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 2)
- ffestw_substate (ffestw_stack_top ())++; /* 0=>1, 1=>2. */
-
- b = ffestw_update (ffestw_push (NULL));
- ffestw_set_top_do (b, NULL);
- ffestw_set_state (b, FFESTV_stateMAP);
- ffestw_set_blocknum (b, 0);
- ffestw_set_shriek (b, ffestc_shriek_map_);
- ffestw_set_substate (b, 0); /* No field-declarations seen yet. */
-
- ffestd_V012 ();
-}
-
-/* ffestc_V013 -- END MAP statement
-
- ffestc_V013();
-
- Make sure ffestc_kind_ identifies a MAP block.
- Implement the end of the current MAP block. */
-
-void
-ffestc_V013 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_map_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_useless_ ();
-
- if (ffestw_substate (ffestw_stack_top ()) != 1)
- {
- ffebad_start (FFEBAD_MAP_NO_COMPONENTS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ()));
- ffebad_finish ();
- }
-
- ffestc_shriek_map_ (TRUE);
-}
-
-#endif
-/* ffestc_V014_start -- VOLATILE statement list begin
-
- ffestc_V014_start();
-
- Verify that VOLATILE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V014_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_progspec_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_V014_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V014_item_object -- VOLATILE statement for object-name
-
- ffestc_V014_item_object(name_token);
-
- Make sure name_token identifies a valid object to be VOLATILEd. */
-
-void
-ffestc_V014_item_object (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_V014_item_object (name);
-}
-
-/* ffestc_V014_item_cblock -- VOLATILE statement for common-block-name
-
- ffestc_V014_item_cblock(name_token);
-
- Make sure name_token identifies a valid common block to be VOLATILEd. */
-
-void
-ffestc_V014_item_cblock (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_V014_item_cblock (name);
-}
-
-/* ffestc_V014_finish -- VOLATILE statement list complete
-
- ffestc_V014_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V014_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V014_finish ();
-}
-
-/* ffestc_V016_start -- RECORD statement list begin
-
- ffestc_V016_start();
-
- Verify that RECORD is valid here, and begin accepting items in the list. */
-
-#if FFESTR_VXT
-void
-ffestc_V016_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_record_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- switch (ffestw_state (ffestw_stack_top ()))
- {
- case FFESTV_stateSTRUCTURE:
- case FFESTV_stateMAP:
- ffestw_set_substate (ffestw_stack_top (), 1); /* Seen at least one
- member. */
- break;
-
- default:
- break;
- }
-
- ffestd_V016_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V016_item_structure -- RECORD statement for common-block-name
-
- ffestc_V016_item_structure(name_token);
-
- Make sure name_token identifies a valid structure to be RECORDed. */
-
-void
-ffestc_V016_item_structure (ffelexToken name)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- ffestd_V016_item_structure (name);
-}
-
-/* ffestc_V016_item_object -- RECORD statement for object-name
-
- ffestc_V016_item_object(name_token,dim_list);
-
- Make sure name_token identifies a valid object to be RECORDd. */
-
-void
-ffestc_V016_item_object (ffelexToken name, ffesttDimList dims)
-{
- ffestc_check_item_ ();
- assert (name != NULL);
- if (!ffestc_ok_)
- return;
-
- if (dims != NULL)
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-
- ffestd_V016_item_object (name, dims);
-}
-
-/* ffestc_V016_finish -- RECORD statement list complete
-
- ffestc_V016_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V016_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V016_finish ();
-}
-
-/* ffestc_V018_start -- REWRITE(...) statement list begin
-
- ffestc_V018_start();
-
- Verify that REWRITE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V018_start ()
-{
- ffestvFormat format;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixERR])
- || !ffestc_subr_is_format_
- (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT])
- || !ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT]);
- switch (format)
- {
- case FFESTV_formatNAMELIST:
- case FFESTV_formatASTERISK:
- ffebad_start (FFEBAD_CONFLICTING_SPECS);
- ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
- ffelex_token_where_column (ffesta_tokens[0]));
- assert (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present);
- if (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present)
- {
- ffebad_here (0, ffelex_token_where_line
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw),
- ffelex_token_where_column
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw));
- }
- else
- {
- ffebad_here (1, ffelex_token_where_line
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value),
- ffelex_token_where_column
- (ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value));
- }
- ffebad_finish ();
- ffestc_ok_ = FALSE;
- return;
-
- default:
- break;
- }
-
- ffestd_V018_start (format);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V018_item -- REWRITE statement i/o item
-
- ffestc_V018_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_V018_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V018_item (expr);
-}
-
-/* ffestc_V018_finish -- REWRITE statement list complete
-
- ffestc_V018_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V018_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V018_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V019_start -- ACCEPT statement list begin
-
- ffestc_V019_start();
-
- Verify that ACCEPT is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V019_start ()
-{
- ffestvFormat format;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_format_
- (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- ffestd_V019_start (format);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V019_item -- ACCEPT statement i/o item
-
- ffestc_V019_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_V019_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_V019_item (expr);
-}
-
-/* ffestc_V019_finish -- ACCEPT statement list complete
-
- ffestc_V019_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V019_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V019_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-#endif
-/* ffestc_V020_start -- TYPE statement list begin
-
- ffestc_V020_start();
-
- Verify that TYPE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V020_start ()
-{
- ffestvFormat format;
-
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_format_
- (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- format = ffestc_subr_format_
- (&ffestp_file.type.type_spec[FFESTP_typeixFORMAT]);
- ffestc_namelist_ = (format == FFESTV_formatNAMELIST);
-
- ffestd_V020_start (format);
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V020_item -- TYPE statement i/o item
-
- ffestc_V020_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_V020_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- if (ffestc_namelist_ != 0)
- {
- if (ffestc_namelist_ == 1)
- {
- ffestc_namelist_ = 2;
- ffebad_start (FFEBAD_NAMELIST_ITEMS);
- ffebad_here (0, ffelex_token_where_line (expr_token),
- ffelex_token_where_column (expr_token));
- ffebad_finish ();
- }
- return;
- }
-
- ffestd_V020_item (expr);
-}
-
-/* ffestc_V020_finish -- TYPE statement list complete
-
- ffestc_V020_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V020_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V020_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V021 -- DELETE statement
-
- ffestc_V021();
-
- Make sure a DELETE is valid in the current context, and implement it. */
-
-#if FFESTR_VXT
-void
-ffestc_V021 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.delete.delete_spec[FFESTP_deleteixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT]))
- ffestd_V021 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V022 -- UNLOCK statement
-
- ffestc_V022();
-
- Make sure a UNLOCK is valid in the current context, and implement it. */
-
-void
-ffestc_V022 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.beru.beru_spec[FFESTP_beruixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.beru.beru_spec[FFESTP_beruixUNIT]))
- ffestd_V022 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V023_start -- ENCODE(...) statement list begin
-
- ffestc_V023_start();
-
- Verify that ENCODE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V023_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- ffestd_V023_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V023_item -- ENCODE statement i/o item
-
- ffestc_V023_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_V023_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V023_item (expr);
-}
-
-/* ffestc_V023_finish -- ENCODE statement list complete
-
- ffestc_V023_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V023_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V023_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V024_start -- DECODE(...) statement list begin
-
- ffestc_V024_start();
-
- Verify that DECODE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V024_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- if (!ffestc_subr_is_branch_
- (&ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixERR]))
- {
- ffestc_ok_ = FALSE;
- return;
- }
-
- ffestd_V024_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V024_item -- DECODE statement i/o item
-
- ffestc_V024_item(expr,expr_token);
-
- Implement output-list expression. */
-
-void
-ffestc_V024_item (ffebld expr, ffelexToken expr_token)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V024_item (expr);
-}
-
-/* ffestc_V024_finish -- DECODE statement list complete
-
- ffestc_V024_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V024_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V024_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V025_start -- DEFINEFILE statement list begin
-
- ffestc_V025_start();
-
- Verify that DEFINEFILE is valid here, and begin accepting items in the
- list. */
-
-void
-ffestc_V025_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_branch_begin_ ();
-
- ffestd_V025_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V025_item -- DEFINE FILE statement item
-
- ffestc_V025_item(u,ut,m,mt,n,nt,asv,asvt);
-
- Implement item. */
-
-void
-ffestc_V025_item (ffebld u, ffelexToken ut, ffebld m, ffelexToken mt,
- ffebld n, ffelexToken nt, ffebld asv, ffelexToken asvt)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V025_item (u, m, n, asv);
-}
-
-/* ffestc_V025_finish -- DEFINE FILE statement list complete
-
- ffestc_V025_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V025_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V025_finish ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-/* ffestc_V026 -- FIND statement
-
- ffestc_V026();
-
- Make sure a FIND is valid in the current context, and implement it. */
-
-void
-ffestc_V026 ()
-{
- ffestc_check_simple_ ();
- if (ffestc_order_actionif_ () != FFESTC_orderOK_)
- return;
- ffestc_labeldef_branch_begin_ ();
-
- if (ffestc_subr_is_branch_
- (&ffestp_file.find.find_spec[FFESTP_findixERR])
- && ffestc_subr_is_present_ ("UNIT",
- &ffestp_file.find.find_spec[FFESTP_findixUNIT])
- && ffestc_subr_is_present_ ("REC",
- &ffestp_file.find.find_spec[FFESTP_findixREC]))
- ffestd_V026 ();
-
- if (ffestc_shriek_after1_ != NULL)
- (*ffestc_shriek_after1_) (TRUE);
- ffestc_labeldef_branch_end_ ();
-}
-
-#endif
-/* ffestc_V027_start -- VXT PARAMETER statement list begin
-
- ffestc_V027_start();
-
- Verify that PARAMETER is valid here, and begin accepting items in the list. */
-
-void
-ffestc_V027_start ()
-{
- ffestc_check_start_ ();
- if (ffestc_order_parameter_ () != FFESTC_orderOK_)
- {
- ffestc_ok_ = FALSE;
- return;
- }
- ffestc_labeldef_useless_ ();
-
- ffestd_V027_start ();
-
- ffestc_ok_ = TRUE;
-}
-
-/* ffestc_V027_item -- VXT PARAMETER statement assignment
-
- ffestc_V027_item(dest,dest_token,source,source_token);
-
- Make sure the source is a valid source for the destination; make the
- assignment. */
-
-void
-ffestc_V027_item (ffelexToken dest_token, ffebld source,
- ffelexToken source_token UNUSED)
-{
- ffestc_check_item_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V027_item (dest_token, source);
-}
-
-/* ffestc_V027_finish -- VXT PARAMETER statement list complete
-
- ffestc_V027_finish();
-
- Just wrap up any local activities. */
-
-void
-ffestc_V027_finish ()
-{
- ffestc_check_finish_ ();
- if (!ffestc_ok_)
- return;
-
- ffestd_V027_finish ();
-}
-
-/* Any executable statement. Mainly make sure that one-shot things
- like the statement for a logical IF are reset. */
-
-void
-ffestc_any ()
-{
- ffestc_check_simple_ ();
-
- ffestc_order_any_ ();
-
- ffestc_labeldef_any_ ();
-
- if (ffestc_shriek_after1_ == NULL)
- return;
-
- ffestd_any ();
-
- (*ffestc_shriek_after1_) (TRUE);
-}
projects / msp430-gcc.git / blobdiff