symbol.c

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

  return s;
}

/* Declare a FUNCTION program unit (with distinct RESULT() name).

   Retrieves or creates the ffesymbol for the specified function.  Doesn't
   actually ensure the named item is a function; the caller must handle
   that.

   If FUNCTION with RESULT() is specified but the names are the same,
   pretend as though RESULT() was not specified, and don't call this
   function; use ffesymbol_declare_funcunit() instead.	*/

ffesymbol
ffesymbol_declare_funcnotresunit (ffelexToken t)
{
  ffename n;
  ffesymbol s;

  assert (t != NULL);
  assert (!ffesymbol_retractable_);

  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)
    {
      ffesymbol_check (s, t, FALSE);
      return s;
    }

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

  /* A FUNCTION program unit name also is in the local name space; handle it
     here since RESULT() is a different name and is handled separately. */

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

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

  return s;
}

/* Declare a function result.

   Retrieves or creates the ffesymbol for the specified function result,
   whether specified via a distinct RESULT() or by default in a FUNCTION or
   ENTRY statement.  */

ffesymbol
ffesymbol_declare_funcresult (ffelexToken t)
{
  ffename n;
  ffesymbol s;

  assert (t != NULL);
  assert (!ffesymbol_retractable_);

  n = ffename_find (ffesymbol_local_, t);
  s = ffename_symbol (n);
  if (s != NULL)
    return s;

  return ffesymbol_new_ (n);
}

/* Declare a FUNCTION program unit with no RESULT().

   Retrieves or creates the ffesymbol for the specified function.  Doesn't
   actually ensure the named item is a function; the caller must handle
   that.

   This is the function to call when the FUNCTION or ENTRY statement has
   no separate and distinct name specified via RESULT().  That's because
   this function enters the global name of the function in only the global
   name space.	ffesymbol_declare_funcresult() must still be called to
   declare the name for the function result in the local name space.  */

ffesymbol
ffesymbol_declare_funcunit (ffelexToken t)
{
  ffename n;
  ffesymbol s;

  assert (t != NULL);
  assert (!ffesymbol_retractable_);

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

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

  ffeglobal_new_function (s, t);/* Detect conflicts. */

  return s;
}

/* Declare a local entity.

   Retrieves or creates the ffesymbol for the specified local entity.
   Set maybe_intrin TRUE if this name might turn out to name an
   intrinsic (legitimately); otherwise if the name doesn't meet the
   requirements for a user-defined symbol name, a diagnostic will be
   issued right away rather than waiting until the intrinsicness of the
   symbol is determined.  */

ffesymbol
ffesymbol_declare_local (ffelexToken t, bool maybe_intrin)
{
  ffename n;
  ffesymbol s;

  assert (t != NULL);

  /* If we're parsing within a statement function definition, return the
     symbol if already known (a dummy argument for the statement function).
     Otherwise continue on, which means the symbol is declared within the
     containing (local) program unit rather than the statement function
     definition.  */

  if ((ffesymbol_sfunc_ != NULL)
      && ((n = ffename_lookup (ffesymbol_sfunc_, t)) != NULL))
    return ffename_symbol (n);

  n = ffename_find (ffesymbol_local_, t);
  s = ffename_symbol (n);
  if (s != NULL)
    {
      ffesymbol_check (s, t, maybe_intrin);
      return s;
    }

  s = ffesymbol_new_ (n);
  ffesymbol_check (s, t, maybe_intrin);
  return s;
}

/* Declare a main program unit.

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

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

  assert (!ffesymbol_retractable_);

  if (t == NULL)
    {
      if (ffesymbol_token_unnamed_main_ == NULL)
	ffesymbol_token_unnamed_main_
	  = ffelex_token_new_name (FFETARGET_nameUNNAMED_MAIN, wl, wc);
      t = ffesymbol_token_unnamed_main_;
    }

  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_program (s, t);	/* Detect conflicts. */

  return s;
}

