global.c

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

/* global.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:

   Description:
      Manages information kept across individual program units within a single
      source file.  This includes reporting errors when a name is defined
      multiple times (for example, two program units named FOO) and when a
      COMMON block is given initial data in more than one program unit.

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "global.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"
#include "name.h"
#include "symbol.h"
#include "top.h"

/* Externals defined here. */


/* Simple definitions and enumerations. */


/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


/* Static objects accessed by functions in this module. */

#if FFEGLOBAL_ENABLED
static ffenameSpace ffeglobal_filewide_ = NULL;
static const char *ffeglobal_type_string_[] =
{
  [FFEGLOBAL_typeNONE] "??",
  [FFEGLOBAL_typeMAIN] "main program",
  [FFEGLOBAL_typeEXT] "external",
  [FFEGLOBAL_typeSUBR] "subroutine",
  [FFEGLOBAL_typeFUNC] "function",
  [FFEGLOBAL_typeBDATA] "block data",
  [FFEGLOBAL_typeCOMMON] "common block",
  [FFEGLOBAL_typeANY] "?any?"
};
#endif

/* Static functions (internal). */


/* Internal macros. */


/* Call given fn with all globals

   ffeglobal (*fn)(ffeglobal g);
   ffeglobal_drive(fn);	 */

#if FFEGLOBAL_ENABLED
void
ffeglobal_drive (ffeglobal (*fn) (ffeglobal))
{
  if (ffeglobal_filewide_ != NULL)
    ffename_space_drive_global (ffeglobal_filewide_, fn);
}

#endif
/* ffeglobal_new_ -- Make new global

   ffename n;
   ffeglobal g;
   g = ffeglobal_new_(n);  */

#if FFEGLOBAL_ENABLED
static ffeglobal
ffeglobal_new_ (ffename n)
{
  ffeglobal g;

  assert (n != NULL);

  g = (ffeglobal) malloc_new_ks (malloc_pool_image (), "FFEGLOBAL",
				 sizeof (*g));
  g->n = n;
#ifdef FFECOM_globalHOOK
  g->hook = FFECOM_globalNULL;
#endif
  g->tick = 0;

  ffename_set_global (n, g);

  return g;
}

#endif
/* ffeglobal_init_1 -- Initialize per file

   ffeglobal_init_1();	*/

void
ffeglobal_init_1 ()
{
#if FFEGLOBAL_ENABLED
  if (ffeglobal_filewide_ != NULL)
    ffename_space_kill (ffeglobal_filewide_);
  ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ());
#endif
}

/* ffeglobal_init_common -- Initial value specified for common block

   ffesymbol s;	 // the ffesymbol for the common block
   ffelexToken t;  // the token with the point of initialization
   ffeglobal_init_common(s,t);

   For back ends where file-wide global symbols are not maintained, does
   nothing.  Otherwise, makes sure this common block hasn't already been
   initialized in a previous program unit, and flag that it's been
   initialized in this one.  */

void
ffeglobal_init_common (ffesymbol s, ffelexToken t)
{
#if FFEGLOBAL_ENABLED
  ffeglobal g;

  g = ffesymbol_global (s);

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

  if (g->tick == ffe_count_2)
    return;

  if (g->tick != 0)
    {
      if (g->u.common.initt != NULL)
	{
	  ffebad_start (FFEBAD_COMMON_ALREADY_INIT);
	  ffebad_string (ffesymbol_text (s));
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (g->u.common.initt),
		       ffelex_token_where_column (g->u.common.initt));
	  ffebad_finish ();
	}

      /* Complain about just one attempt to reinit per program unit, but
	 continue referring back to the first such successful attempt.  */
    }
  else
    {
      if (g->u.common.blank)
	{
	  /* Not supposed to initialize blank common, though it works.  */
	  ffebad_start (FFEBAD_COMMON_BLANK_INIT);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_finish ();
	}

      g->u.common.initt = ffelex_token_use (t);
    }

  g->tick = ffe_count_2;
#endif
}

/* ffeglobal_new_common -- New common block

   ffesymbol s;	 // the ffesymbol for the new common block
   ffelexToken t;  // the token with the name of the common block
   bool blank;	// TRUE if blank common
   ffeglobal_new_common(s,t,blank);

   For back ends where file-wide global symbols are not maintained, does
   nothing.  Otherwise, makes sure this symbol hasn't been seen before or
   is known as a common block.	*/

