aboutsummaryrefslogtreecommitdiff
path: root/gcc/f/global.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/f/global.c')
-rw-r--r--gcc/f/global.c1490
1 files changed, 1490 insertions, 0 deletions
diff --git a/gcc/f/global.c b/gcc/f/global.c
new file mode 100644
index 00000000000..033448deaa4
--- /dev/null
+++ b/gcc/f/global.c
@@ -0,0 +1,1490 @@
+/* global.c -- Implementation File (module.c template V1.0)
+ Copyright (C) 1995 Free Software Foundation, Inc.
+ Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
+
+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 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) ())
+{
+ 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)
+ {
+ 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)
+ {
+ assert (g->u.common.blank == blank);
+ }
+ else
+ {
+ 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 ())
+ {
+ 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_typeNONE)
+ && (g->type != FFEGLOBAL_typeEXT)
+ && ((g->type != type)
+ || (g->u.proc.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 = 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)
+ && ((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))))
+ {
+ 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 ())
+ {
+ 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);
+ }
+ g->tick = ffe_count_2;
+ if ((g->tick != 0)
+ && (g->type != type))
+ g->u.proc.n_args = -1;
+ 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);
+ }
+ 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 ();
+ }
+ }
+#endif
+
+ if (pad != 0)
+ { /* Warn about initial padding in common area. */
+ 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 ();
+ }
+}
+
+/* Collect info for a global's argument. */
+
+void
+ffeglobal_proc_def_arg (ffesymbol s, int argno, 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 ())
+ {
+ char *refwhy = NULL;
+ 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;
+
+ case FFEGLOBAL_argsummaryPTR:
+ defwhy = "a pointer";
+ break;
+
+ 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)
+ {
+ char *refwhy = NULL;
+ 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;
+
+ case FFEGLOBAL_argsummaryPTR:
+ if ((ai->as != FFEGLOBAL_argsummaryPTR)
+ && (ai->as != FFEGLOBAL_argsummaryNONE))
+ {
+ fail = TRUE;
+ refwhy = "a pointer";
+ }
+ 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;
+
+ case FFEGLOBAL_argsummaryPTR:
+ defwhy = "a pointer";
+ break;
+
+ 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 ())
+ {
+ 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 ())
+ {
+ 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;
+
+ 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 != type)
+ && (g->type != FFEGLOBAL_typeEXT)
+ && (type != FFEGLOBAL_typeEXT))
+ {
+ 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 ())
+ {
+ 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
+ /* It is never really _known_ that an EXTERNAL statement
+ names a BLOCK DATA by just looking at the program unit,
+ so don't override a different notion. */
+ if (type == FFEGLOBAL_typeBDATA)
+ type = FFEGLOBAL_typeEXT;
+ }
+ else if (ffe_is_globals ())
+ {
+ ffebad_start (FFEBAD_FILEWIDE_DISAGREEMENT);
+ 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 FALSE;
+ }
+ else if (ffe_is_warn_globals ())
+ {
+ ffebad_start (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 TRUE;
+ }
+ }
+
+ 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);
+ }
+ /* Else, make sure there is type agreement. */
+ else if ((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)
+ || ((ffesymbol_size (s) != g->u.proc.sz)
+ && (g->u.proc.sz != FFETARGET_charactersizeNONE))))
+ {
+ if (ffe_is_globals ())
+ {
+ ffebad_start (FFEBAD_FILEWIDE_TYPE_MISMATCH);
+ 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 FALSE;
+ }
+ if (ffe_is_warn_globals ())
+ {
+ ffebad_start (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 TRUE;
+ }
+ }
+
+ 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 ())
+ {
+ 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;
+ 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
+ long 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, long 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->u.common.size < size) && (g->tick > 0) && (g->tick < ffe_count_2))
+ {
+ char oldsize[40];
+ char newsize[40];
+
+ sprintf (&oldsize[0], "%ld", g->u.common.size);
+ sprintf (&newsize[0], "%ld", 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], "%ld", g->u.common.size);
+ sprintf (&newsize[0], "%ld", 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 ()
+{
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-18 14:03:05 +0000