/* Declare a statement-function dummy.

   Retrieves or creates the ffesymbol for the specified statement
   function dummy.  Also ensures that it has a link to the parent (local)
   ffesymbol with the same name, creating it if necessary.  */

ffesymbol
ffesymbol_declare_sfdummy (ffelexToken t)
{
  ffename n;
  ffesymbol s;
  ffesymbol sp;			/* Parent symbol in local area. */

  assert (t != NULL);

  n = ffename_find (ffesymbol_local_, t);
  sp = ffename_symbol (n);
  if (sp == NULL)
    sp = ffesymbol_new_ (n);
  ffesymbol_check (sp, t, FALSE);

  n = ffename_find (ffesymbol_sfunc_, t);
  s = ffename_symbol (n);
  if (s == NULL)
    {
      s = ffesymbol_new_ (n);
      s->sfa_dummy_parent = sp;
    }
  else
    assert (s->sfa_dummy_parent == sp);

  return s;
}

/* Declare a subroutine program unit.

   Retrieves or creates the ffesymbol for the specified subroutine
   Doesn't actually ensure the named item is a subroutine; the caller must
   handle that.  */

ffesymbol
ffesymbol_declare_subrunit (ffelexToken t)
{
  ffename n;
  ffesymbol s;

  assert (!ffesymbol_retractable_);
  assert (t != NULL);

  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)
    {
      ffesymbol_check (s, t, FALSE);
      return s;
    }

  s = ffesymbol_new_ (n);
  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_subroutine (s, t);	/* Detect conflicts, when
					   appropriate. */

  return s;
}

/* Call given fn with all local/global symbols.

   ffesymbol (*fn) (ffesymbol s);
   ffesymbol_drive (fn);  */

void
ffesymbol_drive (ffesymbol (*fn) (ffesymbol))
{
  assert (ffesymbol_sfunc_ == NULL);	/* Might be ok, but not for current
					   uses. */
  ffename_space_drive_symbol (ffesymbol_local_, fn);
  ffename_space_drive_symbol (ffesymbol_global_, fn);
}

/* Call given fn with all sfunc-only symbols.

   ffesymbol (*fn) (ffesymbol s);
   ffesymbol_drive_sfnames (fn);  */

void
ffesymbol_drive_sfnames (ffesymbol (*fn) (ffesymbol))
{
  ffename_space_drive_symbol (ffesymbol_sfunc_, fn);
}

/* Dump info on the symbol for debugging purposes.  */

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffesymbol_dump (ffesymbol s)
{
  ffeinfoKind k;
  ffeinfoWhere w;

  assert (s != NULL);

  if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE)
    fprintf (dmpout, "%s:%d%s%s*%" ffetargetCharacterSize_f "u",
	     ffesymbol_text (s),
	     (int) ffeinfo_rank (s->info),
	     ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
	     ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)),
	     ffeinfo_size (s->info));
  else
    fprintf (dmpout, "%s:%d%s%s",
	     ffesymbol_text (s),
	     (int) ffeinfo_rank (s->info),
	     ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
	     ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)));
  if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE)
    fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
  if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE)
    fprintf (dmpout, "@%s", ffeinfo_where_string (w));

  if ((s->generic != FFEINTRIN_genNONE)
      || (s->specific != FFEINTRIN_specNONE)
      || (s->implementation != FFEINTRIN_impNONE))
    fprintf (dmpout, "{%s:%s:%s}",
	     ffeintrin_name_generic (s->generic),
	     ffeintrin_name_specific (s->specific),
	     ffeintrin_name_implementation (s->implementation));
}
#endif

/* Produce generic error message about a symbol.

   For now, just output error message using symbol's name and pointing to
   the token.  */

