#include "proj.h"
#include "global.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"
#include "name.h"
#include "symbol.h"
#include "top.h"
#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
#if FFEGLOBAL_ENABLED
void
ffeglobal_drive (ffeglobal (*fn) (ffeglobal))
{
if (ffeglobal_filewide_ != NULL)
ffename_space_drive_global (ffeglobal_filewide_, fn);
}
#endif
#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
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
}
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 ();
}
}
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
}
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
}
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)
{
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))
{
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))))
{
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);
}
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
}
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;
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
}
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;
ai = &g->u.proc.arg_info[argno];
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)
|| (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)
|| (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))
{
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))
{
if ((bt != ai->bt)
&& ((bt != FFEINFO_basictypeREAL)
|| (ai->bt != FFEINFO_basictypeCOMPLEX))
&& ((bt != FFEINFO_basictypeCOMPLEX)
|| (ai->bt != FFEINFO_basictypeREAL)))
{
warn = TRUE;
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 ();
}
}
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);
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;
}
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 ();
}
}
g->u.proc.n_args = n_args;
g->u.proc.other_t = NULL;
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;
}
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;
ai = &g->u.proc.arg_info[argno];
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)
|| (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)
|| (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))
{
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))
{
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;
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)
{
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;
}
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;
}
g->u.proc.n_args = n_args;
g->u.proc.other_t = ffelex_token_use (t);
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;
}
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
}
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
}
bool
ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type)
{
#if FFEGLOBAL_ENABLED
ffename n = NULL;
ffeglobal g;
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))
{
if ((((type == FFEGLOBAL_typeBDATA)
&& (g->type != FFEGLOBAL_typeCOMMON))
|| ((g->type == FFEGLOBAL_typeBDATA)
&& (type != FFEGLOBAL_typeCOMMON)
&& ! g->u.proc.defined)))
{
#if 0
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
}
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 ((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);
}
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
|| (g->u.proc.defined
&& ffesymbol_size (s) != g->u.proc.sz
&& ffesymbol_size (s) != FFETARGET_charactersizeNONE
&& g->u.proc.sz != FFETARGET_charactersizeNONE)))
{
int error;
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)
{
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
{
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 ())
{
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))
{
g->t = ffelex_token_use (t);
g->type = type;
#ifdef FFECOM_globalHOOK
g->hook = FFECOM_globalNULL;
#endif
g->u.proc.n_args = -1;
}
return TRUE;
#endif
}
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;
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
}
#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];
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];
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 ()
{
}