global.c

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

{
  ffeglobal g = ffesymbol_global (s);

  assert (g != NULL);

  if (g->type == FFEGLOBAL_typeANY)
    return FALSE;

  if (g->u.proc.n_args >= 0)
    {
      if (g->u.proc.n_args == n_args)
	return TRUE;

      if (g->u.proc.defined && ffe_is_globals ())
	{
	  ffebad_start (FFEBAD_FILEWIDE_NARGS);
	  ffebad_string (ffesymbol_text (s));
	  if (g->u.proc.n_args > n_args)
	    ffebad_string ("few");
	  else
	    ffebad_string ("many");
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (g->t),
		       ffelex_token_where_column (g->t));
	  ffebad_finish ();
	  return FALSE;
	}

      if (ffe_is_warn_globals ())
	{
	  ffebad_start (FFEBAD_FILEWIDE_NARGS_W);
	  ffebad_string (ffesymbol_text (s));
	  if (g->u.proc.n_args > n_args)
	    ffebad_string ("few");
	  else
	    ffebad_string ("many");
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (g->t),
		       ffelex_token_where_column (g->t));
	  ffebad_finish ();
	}

      return TRUE;		/* Don't replace the info we already have. */
    }

  /* This is new info we can use in cross-checking future references
     and a possible future definition.  */

  g->u.proc.n_args = n_args;
  g->u.proc.other_t = ffelex_token_use (t);

  /* Make this "the" place we found the global, since it has the most info.  */

  if (g->t != NULL)
    ffelex_token_kill (g->t);
  g->t = ffelex_token_use (t);

  if (n_args == 0)
    {
      g->u.proc.arg_info = NULL;
      return TRUE;
    }

  g->u.proc.arg_info
    = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (),
					 "ffeglobalArgInfo_",
					 n_args * sizeof (g->u.proc.arg_info[0]));
  while (n_args-- > 0)
    g->u.proc.arg_info[n_args].t = NULL;

  return TRUE;
}

/* Return a global for a promoted symbol (one that has heretofore
   been assumed to be local, but since discovered to be global).  */

ffeglobal
ffeglobal_promoted (ffesymbol s)
{
#if FFEGLOBAL_ENABLED
  ffename n;
  ffeglobal g;

  assert (ffesymbol_global (s) == NULL);

  n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s)));
  g = ffename_global (n);

  return g;
#else
  return NULL;
#endif
}

/* Register a reference to an intrinsic.  Such a reference is always
   valid, though a warning might be in order if the same name has
   already been used for a global.  */

void
ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit)
{
#if FFEGLOBAL_ENABLED
  ffename n;
  ffeglobal g;

  if (ffesymbol_global (s) == NULL)
    {
      n = ffename_find (ffeglobal_filewide_, t);
      g = ffename_global (n);
    }
  else
    {
      g = ffesymbol_global (s);
      n = NULL;
    }

  if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
    return;

  if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE))
    {
      if (! explicit
	  && ! g->intrinsic
	  && ffe_is_warn_globals ())
	{
	  /* This name, previously used as a global, now is used
	     for an intrinsic.  Warn, since this new use as an
	     intrinsic might have been intended to refer to
	     the global procedure.  */
	  ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
	  ffebad_string (ffelex_token_text (t));
	  ffebad_string ("intrinsic");
	  ffebad_string ("global");
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (g->t),
		       ffelex_token_where_column (g->t));
	  ffebad_finish ();
	}
    }
  else
    {
      if (g == NULL)
	{
	  g = ffeglobal_new_ (n);
	  g->tick = ffe_count_2;
	  g->type = FFEGLOBAL_typeNONE;
	  g->intrinsic = TRUE;
	  g->explicit_intrinsic = explicit;
	  g->t = ffelex_token_use (t);
	}
      else if (g->intrinsic
	       && (explicit != g->explicit_intrinsic)
	       && (g->tick != ffe_count_2)
	       && ffe_is_warn_globals ())
	{
	  /* An earlier reference to this intrinsic disagrees with
	     this reference vis-a-vis explicit `intrinsic foo',
	     which suggests that the one relying on implicit
	     intrinsicacity might have actually intended to refer
	     to a global of the same name.  */
	  ffebad_start (FFEBAD_INTRINSIC_EXPIMP);
	  ffebad_string (ffelex_token_text (t));
	  ffebad_string (explicit ? "explicit" : "implicit");
	  ffebad_string (explicit ? "implicit" : "explicit");
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (g->t),
		       ffelex_token_where_column (g->t));
	  ffebad_finish ();
	}
    }

  g->intrinsic = TRUE;
  if (explicit)
    g->explicit_intrinsic = TRUE;

  ffesymbol_set_global (s, g);
