path: root/contrib/gcc/f/global.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. */

  ai = &g->u.proc.arg_info[argno];

  /* Maybe warn about previous references.  */

  if ((ai->t != NULL)
      && ffe_is_warn_globals ())
    {
      const char *refwhy = NULL;
      const char *defwhy = NULL;
      bool warn = FALSE;

      switch (as)
	{
	case FFEGLOBAL_argsummaryREF:
	  if ((ai->as != FFEGLOBAL_argsummaryREF)
	      && (ai->as != FFEGLOBAL_argsummaryNONE)
	      && ((ai->as != FFEGLOBAL_argsummaryDESCR)	/* Choose better message. */
		  || (ai->bt != FFEINFO_basictypeCHARACTER)
		  || (ai->bt == bt)))
	    {
	      warn = TRUE;
	      refwhy = "passed by reference";
	    }
	  break;

	case FFEGLOBAL_argsummaryDESCR:
	  if ((ai->as != FFEGLOBAL_argsummaryDESCR)
	      && (ai->as != FFEGLOBAL_argsummaryNONE)
	      && ((ai->as != FFEGLOBAL_argsummaryREF)	/* Choose better message. */
		  || (bt != FFEINFO_basictypeCHARACTER)
		  || (ai->bt == bt)))
	    {
	      warn = TRUE;
	      refwhy = "passed by descriptor";
	    }
	  break;

	case FFEGLOBAL_argsummaryPROC:
	  if ((ai->as != FFEGLOBAL_argsummaryPROC)
	      && (ai->as != FFEGLOBAL_argsummarySUBR)
	      && (ai->as != FFEGLOBAL_argsummaryFUNC)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      warn = TRUE;
	      refwhy = "a procedure";
	    }
	  break;

	case FFEGLOBAL_argsummarySUBR:
	  if ((ai->as != FFEGLOBAL_argsummaryPROC)
	      && (ai->as != FFEGLOBAL_argsummarySUBR)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      warn = TRUE;
	      refwhy = "a subroutine";
	    }
	  break;

	case FFEGLOBAL_argsummaryFUNC:
	  if ((ai->as != FFEGLOBAL_argsummaryPROC)
	      && (ai->as != FFEGLOBAL_argsummaryFUNC)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      warn = TRUE;
	      refwhy = "a function";
	    }
	  break;

	case FFEGLOBAL_argsummaryALTRTN:
	  if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      warn = TRUE;
	      refwhy = "an alternate-return label";
	    }
	  break;

	default:
	  break;
	}

      if ((refwhy != NULL) && (defwhy == NULL))
	{
	  /* Fill in the def info.  */

	  switch (ai->as)
	    {
	    case FFEGLOBAL_argsummaryNONE:
	      defwhy = "omitted";
	      break;

	    case FFEGLOBAL_argsummaryVAL:
	      defwhy = "passed by value";
	      break;

	    case FFEGLOBAL_argsummaryREF:
	      defwhy = "passed by reference";
	      break;

	    case FFEGLOBAL_argsummaryDESCR:
	      defwhy = "passed by descriptor";
	      break;

	    case FFEGLOBAL_argsummaryPROC:
	      defwhy = "a procedure";
	      break;

	    case FFEGLOBAL_argsummarySUBR:
	      defwhy = "a subroutine";
	      break;

	    case FFEGLOBAL_argsummaryFUNC:
	      defwhy = "a function";
	      break;

	    case FFEGLOBAL_argsummaryALTRTN:
	      defwhy = "an alternate-return label";
	      break;

#if 0
	    case FFEGLOBAL_argsummaryPTR:
	      defwhy = "a pointer";
	      break;
#endif

	    default:
	      defwhy = "???";
	      break;
	    }
	}

      if (!warn
	  && (bt != FFEINFO_basictypeHOLLERITH)
	  && (bt != FFEINFO_basictypeTYPELESS)
	  && (bt != FFEINFO_basictypeNONE)
	  && (ai->bt != FFEINFO_basictypeHOLLERITH)
	  && (ai->bt != FFEINFO_basictypeTYPELESS)
	  && (ai->bt != FFEINFO_basictypeNONE))
	{
	  /* Check types.  */

	  if ((bt != ai->bt)
	      && ((bt != FFEINFO_basictypeREAL)
		  || (ai->bt != FFEINFO_basictypeCOMPLEX))
	      && ((bt != FFEINFO_basictypeCOMPLEX)
		  || (ai->bt != FFEINFO_basictypeREAL)))
	    {
	      warn = TRUE;	/* We can cope with these differences. */
	      refwhy = "one type";
	      defwhy = "some other type";
	    }

	  if (!warn && (kt != ai->kt))
	    {
	      warn = TRUE;
	      refwhy = "one precision";
	      defwhy = "some other precision";
	    }
	}

      if (warn)
	{
	  char num[60];

	  if (name == NULL)
	    sprintf (&num[0], "%d", argno + 1);
	  else
	    {
	      if (strlen (name) < 30)
		sprintf (&num[0], "%d (named `%s')", argno + 1, name);
	      else
		sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name);
	    }
	  ffebad_start (FFEBAD_FILEWIDE_ARG_W);
	  ffebad_string (ffesymbol_text (s));
	  ffebad_string (num);
	  ffebad_string (refwhy);
	  ffebad_string (defwhy);
	  ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t));
	  ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
	  ffebad_finish ();
	}
    }

  /* Define this argument.  */

  if (ai->t != NULL)
    ffelex_token_kill (ai->t);
  if ((as != FFEGLOBAL_argsummaryPROC)
      || (ai->t == NULL))
    ai->as = as;	/* Otherwise leave SUBR/FUNC info intact. */
  ai->t = ffelex_token_use (g->t);
  if (name == NULL)
    ai->name = NULL;
  else
    {
      ai->name = malloc_new_ks (malloc_pool_image (),
				"ffeglobalArgInfo_ name",
				strlen (name) + 1);
      strcpy (ai->name, name);
    }
  ai->bt = bt;
  ai->kt = kt;
  ai->array = array;
}

