+++ /dev/null
-/* 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)
-\f
-/* 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);
- }
-}
projects / msp430-gcc.git / blobdiff