#endif
}

/* Register a reference to a global.  Returns TRUE if the reference
   is valid.  */

bool
ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
{
#if FFEGLOBAL_ENABLED
  ffename n = NULL;
  ffeglobal g;

  /* It is never really _known_ that an EXTERNAL statement
     names a BLOCK DATA by just looking at the program unit,
     so override a different notion here.  */
  if (type == FFEGLOBAL_typeBDATA)
    type = FFEGLOBAL_typeEXT;

  g = ffesymbol_global (s);
  if (g == NULL)
    {
      n = ffename_find (ffeglobal_filewide_, t);
      g = ffename_global (n);
      if (g != NULL)
	ffesymbol_set_global (s, g);
    }

  if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
    return TRUE;

  if ((g != NULL)
      && (g->type != FFEGLOBAL_typeNONE)
      && (g->type != FFEGLOBAL_typeEXT)
      && (g->type != type)
      && (type != FFEGLOBAL_typeEXT))
    {
      /* Disagreement about (fully refined) class of program unit
	 (main, subroutine, function, block data).  Treat EXTERNAL/
	 COMMON disagreements distinctly.  */
      if ((((type == FFEGLOBAL_typeBDATA)
	    && (g->type != FFEGLOBAL_typeCOMMON))
	   || ((g->type == FFEGLOBAL_typeBDATA)
	       && (type != FFEGLOBAL_typeCOMMON)
	       && ! g->u.proc.defined)))
	{
#if 0	/* This is likely to just annoy people. */
	  if (ffe_is_warn_globals ())
	    {
	      /* Warn about EXTERNAL of a COMMON name, though it works.  */
	      ffebad_start (FFEBAD_FILEWIDE_TIFF);
	      ffebad_string (ffelex_token_text (t));
	      ffebad_string (ffeglobal_type_string_[type]);
	      ffebad_string (ffeglobal_type_string_[g->type]);
	      ffebad_here (0, ffelex_token_where_line (t),
			   ffelex_token_where_column (t));
	      ffebad_here (1, ffelex_token_where_line (g->t),
			   ffelex_token_where_column (g->t));
	      ffebad_finish ();
	    }
#endif
	}
      else if (ffe_is_globals () || ffe_is_warn_globals ())
	{
	  ffebad_start (ffe_is_globals ()
			? FFEBAD_FILEWIDE_DISAGREEMENT
			: FFEBAD_FILEWIDE_DISAGREEMENT_W);
	  ffebad_string (ffelex_token_text (t));
	  ffebad_string (ffeglobal_type_string_[type]);
	  ffebad_string (ffeglobal_type_string_[g->type]);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (g->t),
		       ffelex_token_where_column (g->t));
	  ffebad_finish ();
	  g->type = FFEGLOBAL_typeANY;
	  return (! ffe_is_globals ());
	}
    }

  if ((g != NULL)
      && (type == FFEGLOBAL_typeFUNC))
    {
      /* If just filling in this function's type, do so.  */
      if ((g->tick == ffe_count_2)
	  && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
	  && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE))
	{
	  g->u.proc.bt = ffesymbol_basictype (s);
	  g->u.proc.kt = ffesymbol_kindtype (s);
	  g->u.proc.sz = ffesymbol_size (s);
	}
      /* Make sure there is type agreement.  */
      if (g->type == FFEGLOBAL_typeFUNC
	  && g->u.proc.bt != FFEINFO_basictypeNONE
	  && ffesymbol_basictype (s) != FFEINFO_basictypeNONE
	  && (ffesymbol_basictype (s) != g->u.proc.bt
	      || ffesymbol_kindtype (s) != g->u.proc.kt
	      /* CHARACTER*n disagreements matter only once a
		 definition is involved, since the definition might
		 be CHARACTER*(*), which accepts all references.  */
	      || (g->u.proc.defined
		  && ffesymbol_size (s) != g->u.proc.sz
		  && ffesymbol_size (s) != FFETARGET_charactersizeNONE
		  && g->u.proc.sz != FFETARGET_charactersizeNONE)))
	{
	  int error;

	  /* Type mismatch between function reference/definition and
	     this subsequent reference (which might just be the filling-in
	     of type info for the definition, but we can't reach here
	     if that's the case and there was a previous definition).

	     It's an error given a previous definition, since that
	     implies inlining can crash the compiler, unless the user
	     asked for no such inlining.  */
	  error = (g->tick != ffe_count_2
		   && g->u.proc.defined
		   && ffe_is_globals ());
	  if (error || ffe_is_warn_globals ())
	    {
	      ffebad_start (error
			    ? FFEBAD_FILEWIDE_TYPE_MISMATCH
			    : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
	      ffebad_string (ffelex_token_text (t));
	      if (g->tick == ffe_count_2)
		{
		  /* Current reference fills in type info for definition.
		     The current token doesn't necessarily point to the actual
		     definition of the function, so use the definition pointer
		     and the pointer to the pre-definition type info.  */
		  ffebad_here (0, ffelex_token_where_line (g->t),
			       ffelex_token_where_column (g->t));
		  ffebad_here (1, ffelex_token_where_line (g->u.proc.other_t),
			       ffelex_token_where_column (g->u.proc.other_t));
		}
	      else
		{
		  /* Current reference is not a filling-in of a current
		     definition.  The current token is fine, as is
		     the previous-mention token.  */
		  ffebad_here (0, ffelex_token_where_line (t),
			       ffelex_token_where_column (t));
		  ffebad_here (1, ffelex_token_where_line (g->t),
			       ffelex_token_where_column (g->t));
		}
	      ffebad_finish ();
	      if (error)
		g->type = FFEGLOBAL_typeANY;
	      return FALSE;
	    }
	}
    }

  if (g == NULL)
    {
      g = ffeglobal_new_ (n);
      g->t = ffelex_token_use (t);
      g->tick = ffe_count_2;
      g->intrinsic = FALSE;
      g->type = type;
      g->u.proc.defined = FALSE;
      g->u.proc.bt = ffesymbol_basictype (s);
      g->u.proc.kt = ffesymbol_kindtype (s);
      g->u.proc.sz = ffesymbol_size (s);
      g->u.proc.n_args = -1;
      ffesymbol_set_global (s, g);
    }
  else if (g->intrinsic
	   && !g->explicit_intrinsic
	   && (g->tick != ffe_count_2)
	   && ffe_is_warn_globals ())
    {
      /* Now known as a global, this name previously was seen as an
	 intrinsic.  Warn, in case the previous reference was intended
	 for the same global.  */
      ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
      ffebad_string (ffelex_token_text (t));
      ffebad_string ("global");
      ffebad_string ("intrinsic");
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_here (1, ffelex_token_where_line (g->t),
		   ffelex_token_where_column (g->t));
      ffebad_finish ();
    }

  if ((g->type != type)
      && (type != FFEGLOBAL_typeEXT))
    {
      /* We've learned more, so point to where we learned it.  */
      g->t = ffelex_token_use (t);
      g->type = type;
#ifdef FFECOM_globalHOOK
      g->hook = FFECOM_globalNULL;	/* Discard previous _DECL. */
#endif
      g->u.proc.n_args = -1;
    }

  return TRUE;
