freebsd-dev/contrib/gcc/f/storag.c
1999-10-16 06:09:09 +00:00

574 lines
15 KiB
C
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/* storag.c -- Implementation File (module.c template V1.0)
Copyright (C) 1995, 1996 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:
None
Description:
Maintains information on storage (memory) relationships between
COMMON, dummy, and local variables, plus their equivalences (dummies
don't have equivalences, however).
Modifications:
*/
/* Include files. */
#include "proj.h"
#include "storag.h"
#include "data.h"
#include "malloc.h"
#include "symbol.h"
#include "target.h"
/* Externals defined here. */
ffestoragList_ ffestorag_list_;
/* Simple definitions and enumerations. */
/* Internal typedefs. */
/* Private include files. */
/* Internal structure definitions. */
/* Static objects accessed by functions in this module. */
static ffetargetOffset ffestorag_local_size_; /* #units allocated so far. */
static bool ffestorag_reported_;/* Reports happen only once. */
/* Static functions (internal). */
/* Internal macros. */
#define ffestorag_next_(s) ((s)->next)
#define ffestorag_previous_(s) ((s)->previous)
/* ffestorag_drive -- Drive fn from list of storage objects
ffestoragList sl;
void (*fn)(ffestorag mst,ffestorag st);
ffestorag mst; // the master ffestorag object (or whatever)
ffestorag_drive(sl,fn,mst);
Calls (*fn)(mst,st) for every st in the list sl. */
void
ffestorag_drive (ffestoragList sl, void (*fn) (ffestorag mst, ffestorag st),
ffestorag mst)
{
ffestorag st;
for (st = sl->first;
st != (ffestorag) &sl->first;
st = st->next)
(*fn) (mst, st);
}
/* ffestorag_dump -- Dump information on storage object
ffestorag s; // the ffestorag object
ffestorag_dump(s);
Dumps information in the storage object. */
void
ffestorag_dump (ffestorag s)
{
if (s == NULL)
{
fprintf (dmpout, "(no storage object)");
return;
}
switch (s->type)
{
case FFESTORAG_typeCBLOCK:
fprintf (dmpout, "CBLOCK ");
break;
case FFESTORAG_typeCOMMON:
fprintf (dmpout, "COMMON ");
break;
case FFESTORAG_typeLOCAL:
fprintf (dmpout, "LOCAL ");
break;
case FFESTORAG_typeEQUIV:
fprintf (dmpout, "EQUIV ");
break;
default:
fprintf (dmpout, "?%d? ", s->type);
break;
}
if (s->symbol != NULL)
fprintf (dmpout, "\"%s\" ", ffesymbol_text (s->symbol));
fprintf (dmpout, "at %" ffetargetOffset_f "d size %" ffetargetOffset_f
"d, align loc%%%"
ffetargetAlign_f "u=%" ffetargetAlign_f "u, bt=%s, kt=%s",
s->offset,
s->size, (unsigned int) s->alignment, (unsigned int) s->modulo,
ffeinfo_basictype_string (s->basic_type),
ffeinfo_kindtype_string (s->kind_type));
if (s->equivs_.first != (ffestorag) &s->equivs_.first)
{
ffestorag sq;
fprintf (dmpout, " with equivs");
for (sq = s->equivs_.first;
sq != (ffestorag) &s->equivs_.first;
sq = ffestorag_next_ (sq))
{
if (ffestorag_previous_ (sq) == (ffestorag) &s->equivs_.first)
fputc (' ', dmpout);
else
fputc (',', dmpout);
fprintf (dmpout, "%s", ffesymbol_text (ffestorag_symbol (sq)));
}
}
}
/* ffestorag_init_2 -- Initialize for new program unit
ffestorag_init_2(); */
void
ffestorag_init_2 ()
{
ffestorag_list_.first = ffestorag_list_.last
= (ffestorag) &ffestorag_list_.first;
ffestorag_local_size_ = 0;
ffestorag_reported_ = FALSE;
}
/* ffestorag_end_layout -- Do final layout for symbol
ffesymbol s;
ffestorag_end_layout(s); */
void
ffestorag_end_layout (ffesymbol s)
{
if (ffesymbol_storage (s) != NULL)
return; /* Already laid out. */
ffestorag_exec_layout (s); /* Do what we have in common. */
#if 0
assert (ffesymbol_storage (s) == NULL); /* I'd like to know what
cases miss going through
ffecom_sym_learned, and
why; I don't think we
should have to do the
exec_layout thing at all
here. */
/* Now I think I know: we have to do exec_layout here, because equivalence
handling could encounter an error that takes a variable off of its
equivalence object (and vice versa), and we should then layout the var
as a local entity. */
#endif
}
/* ffestorag_exec_layout -- Do initial layout for symbol
ffesymbol s;
ffestorag_exec_layout(s); */
void
ffestorag_exec_layout (ffesymbol s)
{
ffetargetAlign alignment;
ffetargetAlign modulo;
ffetargetOffset size;
ffetargetOffset num_elements;
ffetargetAlign pad;
ffestorag st;
ffestorag stv;
ffebld list;
ffebld item;
ffesymbol var;
bool init;
if (ffesymbol_storage (s) != NULL)
return; /* Already laid out. */
switch (ffesymbol_kind (s))
{
default:
return; /* Do nothing. */
case FFEINFO_kindENTITY:
switch (ffesymbol_where (s))
{
case FFEINFO_whereLOCAL:
if (ffesymbol_equiv (s) != NULL)
return; /* Let ffeequiv handle this guy. */
if (ffesymbol_rank (s) == 0)
num_elements = 1;
else
{
if (ffebld_op (ffesymbol_arraysize (s))
!= FFEBLD_opCONTER)
return; /* An adjustable local array, just like a dummy. */
num_elements
= ffebld_constant_integerdefault (ffebld_conter
(ffesymbol_arraysize (s)));
}
ffetarget_layout (ffesymbol_text (s), &alignment, &modulo,
&size, ffesymbol_basictype (s),
ffesymbol_kindtype (s), ffesymbol_size (s),
num_elements);
st = ffestorag_new (ffestorag_list_master ());
st->parent = NULL; /* Initializations happen at sym level. */
st->init = NULL;
st->accretion = NULL;
st->symbol = s;
st->size = size;
st->offset = 0;
st->alignment = alignment;
st->modulo = modulo;
st->type = FFESTORAG_typeLOCAL;
st->basic_type = ffesymbol_basictype (s);
st->kind_type = ffesymbol_kindtype (s);
st->type_symbol = s;
st->is_save = ffesymbol_is_save (s);
st->is_init = ffesymbol_is_init (s);
ffesymbol_set_storage (s, st);
if (ffesymbol_is_init (s))
ffecom_notify_init_symbol (s); /* Init completed before, but
we didn't have a storage
object for it; maybe back
end wants to see the sym
again now. */
ffesymbol_signal_unreported (s);
return;
case FFEINFO_whereCOMMON:
return; /* Allocate storage for entire common block
at once. */
case FFEINFO_whereDUMMY:
return; /* Don't do anything about dummies for now. */
case FFEINFO_whereRESULT:
case FFEINFO_whereIMMEDIATE:
case FFEINFO_whereCONSTANT:
case FFEINFO_whereNONE:
return; /* These don't get storage (esp. NONE, which
is UNCERTAIN). */
default:
assert ("bad ENTITY where" == NULL);
return;
}
break;
case FFEINFO_kindCOMMON:
assert (ffesymbol_where (s) == FFEINFO_whereLOCAL);
st = ffestorag_new (ffestorag_list_master ());
st->parent = NULL; /* Initializations happen here. */
st->init = NULL;
st->accretion = NULL;
st->symbol = s;
st->size = 0;
st->offset = 0;
st->alignment = 1;
st->modulo = 0;
st->type = FFESTORAG_typeCBLOCK;
if (ffesymbol_commonlist (s) != NULL)
{
var = ffebld_symter (ffebld_head (ffesymbol_commonlist (s)));
st->basic_type = ffesymbol_basictype (var);
st->kind_type = ffesymbol_kindtype (var);
st->type_symbol = var;
}
else
{ /* Special case for empty common area:
NONE/NONE means nothing. */
st->basic_type = FFEINFO_basictypeNONE;
st->kind_type = FFEINFO_kindtypeNONE;
st->type_symbol = NULL;
}
st->is_save = ffesymbol_is_save (s);
st->is_init = ffesymbol_is_init (s);
if (!ffe_is_mainprog ())
ffeglobal_save_common (s,
st->is_save || ffe_is_saveall (),
ffesymbol_where_line (s),
ffesymbol_where_column (s));
ffesymbol_set_storage (s, st);
init = FALSE;
for (list = ffesymbol_commonlist (s);
list != NULL;
list = ffebld_trail (list))
{
item = ffebld_head (list);
assert (ffebld_op (item) == FFEBLD_opSYMTER);
var = ffebld_symter (item);
if (ffesymbol_basictype (var) == FFEINFO_basictypeANY)
continue; /* Ignore any symbols that have errors. */
if (ffesymbol_rank (var) == 0)
num_elements = 1;
else
num_elements = ffebld_constant_integerdefault (ffebld_conter
(ffesymbol_arraysize (var)));
ffetarget_layout (ffesymbol_text (var), &alignment, &modulo,
&size, ffesymbol_basictype (var),
ffesymbol_kindtype (var), ffesymbol_size (var),
num_elements);
pad = ffetarget_align (&st->alignment, &st->modulo, st->size,
alignment, modulo);
if (pad != 0)
{ /* Warn about padding in the midst of a
common area. */
char padding[20];
sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
ffebad_start (FFEBAD_COMMON_PAD);
ffebad_string (padding);
ffebad_string (ffesymbol_text (var));
ffebad_string (ffesymbol_text (s));
ffebad_string ((pad == 1)
? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
ffebad_finish ();
}
stv = ffestorag_new (ffestorag_list_master ());
stv->parent = st; /* Initializations happen in COMMON block. */
stv->init = NULL;
stv->accretion = NULL;
stv->symbol = var;
stv->size = size;
if (!ffetarget_offset_add (&stv->offset, st->size, pad))
{ /* Common block size plus pad, complain if
overflow. */
ffetarget_offset_overflow (ffesymbol_text (s));
}
if (!ffetarget_offset_add (&st->size, stv->offset, stv->size))
{ /* Adjust size of common block, complain if
overflow. */
ffetarget_offset_overflow (ffesymbol_text (s));
}
stv->alignment = alignment;
stv->modulo = modulo;
stv->type = FFESTORAG_typeCOMMON;
stv->basic_type = ffesymbol_basictype (var);
stv->kind_type = ffesymbol_kindtype (var);
stv->type_symbol = var;
stv->is_save = st->is_save;
stv->is_init = st->is_init;
ffesymbol_set_storage (var, stv);
ffesymbol_signal_unreported (var);
ffestorag_update (st, var, ffesymbol_basictype (var),
ffesymbol_kindtype (var));
if (ffesymbol_is_init (var))
init = TRUE; /* Must move inits over to COMMON's
ffestorag. */
}
if (ffeequiv_layout_cblock (st))
init = TRUE;
ffeglobal_pad_common (s, st->modulo, ffesymbol_where_line (s),
ffesymbol_where_column (s));
if (init)
ffedata_gather (st); /* Gather subordinate inits into one init. */
ffesymbol_signal_unreported (s);
return;
}
}
/* ffestorag_new -- Create new ffestorag object, append to list
ffestorag s;
ffestoragList sl;
s = ffestorag_new(sl); */
ffestorag
ffestorag_new (ffestoragList sl)
{
ffestorag s;
s = (ffestorag) malloc_new_kp (ffe_pool_program_unit (), "ffestorag",
sizeof (*s));
s->next = (ffestorag) &sl->first;
s->previous = sl->last;
#ifdef FFECOM_storageHOOK
s->hook = FFECOM_storageNULL;
#endif
s->previous->next = s;
sl->last = s;
s->equivs_.first = s->equivs_.last = (ffestorag) &s->equivs_.first;
return s;
}
/* Report info on LOCAL non-sym-assoc'ed entities if needed. */
void
ffestorag_report ()
{
ffestorag s;
if (ffestorag_reported_)
return;
for (s = ffestorag_list_.first;
s != (ffestorag) &ffestorag_list_.first;
s = s->next)
{
if (s->symbol == NULL)
{
ffestorag_reported_ = TRUE;
fputs ("Storage area: ", dmpout);
ffestorag_dump (s);
fputc ('\n', dmpout);
}
}
}
/* ffestorag_update -- Update type info for ffestorag object
ffestorag s; // existing object
ffeinfoBasictype bt; // basic type for newly added member of object
ffeinfoKindtype kt; // kind type for it
ffestorag_update(s,bt,kt);
If the existing type for the storage object agrees with the new type
info, just returns. If the basic types agree but not the kind types,
sets the kind type for the object to NONE. If the basic types
disagree, sets the kind type to NONE, and the basic type to NONE if the
basic types both are not CHARACTER, otherwise to ANY. If the basic
type for the object already is NONE, it is set to ANY if the new basic
type is CHARACTER. Any time a transition is made to ANY and pedantic
mode is on, a message is issued that mixing CHARACTER and non-CHARACTER
stuff in the same COMMON/EQUIVALENCE is invalid. */
void
ffestorag_update (ffestorag s, ffesymbol sym, ffeinfoBasictype bt,
ffeinfoKindtype kt)
{
if (s->basic_type == bt)
{
if (s->kind_type == kt)
return;
s->kind_type = FFEINFO_kindtypeNONE;
return;
}
switch (s->basic_type)
{
case FFEINFO_basictypeANY:
return; /* No need to do anything further. */
case FFEINFO_basictypeCHARACTER:
any: /* :::::::::::::::::::: */
s->basic_type = FFEINFO_basictypeANY;
s->kind_type = FFEINFO_kindtypeANY;
if (ffe_is_pedantic ())
{
ffebad_start (FFEBAD_MIXED_TYPES);
ffebad_string (ffesymbol_text (s->type_symbol));
ffebad_string (ffesymbol_text (sym));
ffebad_finish ();
}
return;
default:
if (bt == FFEINFO_basictypeCHARACTER)
goto any; /* :::::::::::::::::::: */
s->basic_type = FFEINFO_basictypeNONE;
s->kind_type = FFEINFO_kindtypeNONE;
return;
}
}
/* Update INIT flag for storage object.
If the INIT flag for the <s> object is already TRUE, return. Else,
set it to TRUE and call ffe*_update_init for all contained objects. */
void
ffestorag_update_init (ffestorag s)
{
ffestorag sq;
if (s->is_init)
return;
s->is_init = TRUE;
if ((s->symbol != NULL)
&& !ffesymbol_is_init (s->symbol))
ffesymbol_update_init (s->symbol);
if (s->parent != NULL)
ffestorag_update_init (s->parent);
for (sq = s->equivs_.first;
sq != (ffestorag) &s->equivs_.first;
sq = ffestorag_next_ (sq))
{
if (!sq->is_init)
ffestorag_update_init (sq);
}
}
/* Update SAVE flag for storage object.
If the SAVE flag for the <s> object is already TRUE, return. Else,
set it to TRUE and call ffe*_update_save for all contained objects. */
void
ffestorag_update_save (ffestorag s)
{
ffestorag sq;
if (s->is_save)
return;
s->is_save = TRUE;
if ((s->symbol != NULL)
&& !ffesymbol_is_save (s->symbol))
ffesymbol_update_save (s->symbol);
if (s->parent != NULL)
ffestorag_update_save (s->parent);
for (sq = s->equivs_.first;
sq != (ffestorag) &s->equivs_.first;
sq = ffestorag_next_ (sq))
{
if (!sq->is_save)
ffestorag_update_save (sq);
}
}