stc.c

gcc-2.95.3 Linux下最常用的C编译器

/* stc.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995-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 **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

/* 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;