Google Git
Sign in
gnu / gcc / 75bbfcfa8623f5b211475a54f52ced32201575e7 / . / gcc / f / global.c
blob: 85311f1860178df6c820e05fbe7f764ffefc1770 [file] [log] [blame]
/* 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 ()
{
}