| /* 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); |
| } |
| } |