symbol.c

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

/* Implementation of Fortran symbol manager
   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.  */

#include "proj.h"
#include "symbol.h"
#include "bad.h"
#include "bld.h"
#include "com.h"
#include "equiv.h"
#include "global.h"
#include "info.h"
#include "intrin.h"
#include "lex.h"
#include "malloc.h"
#include "src.h"
#include "st.h"
#include "storag.h"
#include "target.h"
#include "where.h"

/* Choice of how to handle global symbols -- either global only within the
   program unit being defined or global within the entire source file.
   The former is appropriate for systems where an object file can
   easily be taken apart program unit by program unit, the latter is the
   UNIX/C model where the object file is essentially a monolith.  */

#define FFESYMBOL_globalPROGUNIT_ 1
#define FFESYMBOL_globalFILE_ 2

/* Choose how to handle global symbols here.  */

#if FFECOM_targetCURRENT == FFECOM_targetFFE
#define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
#elif FFECOM_targetCURRENT == FFECOM_targetGCC
/* Would be good to understand why PROGUNIT in this case too.
   (1995-08-22).  */
#define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
#else
#error
#endif

/* Choose how to handle memory pools based on global symbol stuff.  */

#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
#define FFESYMBOL_SPACE_POOL_ ffe_pool_program_unit()
#elif FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
#define FFESYMBOL_SPACE_POOL_ ffe_pool_file()
#else
#error
#endif

/* What kind of retraction is needed for a symbol?  */

enum _ffesymbol_retractcommand_
  {
    FFESYMBOL_retractcommandDELETE_,
    FFESYMBOL_retractcommandRETRACT_,
    FFESYMBOL_retractcommand_
  };
typedef enum _ffesymbol_retractcommand_ ffesymbolRetractCommand_;

/* This object keeps track of retraction for a symbol and links to the next
   such object.  */

typedef struct _ffesymbol_retract_ *ffesymbolRetract_;
struct _ffesymbol_retract_
  {
    ffesymbolRetract_ next;
    ffesymbolRetractCommand_ command;
    ffesymbol live;		/* Live symbol. */
    ffesymbol symbol;		/* Backup copy of symbol. */
  };

static ffebad ffesymbol_check_token_ (ffelexToken t, char *c);
static void ffesymbol_kill_manifest_ (void);
static ffesymbol ffesymbol_new_ (ffename n);
static ffesymbol ffesymbol_unhook_ (ffesymbol s);
static void ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c);

/* Manifest names for unnamed things (as tokens) so we make them only
   once.  */

static ffelexToken ffesymbol_token_blank_common_ = NULL;
static ffelexToken ffesymbol_token_unnamed_main_ = NULL;
static ffelexToken ffesymbol_token_unnamed_blockdata_ = NULL;

/* Name spaces currently in force.  */

static ffenameSpace ffesymbol_global_ = NULL;
static ffenameSpace ffesymbol_local_ = NULL;
static ffenameSpace ffesymbol_sfunc_ = NULL;

/* Keep track of retraction.  */

static bool ffesymbol_retractable_ = FALSE;
static mallocPool ffesymbol_retract_pool_;
static ffesymbolRetract_ ffesymbol_retract_first_;
static ffesymbolRetract_ *ffesymbol_retract_list_;

/* List of state names. */

static const char *ffesymbol_state_name_[] =
{
  "?",
  "@",
  "&",
  "$",
};

/* List of attribute names. */

static const char *ffesymbol_attr_name_[] =
{
#define DEFATTR(ATTR,ATTRS,NAME) NAME,
#include "symbol.def"
#undef DEFATTR
};


/* Check whether the token text has any invalid characters.  If not,
   return FALSE.  If so, if error messages inhibited, return TRUE
   so caller knows to try again later, else report error and return
   FALSE.  */

static ffebad
ffesymbol_check_token_ (ffelexToken t, char *c)
{
  char *p = ffelex_token_text (t);
  ffeTokenLength len = ffelex_token_length (t);
  ffebad bad;
  ffeTokenLength i = 0;
  ffebad skip_me = ((ffe_case_symbol () == FFE_caseINITCAP)
		    ? FFEBAD_SYMBOL_NOLOWER_INITCAP : FFEBAD + 1);
  ffebad stop_me = ((ffe_case_symbol () == FFE_caseINITCAP)
		    ? FFEBAD : FFEBAD + 1);
  if (len == 0)
    return FFEBAD;

  bad = ffesrc_bad_char_symbol_init (*p);
  if (bad == FFEBAD)
    {
      for (++i, ++p; i < len; ++i, ++p)
	{
	  bad = ffesrc_bad_char_symbol_noninit (*p);
	  if (bad == skip_me)
	    continue;		/* Keep looking for good InitCap character. */
	  if (bad == stop_me)
	    break;		/* Found good InitCap character. */
	  if (bad != FFEBAD)
	    break;		/* Bad character found. */
	}
    }

  if (bad != FFEBAD)
    {
      if (i >= len)
	*c = *(ffelex_token_text (t));
      else
	*c = *p;
    }

  return bad;
}