#endif
}

/* ffeglobal_save_common -- Check SAVE status of common area

   ffesymbol s;	 // the common area
   bool save;  // TRUE if SAVEd, FALSE otherwise
   ffeglobal_save_common(s,save,ffesymbol_where_line(s),
	 ffesymbol_where_column(s));

   In global-enabled mode, make sure the save info agrees with any existing
   info established for the common area, otherwise complain.
   In global-disabled mode, do nothing.	 */

void
ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
		       ffewhereColumn wc)
{
#if FFEGLOBAL_ENABLED
  ffeglobal g;

  g = ffesymbol_global (s);
  if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
    return;			/* Let someone else catch this! */
  if (g->type == FFEGLOBAL_typeANY)
    return;

  if (!g->u.common.have_save)
    {
      g->u.common.have_save = TRUE;
      g->u.common.save = save;
      g->u.common.save_where_line = ffewhere_line_use (wl);
      g->u.common.save_where_col = ffewhere_column_use (wc);
    }
  else
    {
      if ((g->u.common.save != save) && ffe_is_pedantic ())
	{
	  ffebad_start (FFEBAD_COMMON_DIFF_SAVE);
	  ffebad_string (ffesymbol_text (s));
	  ffebad_here (save ? 0 : 1, wl, wc);
	  ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col);
	  ffebad_finish ();
	}
    }
