mirror of
https://git.FreeBSD.org/src.git
synced 2024-12-24 11:29:10 +00:00
1594 lines
42 KiB
C
1594 lines
42 KiB
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 *const 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 ()
|
||
{
|
||
}
|