/* Kill manifest (g77-picked) names.  */

static void
ffesymbol_kill_manifest_ ()
{
  if (ffesymbol_token_blank_common_ != NULL)
    ffelex_token_kill (ffesymbol_token_blank_common_);
  if (ffesymbol_token_unnamed_main_ != NULL)
    ffelex_token_kill (ffesymbol_token_unnamed_main_);
  if (ffesymbol_token_unnamed_blockdata_ != NULL)
    ffelex_token_kill (ffesymbol_token_unnamed_blockdata_);

  ffesymbol_token_blank_common_ = NULL;
  ffesymbol_token_unnamed_main_ = NULL;
  ffesymbol_token_unnamed_blockdata_ = NULL;
}

/* Make new symbol.

   If the "retractable" flag is not set, just return the new symbol.
   Else, add symbol to the "retract" list as a delete item, set
   the "have_old" flag, and return the new symbol.  */

static ffesymbol
ffesymbol_new_ (ffename n)
{
  ffesymbol s;
  ffesymbolRetract_ r;

  assert (n != NULL);

  s = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_, "FFESYMBOL",
				 sizeof (*s));
  s->name = n;
  s->other_space_name = NULL;
#if FFEGLOBAL_ENABLED
  s->global = NULL;
#endif
  s->attrs = FFESYMBOL_attrsetNONE;
  s->state = FFESYMBOL_stateNONE;
  s->info = ffeinfo_new_null ();
  s->dims = NULL;
  s->extents = NULL;
  s->dim_syms = NULL;
  s->array_size = NULL;
  s->init = NULL;
  s->accretion = NULL;
  s->accretes = 0;
  s->dummy_args = NULL;
  s->namelist = NULL;
  s->common_list = NULL;
  s->sfunc_expr = NULL;
  s->list_bottom = NULL;
  s->common = NULL;
  s->equiv = NULL;
  s->storage = NULL;
#ifdef FFECOM_symbolHOOK
  s->hook = FFECOM_symbolNULL;
#endif
  s->sfa_dummy_parent = NULL;
  s->func_result = NULL;
  s->value = 0;
  s->check_state = FFESYMBOL_checkstateNONE_;
  s->check_token = NULL;
  s->max_entry_num = 0;
  s->num_entries = 0;
  s->generic = FFEINTRIN_genNONE;
  s->specific = FFEINTRIN_specNONE;
  s->implementation = FFEINTRIN_impNONE;
  s->is_save = FALSE;
  s->is_init = FALSE;
  s->do_iter = FALSE;
  s->reported = FALSE;
  s->explicit_where = FALSE;
  s->namelisted = FALSE;
  s->assigned = FALSE;

  ffename_set_symbol (n, s);

  if (!ffesymbol_retractable_)
    {
      s->have_old = FALSE;
      return s;
    }

  r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_,
					 "FFESYMBOL retract", sizeof (*r));
  r->next = NULL;
  r->command = FFESYMBOL_retractcommandDELETE_;
  r->live = s;
  r->symbol = NULL;		/* No backup copy. */

  *ffesymbol_retract_list_ = r;
  ffesymbol_retract_list_ = &r->next;

  s->have_old = TRUE;
  return s;
}

/* Unhook a symbol from its (soon-to-be-killed) name obj.

   NULLify the names to which this symbol points.  Do other cleanup as
   needed.  */

static ffesymbol
ffesymbol_unhook_ (ffesymbol s)
{
  s->other_space_name = s->name = NULL;
  if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
      || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
    ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
  if (s->check_state == FFESYMBOL_checkstatePENDING_)
    ffelex_token_kill (s->check_token);

  return s;
}

/* Issue diagnostic about bad character in token representing user-defined
   symbol name.	 */

static void
ffesymbol_whine_state_ (ffebad bad, ffelexToken t, char c)
{
  char badstr[2];

  badstr[0] = c;
  badstr[1] = '\0';

  ffebad_start (bad);
  ffebad_here (0, ffelex_token_where_line (t),
	       ffelex_token_where_column (t));
  ffebad_string (badstr);
  ffebad_finish ();
}

/* Returns a string representing the attributes set.  */

