diff options
Diffstat (limited to 'gcc/f/storag.c')
| -rw-r--r-- | gcc/f/storag.c | 573 |
1 files changed, 573 insertions, 0 deletions
diff --git a/gcc/f/storag.c b/gcc/f/storag.c new file mode 100644 index 00000000000..7ad155b983a --- /dev/null +++ b/gcc/f/storag.c @@ -0,0 +1,573 @@ +/* storag.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + 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); + } +} |