/* Collect info on #args a global accepts.  */

void
ffeglobal_proc_def_nargs (ffesymbol s, int n_args)
{
  ffeglobal g = ffesymbol_global (s);

  assert (g != NULL);

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

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

      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 (g->u.proc.other_t),
		       ffelex_token_where_column (g->u.proc.other_t));
	  ffebad_here (1, ffelex_token_where_line (g->t),
		       ffelex_token_where_column (g->t));
	  ffebad_finish ();
	}
    }

  /* 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 = NULL;	/* No other reference yet. */

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

  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;
}

/* Verify that the info for a global's argument is valid.  */

bool
ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
			ffeinfoBasictype bt, ffeinfoKindtype kt,
			bool array, ffelexToken t)
{
  ffeglobal g = ffesymbol_global (s);
  ffeglobalArgInfo_ ai;

  assert (g != NULL);

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

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

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

  ai = &g->u.proc.arg_info[argno];

  /* Warn about previous references.  */

  if (ai->t != NULL)
    {
      const char *refwhy = NULL;
      const char *defwhy = NULL;
      bool fail = FALSE;
      bool warn = FALSE;

      switch (as)
	{
	case FFEGLOBAL_argsummaryNONE:
	  if (g->u.proc.defined)
	    {
	      fail = TRUE;
	      refwhy = "omitted";
	      defwhy = "not optional";
	    }
	  break;

	case FFEGLOBAL_argsummaryVAL:
	  if (ai->as != FFEGLOBAL_argsummaryVAL)
	    {
	      fail = TRUE;
	      refwhy = "passed by value";
	    }
	  break;

	case FFEGLOBAL_argsummaryREF:
	  if ((ai->as != FFEGLOBAL_argsummaryREF)
	      && (ai->as != FFEGLOBAL_argsummaryNONE)
	      && ((ai->as != FFEGLOBAL_argsummaryDESCR)	/* Choose better message. */
		  || (ai->bt != FFEINFO_basictypeCHARACTER)
		  || (ai->bt == bt)))
	    {
	      fail = TRUE;
	      refwhy = "passed by reference";
	    }
	  break;

	case FFEGLOBAL_argsummaryDESCR:
	  if ((ai->as != FFEGLOBAL_argsummaryDESCR)
	      && (ai->as != FFEGLOBAL_argsummaryNONE)
	      && ((ai->as != FFEGLOBAL_argsummaryREF)	/* Choose better message. */
		  || (bt != FFEINFO_basictypeCHARACTER)
		  || (ai->bt == bt)))
	    {
	      fail = TRUE;
	      refwhy = "passed by descriptor";
	    }
	  break;

	case FFEGLOBAL_argsummaryPROC:
	  if ((ai->as != FFEGLOBAL_argsummaryPROC)
	      && (ai->as != FFEGLOBAL_argsummarySUBR)
	      && (ai->as != FFEGLOBAL_argsummaryFUNC)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      fail = TRUE;
	      refwhy = "a procedure";
	    }
	  break;

	case FFEGLOBAL_argsummarySUBR:
	  if ((ai->as != FFEGLOBAL_argsummaryPROC)
	      && (ai->as != FFEGLOBAL_argsummarySUBR)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      fail = TRUE;
	      refwhy = "a subroutine";
	    }
	  break;

	case FFEGLOBAL_argsummaryFUNC:
	  if ((ai->as != FFEGLOBAL_argsummaryPROC)
	      && (ai->as != FFEGLOBAL_argsummaryFUNC)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      fail = TRUE;
	      refwhy = "a function";
	    }
	  break;

	case FFEGLOBAL_argsummaryALTRTN:
	  if ((ai->as != FFEGLOBAL_argsummaryALTRTN)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      fail = TRUE;
	      refwhy = "an alternate-return label";
	    }
	  break;

#if 0
	case FFEGLOBAL_argsummaryPTR:
	  if ((ai->as != FFEGLOBAL_argsummaryPTR)
	      && (ai->as != FFEGLOBAL_argsummaryNONE))
	    {
	      fail = TRUE;
	      refwhy = "a pointer";
	    }
	  break;
#endif

	default:
	  break;
	}

      if ((refwhy != NULL) && (defwhy == NULL))
	{
	  /* Fill in the def info.  */

	  switch (ai->as)
	    {
	    case FFEGLOBAL_argsummaryNONE:
	      defwhy = "omitted";
	      break;

	    case FFEGLOBAL_argsummaryVAL:
	      defwhy = "passed by value";
	      break;

	    case FFEGLOBAL_argsummaryREF:
	      defwhy = "passed by reference";
	      break;

	    case FFEGLOBAL_argsummaryDESCR:
	      defwhy = "passed by descriptor";
	      break;

	    case FFEGLOBAL_argsummaryPROC:
	      defwhy = "a procedure";
	      break;

	    case FFEGLOBAL_argsummarySUBR:
	      defwhy = "a subroutine";
	      break;

	    case FFEGLOBAL_argsummaryFUNC:
	      defwhy = "a function";
	      break;

	    case FFEGLOBAL_argsummaryALTRTN:
	      defwhy = "an alternate-return label";
	      break;

#if 0
	    case FFEGLOBAL_argsummaryPTR:
	      defwhy = "a pointer";
	      break;
#endif

	    default:
	      defwhy = "???";
	      break;
	    }
	}

      if (!fail && !warn
	  && (bt != FFEINFO_basictypeHOLLERITH)
	  && (bt != FFEINFO_basictypeTYPELESS)
	  && (bt != FFEINFO_basictypeNONE)
	  && (ai->bt != FFEINFO_basictypeHOLLERITH)
	  && (ai->bt != FFEINFO_basictypeNONE)
	  && (ai->bt != FFEINFO_basictypeTYPELESS))
	{
	  /* Check types.  */

	  if ((bt != ai->bt)
	      && ((bt != FFEINFO_basictypeREAL)
		  || (ai->bt != FFEINFO_basictypeCOMPLEX))
	      && ((bt != FFEINFO_basictypeCOMPLEX)
		  || (ai->bt != FFEINFO_basictypeREAL)))
	    {
	      if (((bt == FFEINFO_basictypeINTEGER)
		   && (ai->bt == FFEINFO_basictypeLOGICAL))
		  || ((bt == FFEINFO_basictypeLOGICAL)
		   && (ai->bt == FFEINFO_basictypeINTEGER)))
		warn = TRUE;	/* We can cope with these differences. */
	      else
		fail = TRUE;
	      refwhy = "one type";
	      defwhy = "some other type";
	    }

	  if (!fail && !warn && (kt != ai->kt))
	    {
	      fail = TRUE;
	      refwhy = "one precision";
	      defwhy = "some other precision";
	    }
	}

      if (fail && ! g->u.proc.defined)
	{
	  /* No point failing if we're worried only about invocations.  */
	  fail = FALSE;
	  warn = TRUE;
	}

      if (fail && ! ffe_is_globals ())
	{
	  warn = TRUE;
	  fail = FALSE;
	}

      if (fail || (warn && ffe_is_warn_globals ()))
	{
	  char num[60];

	  if (ai->name == NULL)
	    sprintf (&num[0], "%d", argno + 1);
	  else
	    {
	      if (strlen (ai->name) < 30)
		sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name);
	      else
		sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name);
	    }
	  ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W);
	  ffebad_string (ffesymbol_text (s));
	  ffebad_string (num);
	  ffebad_string (refwhy);
	  ffebad_string (defwhy);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t));
	  ffebad_finish ();
	  return (fail ? FALSE : TRUE);
	}

      if (warn)
	return TRUE;
    }

  /* Define this argument.  */

  if (ai->t != NULL)
    ffelex_token_kill (ai->t);
  if ((as != FFEGLOBAL_argsummaryPROC)
      || (ai->t == NULL))
    ai->as = as;
  ai->t = ffelex_token_use (g->t);
  ai->name = NULL;
  ai->bt = bt;
  ai->kt = kt;
  ai->array = array;
  return TRUE;
}

bool
ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t)
{
  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 ()
{
}