void
ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank)
{
#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 (g->type == FFEGLOBAL_typeCOMMON)
	{
	  /* The names match, so the "blankness" should match too!  */
	  assert (g->u.common.blank == blank);
	}
      else
	{
	  /* This global name has already been established,
	     but as something other than a common block.  */
	  if (ffe_is_globals () || ffe_is_warn_globals ())
	    {
	      ffebad_start (ffe_is_globals ()
			    ? FFEBAD_FILEWIDE_ALREADY_SEEN
			    : FFEBAD_FILEWIDE_ALREADY_SEEN_W);
	      ffebad_string (ffelex_token_text (t));
	      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;
	}
    }
  else
    {
      if (g == NULL)
	{
	  g = ffeglobal_new_ (n);
	  g->intrinsic = FALSE;
	}
      else if (g->intrinsic
	       && !g->explicit_intrinsic
	       && ffe_is_warn_globals ())
	{
	  /* Common name previously used as intrinsic.  Though it works,
	     warn, because the intrinsic reference might have been intended
	     as a ref to an external procedure, but g77's vast list of
	     intrinsics happened to snarf the name.  */
	  ffebad_start (FFEBAD_INTRINSIC_GLOBAL);
	  ffebad_string (ffelex_token_text (t));
	  ffebad_string ("common block");
	  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 ();
	}
      g->t = ffelex_token_use (t);
      g->type = FFEGLOBAL_typeCOMMON;
      g->u.common.have_pad = FALSE;
      g->u.common.have_save = FALSE;
      g->u.common.have_size = FALSE;
      g->u.common.blank = blank;
    }

  ffesymbol_set_global (s, g);
#endif
}

/* ffeglobal_new_progunit_ -- New program unit

   ffesymbol s;	 // the ffesymbol for the new unit
   ffelexToken t;  // the token with the name of the unit
   ffeglobalType type;	// the type of the new unit
   ffeglobal_new_progunit_(s,t,type);

   For back ends where file-wide global symbols are not maintained, does
   nothing.  Otherwise, makes sure this symbol hasn't been seen before.	 */

void
ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
{
#if FFEGLOBAL_ENABLED
  ffename n;
  ffeglobal g;

  n = ffename_find (ffeglobal_filewide_, t);
  g = ffename_global (n);
  if ((g != NULL) && (g->type == FFEGLOBAL_typeANY))
    return;

  if ((g != NULL)
      && ((g->type == FFEGLOBAL_typeMAIN)
	  || (g->type == FFEGLOBAL_typeSUBR)
	  || (g->type == FFEGLOBAL_typeFUNC)
	  || (g->type == FFEGLOBAL_typeBDATA))
      && g->u.proc.defined)
    {
      /* This program unit has already been defined.  */
      if (ffe_is_globals () || ffe_is_warn_globals ())
	{
	  ffebad_start (ffe_is_globals ()
			? FFEBAD_FILEWIDE_ALREADY_SEEN
			: FFEBAD_FILEWIDE_ALREADY_SEEN_W);
	  ffebad_string (ffelex_token_text (t));
	  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;
    }
  else if ((g != NULL)
	   && (g->type != FFEGLOBAL_typeNONE)
	   && (g->type != FFEGLOBAL_typeEXT)
	   && (g->type != type))
    {
      /* A reference to this program unit has been seen, but its
	 context disagrees about the new definition regarding
	 what kind of program unit it is.  (E.g. `call foo' followed
	 by `function foo'.)  But `external foo' alone doesn't mean
	 disagreement with either a function or subroutine, though
	 g77 normally interprets it as a request to force-load
	 a block data program unit by that name (to cope with libs).  */
      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;
    }
  else
    {
      if (g == NULL)
	{
	  g = ffeglobal_new_ (n);
	  g->intrinsic = FALSE;
	  g->u.proc.n_args = -1;
	  g->u.proc.other_t = NULL;
	}
      else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
	       && (g->type == FFEGLOBAL_typeFUNC)
	       && ((ffesymbol_basictype (s) != g->u.proc.bt)
		   || (ffesymbol_kindtype (s) != g->u.proc.kt)
		   || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE)
		       && (ffesymbol_size (s) != g->u.proc.sz))))
	{
	  /* The previous reference and this new function definition
	     disagree about the type of the function.  I (Burley) think
	     this rarely occurs, because when this code is reached,
	     the type info doesn't appear to be filled in yet.  */
	  if (ffe_is_globals () || ffe_is_warn_globals ())
	    {
	      ffebad_start (ffe_is_globals ()
			    ? FFEBAD_FILEWIDE_TYPE_MISMATCH
			    : FFEBAD_FILEWIDE_TYPE_MISMATCH_W);
	      ffebad_string (ffelex_token_text (t));
	      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;
	}
      if (g->intrinsic
	  && !g->explicit_intrinsic
	  && ffe_is_warn_globals ())
	{
	  /* This name, previously used as an intrinsic, now is known
	     to also be a global procedure name.  Warn, since the previous
	     use as an intrinsic might have been intended to refer to
	     this procedure.  */
	  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 ();
	}
      g->t = ffelex_token_use (t);
      if ((g->tick == 0)
	  || (g->u.proc.bt == FFEINFO_basictypeNONE)
	  || (g->u.proc.kt == FFEINFO_kindtypeNONE))
	{
	  g->u.proc.bt = ffesymbol_basictype (s);
	  g->u.proc.kt = ffesymbol_kindtype (s);
	  g->u.proc.sz = ffesymbol_size (s);
	}
      /* If there's a known disagreement about the kind of program
	 unit, then don't even bother tracking arglist argreement.  */
      if ((g->tick != 0)
	  && (g->type != type))
	g->u.proc.n_args = -1;
      g->tick = ffe_count_2;
      g->type = type;
      g->u.proc.defined = TRUE;
    }

  ffesymbol_set_global (s, g);