const char *
ffesymbol_attrs_string (ffesymbolAttrs attrs)
{
  static char string[FFESYMBOL_attr * 12 + 20];
  char *p;
  ffesymbolAttr attr;

  p = &string[0];

  if (attrs == FFESYMBOL_attrsetNONE)
    {
      strcpy (p, "NONE");
      return &string[0];
    }

  for (attr = 0; attr < FFESYMBOL_attr; ++attr)
    {
      if (attrs & ((ffesymbolAttrs) 1 << attr))
	{
	  attrs &= ~((ffesymbolAttrs) 1 << attr);
	  strcpy (p, ffesymbol_attr_name_[attr]);
	  while (*p)
	    ++p;
	  *(p++) = '|';
	}
    }
  if (attrs == FFESYMBOL_attrsetNONE)
    *--p = '\0';
  else
    sprintf (p, "?0x%" ffesymbolAttrs_f "x?", attrs);
  assert (((size_t) (p - &string[0])) < ARRAY_SIZE (string));
  return &string[0];
}

/* Check symbol's name for validity, considering that it might actually
   be an intrinsic and thus should not be complained about just yet.  */

void
ffesymbol_check (ffesymbol s, ffelexToken t, bool maybe_intrin)
{
  char c;
  ffebad bad;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;

  if (!ffesrc_check_symbol ()
      || ((s->check_state != FFESYMBOL_checkstateNONE_)
	  && ((s->check_state != FFESYMBOL_checkstateINHIBITED_)
	      || ffebad_inhibit ())))
    return;

  bad = ffesymbol_check_token_ (t, &c);

  if (bad == FFEBAD)
    {
      s->check_state = FFESYMBOL_checkstateCHECKED_;
      return;
    }

  if (maybe_intrin
      && ffeintrin_is_intrinsic (ffelex_token_text (t), NULL, FALSE,
				 &gen, &spec, &imp))
    {
      s->check_state = FFESYMBOL_checkstatePENDING_;
      s->check_token = ffelex_token_use (t);
      return;
    }

  if (ffebad_inhibit ())
    {
      s->check_state = FFESYMBOL_checkstateINHIBITED_;
      return;			/* Don't complain now, do it later. */
    }

  s->check_state = FFESYMBOL_checkstateCHECKED_;

  ffesymbol_whine_state_ (bad, t, c);
}

/* Declare a BLOCKDATA unit.

   Retrieves or creates the ffesymbol for the specified BLOCKDATA (unnamed
   if t is NULL).  Doesn't actually ensure the named item is a
   BLOCKDATA; the caller must handle that.  */

ffesymbol
ffesymbol_declare_blockdataunit (ffelexToken t, ffewhereLine wl,
				 ffewhereColumn wc)
{
  ffename n;
  ffesymbol s;
  bool user = (t != NULL);

  assert (!ffesymbol_retractable_);

  if (t == NULL)
    {
      if (ffesymbol_token_unnamed_blockdata_ == NULL)
	ffesymbol_token_unnamed_blockdata_
	  = ffelex_token_new_name (FFETARGET_nameUNNAMED_BLOCK_DATA, wl, wc);
      t = ffesymbol_token_unnamed_blockdata_;
    }

  n = ffename_lookup (ffesymbol_local_, t);
  if (n != NULL)
    return ffename_symbol (n);	/* This will become an error. */

  n = ffename_find (ffesymbol_global_, t);
  s = ffename_symbol (n);
  if (s != NULL)
    {
      if (user)
	ffesymbol_check (s, t, FALSE);
      return s;
    }

  s = ffesymbol_new_ (n);
  if (user)
    ffesymbol_check (s, t, FALSE);

  /* A program unit name also is in the local name space. */

  n = ffename_find (ffesymbol_local_, t);
  ffename_set_symbol (n, s);
  s->other_space_name = n;

  ffeglobal_new_blockdata (s, t);	/* Detect conflicts, when
					   appropriate. */

  return s;
}

/* Declare a common block (named or unnamed).

   Retrieves or creates the ffesymbol for the specified common block (blank
   common if t is NULL).  Doesn't actually ensure the named item is a
   common block; the caller must handle that.  */

ffesymbol
ffesymbol_declare_cblock (ffelexToken t, ffewhereLine wl, ffewhereColumn wc)
{
  ffename n;
  ffesymbol s;
  bool blank;

  assert (!ffesymbol_retractable_);

  if (t == NULL)
    {
      blank = TRUE;
      if (ffesymbol_token_blank_common_ == NULL)
	ffesymbol_token_blank_common_
	  = ffelex_token_new_name (FFETARGET_nameBLANK_COMMON, wl, wc);
      t = ffesymbol_token_blank_common_;
    }
  else
    blank = FALSE;

  n = ffename_find (ffesymbol_global_, t);
  s = ffename_symbol (n);
  if (s != NULL)
    {
      if (!blank)
	ffesymbol_check (s, t, FALSE);
      return s;
    }

  s = ffesymbol_new_ (n);
  if (!blank)
    ffesymbol_check (s, t, FALSE);

  ffeglobal_new_common (s, t, blank);	/* Detect conflicts. */