#endif
}

/* ffeglobal_size_common -- Establish size of COMMON area

   ffesymbol s;	 // the common area
   ffetargetOffset size;  // size in units
   if (ffeglobal_size_common(s,size))  // new size is largest seen

   In global-enabled mode, set the size if it current size isn't known or is
   smaller than new size, and for non-blank common, complain if old size
   is different from new.  Return TRUE if the new size is the largest seen
   for this COMMON area (or if no size was known for it previously).
   In global-disabled mode, do nothing.	 */

#if FFEGLOBAL_ENABLED
bool
ffeglobal_size_common (ffesymbol s, ffetargetOffset size)
{
  ffeglobal g;

  g = ffesymbol_global (s);
  if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON))
    return FALSE;
  if (g->type == FFEGLOBAL_typeANY)
    return FALSE;

  if (!g->u.common.have_size)
    {
      g->u.common.have_size = TRUE;
      g->u.common.size = size;
      return TRUE;
    }

  if ((g->tick > 0) && (g->tick < ffe_count_2)
      && (g->u.common.size < size))
    {
      char oldsize[40];
      char newsize[40];

      /* Common block initialized in a previous program unit, which
	 effectively freezes its size, but now the program is trying
	 to enlarge it.  */

      sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
      sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);

      ffebad_start (FFEBAD_COMMON_ENLARGED);
      ffebad_string (ffesymbol_text (s));
      ffebad_string (oldsize);
      ffebad_string (newsize);
      ffebad_string ((g->u.common.size == 1)
		     ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
      ffebad_string ((size == 1)
		     ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
      ffebad_here (0, ffelex_token_where_line (g->u.common.initt),
		   ffelex_token_where_column (g->u.common.initt));
      ffebad_here (1, ffesymbol_where_line (s),
		   ffesymbol_where_column (s));
      ffebad_finish ();
    }
  else if ((g->u.common.size != size) && !g->u.common.blank)
    {
      char oldsize[40];
      char newsize[40];

      /* Warn about this even if not -pedantic, because putting all
	 program units in a single source file is the only way to
	 detect this.  Apparently UNIX-model linkers neither handle
	 nor report when they make a common unit smaller than
	 requested, such as when the smaller-declared version is
	 initialized and the larger-declared version is not.  So
	 if people complain about strange overwriting, we can tell
	 them to put all their code in a single file and compile
	 that way.  Warnings about differing sizes must therefore
	 always be issued.  */

      sprintf (&oldsize[0], "%" ffetargetOffset_f "d", g->u.common.size);
      sprintf (&newsize[0], "%" ffetargetOffset_f "d", size);

      ffebad_start (FFEBAD_COMMON_DIFF_SIZE);
      ffebad_string (ffesymbol_text (s));
      ffebad_string (oldsize);
      ffebad_string (newsize);
      ffebad_string ((g->u.common.size == 1)
		     ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
      ffebad_string ((size == 1)
		     ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
      ffebad_here (0, ffelex_token_where_line (g->t),
		   ffelex_token_where_column (g->t));
      ffebad_here (1, ffesymbol_where_line (s),
		   ffesymbol_where_column (s));
      ffebad_finish ();
    }

  if (size > g->u.common.size)
    {
      g->u.common.size = size;
      return TRUE;
    }

  return FALSE;
}

#endif
void
ffeglobal_terminate_1 ()
{
}