#endif
}

/* ffeglobal_pad_common -- Check initial padding of common area

   ffesymbol s;	 // the common area
   ffetargetAlign pad;	// the initial padding
   ffeglobal_pad_common(s,pad,ffesymbol_where_line(s),
	 ffesymbol_where_column(s));

   In global-enabled mode, make sure the padding agrees with any existing
   padding established for the common area, otherwise complain.
   In global-disabled mode, warn about nonzero padding.	 */

void
ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, 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_pad)
    {
      g->u.common.have_pad = TRUE;
      g->u.common.pad = pad;
      g->u.common.pad_where_line = ffewhere_line_use (wl);
      g->u.common.pad_where_col = ffewhere_column_use (wc);

      if (pad != 0)
	{
	  char padding[20];

	  sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
	  ffebad_start (FFEBAD_COMMON_INIT_PAD);
	  ffebad_string (ffesymbol_text (s));
	  ffebad_string (padding);
	  ffebad_string ((pad == 1)
			 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
	  ffebad_here (0, wl, wc);
	  ffebad_finish ();
	}
    }
  else
    {
      if (g->u.common.pad != pad)
	{
	  char padding_1[20];
	  char padding_2[20];

	  sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad);
	  sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad);
	  ffebad_start (FFEBAD_COMMON_DIFF_PAD);
	  ffebad_string (ffesymbol_text (s));
	  ffebad_string (padding_1);
	  ffebad_here (0, wl, wc);
	  ffebad_string (padding_2);
	  ffebad_string ((pad == 1)
			 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
	  ffebad_string ((g->u.common.pad == 1)
			 ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
	  ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col);
	  ffebad_finish ();
	}

      if (g->u.common.pad < pad)
	{
	  g->u.common.pad = pad;
	  g->u.common.pad_where_line = ffewhere_line_use (wl);
	  g->u.common.pad_where_col = ffewhere_column_use (wc);
	}
    }
#endif
}

/* Collect info for a global's argument.  */

void
ffeglobal_proc_def_arg (ffesymbol s, int argno, const char *name, ffeglobalArgSummary as,
			ffeinfoBasictype bt, ffeinfoKindtype kt,
			bool array)
{
  ffeglobal g = ffesymbol_global (s);
  ffeglobalArgInfo_ ai;

  assert (g != NULL);

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

  assert (g->u.proc.n_args >= 0);

  if (argno >= g->u.proc.n_args)
    return;	/* Already complained about this discrepancy. */