void
ffesymbol_error (ffesymbol s, ffelexToken t)
{
  if ((t != NULL)
      && ffest_ffebad_start (FFEBAD_SYMERR))
    {
      ffebad_string (ffesymbol_text (s));
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s));
      ffebad_finish ();
    }

  if (ffesymbol_attr (s, FFESYMBOL_attrANY))
    return;

  ffesymbol_signal_change (s);	/* May need to back up to previous version. */
  if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
      || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
    ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
  ffesymbol_set_attr (s, FFESYMBOL_attrANY);
  ffesymbol_set_info (s, ffeinfo_new_any ());
  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  if (s->check_state == FFESYMBOL_checkstatePENDING_)
    ffelex_token_kill (s->check_token);
  s->check_state = FFESYMBOL_checkstateCHECKED_;
  s = ffecom_sym_learned (s);
  ffesymbol_signal_unreported (s);
}

void
ffesymbol_init_0 ()
{
  ffesymbolAttrs attrs = FFESYMBOL_attrsetNONE;

  assert (FFESYMBOL_state == ARRAY_SIZE (ffesymbol_state_name_));
  assert (FFESYMBOL_attr == ARRAY_SIZE (ffesymbol_attr_name_));
  assert (attrs == FFESYMBOL_attrsetNONE);
  attrs = ((ffesymbolAttrs) 1 << FFESYMBOL_attr);
  assert (attrs != 0);
}

void
ffesymbol_init_1 ()
{
#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
  ffesymbol_global_ = ffename_space_new (ffe_pool_file ());
#endif
}

void
ffesymbol_init_2 ()
{
}

void
ffesymbol_init_3 ()
{
#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
  ffesymbol_global_ = ffename_space_new (ffe_pool_program_unit ());
#endif
  ffesymbol_local_ = ffename_space_new (ffe_pool_program_unit ());
}

void
ffesymbol_init_4 ()
{
  ffesymbol_sfunc_ = ffename_space_new (ffe_pool_program_unit ());
}

/* Look up a local entity.

   Retrieves the ffesymbol for the specified local entity, or returns NULL
   if no local entity by that name exists.  */

ffesymbol
ffesymbol_lookup_local (ffelexToken t)
{
  ffename n;
  ffesymbol s;

  assert (t != NULL);

  n = ffename_lookup (ffesymbol_local_, t);
  if (n == NULL)
    return NULL;

  s = ffename_symbol (n);
  return s;			/* May be NULL here, too. */
}

/* Registers the symbol as one that is referenced by the
   current program unit.  Currently applies only to
   symbols known to have global interest (globals and
   intrinsics).

   s is the (global/intrinsic) symbol referenced; t is the
   referencing token; explicit is TRUE if the reference
   is, e.g., INTRINSIC FOO.  */

void
ffesymbol_reference (ffesymbol s, ffelexToken t, bool explicit)
{
  ffename gn;
  ffesymbol gs = NULL;
  ffeinfoKind kind;
  ffeinfoWhere where;
  bool okay;

  if (ffesymbol_retractable_)
    return;

  if (t == NULL)
    t = ffename_token (s->name);	/* Use the first reference in this program unit. */

  kind = ffesymbol_kind (s);
  where = ffesymbol_where (s);

  if (where == FFEINFO_whereINTRINSIC)
    {
      ffeglobal_ref_intrinsic (s, t,
			       explicit
			       || s->explicit_where
			       || ffeintrin_is_standard (s->generic, s->specific));
      return;
    }

  if ((where != FFEINFO_whereGLOBAL)
      && ((where != FFEINFO_whereLOCAL)
	  || ((kind != FFEINFO_kindFUNCTION)
	      && (kind != FFEINFO_kindSUBROUTINE))))
    return;

  gn = ffename_lookup (ffesymbol_global_, t);
  if (gn != NULL)
    gs = ffename_symbol (gn);
  if ((gs != NULL) && (gs != s))
    {
      /* We have just discovered another global symbol with the same name
	 but a different `nature'.  Complain.  Note that COMMON /FOO/ can
	 coexist with local symbol FOO, e.g. local variable, just not with
	 CALL FOO, hence the separate namespaces.  */

      ffesymbol_error (gs, t);
      ffesymbol_error (s, NULL);
      return;
    }