1*c87b03e5Sespie /* storag.c -- Implementation File (module.c template V1.0)
2*c87b03e5Sespie Copyright (C) 1995, 1996 Free Software Foundation, Inc.
3*c87b03e5Sespie Contributed by James Craig Burley.
4*c87b03e5Sespie
5*c87b03e5Sespie This file is part of GNU Fortran.
6*c87b03e5Sespie
7*c87b03e5Sespie GNU Fortran is free software; you can redistribute it and/or modify
8*c87b03e5Sespie it under the terms of the GNU General Public License as published by
9*c87b03e5Sespie the Free Software Foundation; either version 2, or (at your option)
10*c87b03e5Sespie any later version.
11*c87b03e5Sespie
12*c87b03e5Sespie GNU Fortran is distributed in the hope that it will be useful,
13*c87b03e5Sespie but WITHOUT ANY WARRANTY; without even the implied warranty of
14*c87b03e5Sespie MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15*c87b03e5Sespie GNU General Public License for more details.
16*c87b03e5Sespie
17*c87b03e5Sespie You should have received a copy of the GNU General Public License
18*c87b03e5Sespie along with GNU Fortran; see the file COPYING. If not, write to
19*c87b03e5Sespie the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20*c87b03e5Sespie 02111-1307, USA.
21*c87b03e5Sespie
22*c87b03e5Sespie Related Modules:
23*c87b03e5Sespie None
24*c87b03e5Sespie
25*c87b03e5Sespie Description:
26*c87b03e5Sespie Maintains information on storage (memory) relationships between
27*c87b03e5Sespie COMMON, dummy, and local variables, plus their equivalences (dummies
28*c87b03e5Sespie don't have equivalences, however).
29*c87b03e5Sespie
30*c87b03e5Sespie Modifications:
31*c87b03e5Sespie */
32*c87b03e5Sespie
33*c87b03e5Sespie /* Include files. */
34*c87b03e5Sespie
35*c87b03e5Sespie #include "proj.h"
36*c87b03e5Sespie #include "storag.h"
37*c87b03e5Sespie #include "data.h"
38*c87b03e5Sespie #include "malloc.h"
39*c87b03e5Sespie #include "symbol.h"
40*c87b03e5Sespie #include "target.h"
41*c87b03e5Sespie
42*c87b03e5Sespie /* Externals defined here. */
43*c87b03e5Sespie
44*c87b03e5Sespie ffestoragList_ ffestorag_list_;
45*c87b03e5Sespie
46*c87b03e5Sespie /* Simple definitions and enumerations. */
47*c87b03e5Sespie
48*c87b03e5Sespie
49*c87b03e5Sespie /* Internal typedefs. */
50*c87b03e5Sespie
51*c87b03e5Sespie
52*c87b03e5Sespie /* Private include files. */
53*c87b03e5Sespie
54*c87b03e5Sespie
55*c87b03e5Sespie /* Internal structure definitions. */
56*c87b03e5Sespie
57*c87b03e5Sespie
58*c87b03e5Sespie /* Static objects accessed by functions in this module. */
59*c87b03e5Sespie
60*c87b03e5Sespie static ffetargetOffset ffestorag_local_size_; /* #units allocated so far. */
61*c87b03e5Sespie static bool ffestorag_reported_;/* Reports happen only once. */
62*c87b03e5Sespie
63*c87b03e5Sespie /* Static functions (internal). */
64*c87b03e5Sespie
65*c87b03e5Sespie
66*c87b03e5Sespie /* Internal macros. */
67*c87b03e5Sespie
68*c87b03e5Sespie #define ffestorag_next_(s) ((s)->next)
69*c87b03e5Sespie #define ffestorag_previous_(s) ((s)->previous)
70*c87b03e5Sespie
71*c87b03e5Sespie /* ffestorag_drive -- Drive fn from list of storage objects
72*c87b03e5Sespie
73*c87b03e5Sespie ffestoragList sl;
74*c87b03e5Sespie void (*fn)(ffestorag mst,ffestorag st);
75*c87b03e5Sespie ffestorag mst; // the master ffestorag object (or whatever)
76*c87b03e5Sespie ffestorag_drive(sl,fn,mst);
77*c87b03e5Sespie
78*c87b03e5Sespie Calls (*fn)(mst,st) for every st in the list sl. */
79*c87b03e5Sespie
80*c87b03e5Sespie void
ffestorag_drive(ffestoragList sl,void (* fn)(ffestorag mst,ffestorag st),ffestorag mst)81*c87b03e5Sespie ffestorag_drive (ffestoragList sl, void (*fn) (ffestorag mst, ffestorag st),
82*c87b03e5Sespie ffestorag mst)
83*c87b03e5Sespie {
84*c87b03e5Sespie ffestorag st;
85*c87b03e5Sespie
86*c87b03e5Sespie for (st = sl->first;
87*c87b03e5Sespie st != (ffestorag) &sl->first;
88*c87b03e5Sespie st = st->next)
89*c87b03e5Sespie (*fn) (mst, st);
90*c87b03e5Sespie }
91*c87b03e5Sespie
92*c87b03e5Sespie /* ffestorag_dump -- Dump information on storage object
93*c87b03e5Sespie
94*c87b03e5Sespie ffestorag s; // the ffestorag object
95*c87b03e5Sespie ffestorag_dump(s);
96*c87b03e5Sespie
97*c87b03e5Sespie Dumps information in the storage object. */
98*c87b03e5Sespie
99*c87b03e5Sespie void
ffestorag_dump(ffestorag s)100*c87b03e5Sespie ffestorag_dump (ffestorag s)
101*c87b03e5Sespie {
102*c87b03e5Sespie if (s == NULL)
103*c87b03e5Sespie {
104*c87b03e5Sespie fprintf (dmpout, "(no storage object)");
105*c87b03e5Sespie return;
106*c87b03e5Sespie }
107*c87b03e5Sespie
108*c87b03e5Sespie switch (s->type)
109*c87b03e5Sespie {
110*c87b03e5Sespie case FFESTORAG_typeCBLOCK:
111*c87b03e5Sespie fprintf (dmpout, "CBLOCK ");
112*c87b03e5Sespie break;
113*c87b03e5Sespie
114*c87b03e5Sespie case FFESTORAG_typeCOMMON:
115*c87b03e5Sespie fprintf (dmpout, "COMMON ");
116*c87b03e5Sespie break;
117*c87b03e5Sespie
118*c87b03e5Sespie case FFESTORAG_typeLOCAL:
119*c87b03e5Sespie fprintf (dmpout, "LOCAL ");
120*c87b03e5Sespie break;
121*c87b03e5Sespie
122*c87b03e5Sespie case FFESTORAG_typeEQUIV:
123*c87b03e5Sespie fprintf (dmpout, "EQUIV ");
124*c87b03e5Sespie break;
125*c87b03e5Sespie
126*c87b03e5Sespie default:
127*c87b03e5Sespie fprintf (dmpout, "?%d? ", s->type);
128*c87b03e5Sespie break;
129*c87b03e5Sespie }
130*c87b03e5Sespie
131*c87b03e5Sespie if (s->symbol != NULL)
132*c87b03e5Sespie fprintf (dmpout, "\"%s\" ", ffesymbol_text (s->symbol));
133*c87b03e5Sespie
134*c87b03e5Sespie fprintf (dmpout, "at %" ffetargetOffset_f "d size %" ffetargetOffset_f
135*c87b03e5Sespie "d, align loc%%%"
136*c87b03e5Sespie ffetargetAlign_f "u=%" ffetargetAlign_f "u, bt=%s, kt=%s",
137*c87b03e5Sespie s->offset,
138*c87b03e5Sespie s->size, (unsigned int) s->alignment, (unsigned int) s->modulo,
139*c87b03e5Sespie ffeinfo_basictype_string (s->basic_type),
140*c87b03e5Sespie ffeinfo_kindtype_string (s->kind_type));
141*c87b03e5Sespie
142*c87b03e5Sespie if (s->equivs_.first != (ffestorag) &s->equivs_.first)
143*c87b03e5Sespie {
144*c87b03e5Sespie ffestorag sq;
145*c87b03e5Sespie
146*c87b03e5Sespie fprintf (dmpout, " with equivs");
147*c87b03e5Sespie for (sq = s->equivs_.first;
148*c87b03e5Sespie sq != (ffestorag) &s->equivs_.first;
149*c87b03e5Sespie sq = ffestorag_next_ (sq))
150*c87b03e5Sespie {
151*c87b03e5Sespie if (ffestorag_previous_ (sq) == (ffestorag) &s->equivs_.first)
152*c87b03e5Sespie fputc (' ', dmpout);
153*c87b03e5Sespie else
154*c87b03e5Sespie fputc (',', dmpout);
155*c87b03e5Sespie fprintf (dmpout, "%s", ffesymbol_text (ffestorag_symbol (sq)));
156*c87b03e5Sespie }
157*c87b03e5Sespie }
158*c87b03e5Sespie }
159*c87b03e5Sespie
160*c87b03e5Sespie /* ffestorag_init_2 -- Initialize for new program unit
161*c87b03e5Sespie
162*c87b03e5Sespie ffestorag_init_2(); */
163*c87b03e5Sespie
164*c87b03e5Sespie void
ffestorag_init_2()165*c87b03e5Sespie ffestorag_init_2 ()
166*c87b03e5Sespie {
167*c87b03e5Sespie ffestorag_list_.first = ffestorag_list_.last
168*c87b03e5Sespie = (ffestorag) &ffestorag_list_.first;
169*c87b03e5Sespie ffestorag_local_size_ = 0;
170*c87b03e5Sespie ffestorag_reported_ = FALSE;
171*c87b03e5Sespie }
172*c87b03e5Sespie
173*c87b03e5Sespie /* ffestorag_end_layout -- Do final layout for symbol
174*c87b03e5Sespie
175*c87b03e5Sespie ffesymbol s;
176*c87b03e5Sespie ffestorag_end_layout(s); */
177*c87b03e5Sespie
178*c87b03e5Sespie void
ffestorag_end_layout(ffesymbol s)179*c87b03e5Sespie ffestorag_end_layout (ffesymbol s)
180*c87b03e5Sespie {
181*c87b03e5Sespie if (ffesymbol_storage (s) != NULL)
182*c87b03e5Sespie return; /* Already laid out. */
183*c87b03e5Sespie
184*c87b03e5Sespie ffestorag_exec_layout (s); /* Do what we have in common. */
185*c87b03e5Sespie #if 0
186*c87b03e5Sespie assert (ffesymbol_storage (s) == NULL); /* I'd like to know what
187*c87b03e5Sespie cases miss going through
188*c87b03e5Sespie ffecom_sym_learned, and
189*c87b03e5Sespie why; I don't think we
190*c87b03e5Sespie should have to do the
191*c87b03e5Sespie exec_layout thing at all
192*c87b03e5Sespie here. */
193*c87b03e5Sespie /* Now I think I know: we have to do exec_layout here, because equivalence
194*c87b03e5Sespie handling could encounter an error that takes a variable off of its
195*c87b03e5Sespie equivalence object (and vice versa), and we should then layout the var
196*c87b03e5Sespie as a local entity. */
197*c87b03e5Sespie #endif
198*c87b03e5Sespie }
199*c87b03e5Sespie
200*c87b03e5Sespie /* ffestorag_exec_layout -- Do initial layout for symbol
201*c87b03e5Sespie
202*c87b03e5Sespie ffesymbol s;
203*c87b03e5Sespie ffestorag_exec_layout(s); */
204*c87b03e5Sespie
205*c87b03e5Sespie void
ffestorag_exec_layout(ffesymbol s)206*c87b03e5Sespie ffestorag_exec_layout (ffesymbol s)
207*c87b03e5Sespie {
208*c87b03e5Sespie ffetargetAlign alignment;
209*c87b03e5Sespie ffetargetAlign modulo;
210*c87b03e5Sespie ffetargetOffset size;
211*c87b03e5Sespie ffetargetOffset num_elements;
212*c87b03e5Sespie ffetargetAlign pad;
213*c87b03e5Sespie ffestorag st;
214*c87b03e5Sespie ffestorag stv;
215*c87b03e5Sespie ffebld list;
216*c87b03e5Sespie ffebld item;
217*c87b03e5Sespie ffesymbol var;
218*c87b03e5Sespie bool init;
219*c87b03e5Sespie
220*c87b03e5Sespie if (ffesymbol_storage (s) != NULL)
221*c87b03e5Sespie return; /* Already laid out. */
222*c87b03e5Sespie
223*c87b03e5Sespie switch (ffesymbol_kind (s))
224*c87b03e5Sespie {
225*c87b03e5Sespie default:
226*c87b03e5Sespie return; /* Do nothing. */
227*c87b03e5Sespie
228*c87b03e5Sespie case FFEINFO_kindENTITY:
229*c87b03e5Sespie switch (ffesymbol_where (s))
230*c87b03e5Sespie {
231*c87b03e5Sespie case FFEINFO_whereLOCAL:
232*c87b03e5Sespie if (ffesymbol_equiv (s) != NULL)
233*c87b03e5Sespie return; /* Let ffeequiv handle this guy. */
234*c87b03e5Sespie if (ffesymbol_rank (s) == 0)
235*c87b03e5Sespie num_elements = 1;
236*c87b03e5Sespie else
237*c87b03e5Sespie {
238*c87b03e5Sespie if (ffebld_op (ffesymbol_arraysize (s))
239*c87b03e5Sespie != FFEBLD_opCONTER)
240*c87b03e5Sespie return; /* An adjustable local array, just like a dummy. */
241*c87b03e5Sespie num_elements
242*c87b03e5Sespie = ffebld_constant_integerdefault (ffebld_conter
243*c87b03e5Sespie (ffesymbol_arraysize (s)));
244*c87b03e5Sespie }
245*c87b03e5Sespie ffetarget_layout (ffesymbol_text (s), &alignment, &modulo,
246*c87b03e5Sespie &size, ffesymbol_basictype (s),
247*c87b03e5Sespie ffesymbol_kindtype (s), ffesymbol_size (s),
248*c87b03e5Sespie num_elements);
249*c87b03e5Sespie st = ffestorag_new (ffestorag_list_master ());
250*c87b03e5Sespie st->parent = NULL; /* Initializations happen at sym level. */
251*c87b03e5Sespie st->init = NULL;
252*c87b03e5Sespie st->accretion = NULL;
253*c87b03e5Sespie st->symbol = s;
254*c87b03e5Sespie st->size = size;
255*c87b03e5Sespie st->offset = 0;
256*c87b03e5Sespie st->alignment = alignment;
257*c87b03e5Sespie st->modulo = modulo;
258*c87b03e5Sespie st->type = FFESTORAG_typeLOCAL;
259*c87b03e5Sespie st->basic_type = ffesymbol_basictype (s);
260*c87b03e5Sespie st->kind_type = ffesymbol_kindtype (s);
261*c87b03e5Sespie st->type_symbol = s;
262*c87b03e5Sespie st->is_save = ffesymbol_is_save (s);
263*c87b03e5Sespie st->is_init = ffesymbol_is_init (s);
264*c87b03e5Sespie ffesymbol_set_storage (s, st);
265*c87b03e5Sespie if (ffesymbol_is_init (s))
266*c87b03e5Sespie ffecom_notify_init_symbol (s); /* Init completed before, but
267*c87b03e5Sespie we didn't have a storage
268*c87b03e5Sespie object for it; maybe back
269*c87b03e5Sespie end wants to see the sym
270*c87b03e5Sespie again now. */
271*c87b03e5Sespie ffesymbol_signal_unreported (s);
272*c87b03e5Sespie return;
273*c87b03e5Sespie
274*c87b03e5Sespie case FFEINFO_whereCOMMON:
275*c87b03e5Sespie return; /* Allocate storage for entire common block
276*c87b03e5Sespie at once. */
277*c87b03e5Sespie
278*c87b03e5Sespie case FFEINFO_whereDUMMY:
279*c87b03e5Sespie return; /* Don't do anything about dummies for now. */
280*c87b03e5Sespie
281*c87b03e5Sespie case FFEINFO_whereRESULT:
282*c87b03e5Sespie case FFEINFO_whereIMMEDIATE:
283*c87b03e5Sespie case FFEINFO_whereCONSTANT:
284*c87b03e5Sespie case FFEINFO_whereNONE:
285*c87b03e5Sespie return; /* These don't get storage (esp. NONE, which
286*c87b03e5Sespie is UNCERTAIN). */
287*c87b03e5Sespie
288*c87b03e5Sespie default:
289*c87b03e5Sespie assert ("bad ENTITY where" == NULL);
290*c87b03e5Sespie return;
291*c87b03e5Sespie }
292*c87b03e5Sespie break;
293*c87b03e5Sespie
294*c87b03e5Sespie case FFEINFO_kindCOMMON:
295*c87b03e5Sespie assert (ffesymbol_where (s) == FFEINFO_whereLOCAL);
296*c87b03e5Sespie st = ffestorag_new (ffestorag_list_master ());
297*c87b03e5Sespie st->parent = NULL; /* Initializations happen here. */
298*c87b03e5Sespie st->init = NULL;
299*c87b03e5Sespie st->accretion = NULL;
300*c87b03e5Sespie st->symbol = s;
301*c87b03e5Sespie st->size = 0;
302*c87b03e5Sespie st->offset = 0;
303*c87b03e5Sespie st->alignment = 1;
304*c87b03e5Sespie st->modulo = 0;
305*c87b03e5Sespie st->type = FFESTORAG_typeCBLOCK;
306*c87b03e5Sespie if (ffesymbol_commonlist (s) != NULL)
307*c87b03e5Sespie {
308*c87b03e5Sespie var = ffebld_symter (ffebld_head (ffesymbol_commonlist (s)));
309*c87b03e5Sespie st->basic_type = ffesymbol_basictype (var);
310*c87b03e5Sespie st->kind_type = ffesymbol_kindtype (var);
311*c87b03e5Sespie st->type_symbol = var;
312*c87b03e5Sespie }
313*c87b03e5Sespie else
314*c87b03e5Sespie { /* Special case for empty common area:
315*c87b03e5Sespie NONE/NONE means nothing. */
316*c87b03e5Sespie st->basic_type = FFEINFO_basictypeNONE;
317*c87b03e5Sespie st->kind_type = FFEINFO_kindtypeNONE;
318*c87b03e5Sespie st->type_symbol = NULL;
319*c87b03e5Sespie }
320*c87b03e5Sespie st->is_save = ffesymbol_is_save (s);
321*c87b03e5Sespie st->is_init = ffesymbol_is_init (s);
322*c87b03e5Sespie if (!ffe_is_mainprog ())
323*c87b03e5Sespie ffeglobal_save_common (s,
324*c87b03e5Sespie st->is_save || ffe_is_saveall (),
325*c87b03e5Sespie ffesymbol_where_line (s),
326*c87b03e5Sespie ffesymbol_where_column (s));
327*c87b03e5Sespie ffesymbol_set_storage (s, st);
328*c87b03e5Sespie
329*c87b03e5Sespie init = FALSE;
330*c87b03e5Sespie for (list = ffesymbol_commonlist (s);
331*c87b03e5Sespie list != NULL;
332*c87b03e5Sespie list = ffebld_trail (list))
333*c87b03e5Sespie {
334*c87b03e5Sespie item = ffebld_head (list);
335*c87b03e5Sespie assert (ffebld_op (item) == FFEBLD_opSYMTER);
336*c87b03e5Sespie var = ffebld_symter (item);
337*c87b03e5Sespie if (ffesymbol_basictype (var) == FFEINFO_basictypeANY)
338*c87b03e5Sespie continue; /* Ignore any symbols that have errors. */
339*c87b03e5Sespie if (ffesymbol_rank (var) == 0)
340*c87b03e5Sespie num_elements = 1;
341*c87b03e5Sespie else
342*c87b03e5Sespie num_elements = ffebld_constant_integerdefault (ffebld_conter
343*c87b03e5Sespie (ffesymbol_arraysize (var)));
344*c87b03e5Sespie ffetarget_layout (ffesymbol_text (var), &alignment, &modulo,
345*c87b03e5Sespie &size, ffesymbol_basictype (var),
346*c87b03e5Sespie ffesymbol_kindtype (var), ffesymbol_size (var),
347*c87b03e5Sespie num_elements);
348*c87b03e5Sespie pad = ffetarget_align (&st->alignment, &st->modulo, st->size,
349*c87b03e5Sespie alignment, modulo);
350*c87b03e5Sespie if (pad != 0)
351*c87b03e5Sespie { /* Warn about padding in the midst of a
352*c87b03e5Sespie common area. */
353*c87b03e5Sespie char padding[20];
354*c87b03e5Sespie
355*c87b03e5Sespie sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
356*c87b03e5Sespie ffebad_start (FFEBAD_COMMON_PAD);
357*c87b03e5Sespie ffebad_string (padding);
358*c87b03e5Sespie ffebad_string (ffesymbol_text (var));
359*c87b03e5Sespie ffebad_string (ffesymbol_text (s));
360*c87b03e5Sespie ffebad_string ((pad == 1)
361*c87b03e5Sespie ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
362*c87b03e5Sespie ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
363*c87b03e5Sespie ffebad_finish ();
364*c87b03e5Sespie }
365*c87b03e5Sespie stv = ffestorag_new (ffestorag_list_master ());
366*c87b03e5Sespie stv->parent = st; /* Initializations happen in COMMON block. */
367*c87b03e5Sespie stv->init = NULL;
368*c87b03e5Sespie stv->accretion = NULL;
369*c87b03e5Sespie stv->symbol = var;
370*c87b03e5Sespie stv->size = size;
371*c87b03e5Sespie if (!ffetarget_offset_add (&stv->offset, st->size, pad))
372*c87b03e5Sespie { /* Common block size plus pad, complain if
373*c87b03e5Sespie overflow. */
374*c87b03e5Sespie ffetarget_offset_overflow (ffesymbol_text (s));
375*c87b03e5Sespie }
376*c87b03e5Sespie if (!ffetarget_offset_add (&st->size, stv->offset, stv->size))
377*c87b03e5Sespie { /* Adjust size of common block, complain if
378*c87b03e5Sespie overflow. */
379*c87b03e5Sespie ffetarget_offset_overflow (ffesymbol_text (s));
380*c87b03e5Sespie }
381*c87b03e5Sespie stv->alignment = alignment;
382*c87b03e5Sespie stv->modulo = modulo;
383*c87b03e5Sespie stv->type = FFESTORAG_typeCOMMON;
384*c87b03e5Sespie stv->basic_type = ffesymbol_basictype (var);
385*c87b03e5Sespie stv->kind_type = ffesymbol_kindtype (var);
386*c87b03e5Sespie stv->type_symbol = var;
387*c87b03e5Sespie stv->is_save = st->is_save;
388*c87b03e5Sespie stv->is_init = st->is_init;
389*c87b03e5Sespie ffesymbol_set_storage (var, stv);
390*c87b03e5Sespie ffesymbol_signal_unreported (var);
391*c87b03e5Sespie ffestorag_update (st, var, ffesymbol_basictype (var),
392*c87b03e5Sespie ffesymbol_kindtype (var));
393*c87b03e5Sespie if (ffesymbol_is_init (var))
394*c87b03e5Sespie init = TRUE; /* Must move inits over to COMMON's
395*c87b03e5Sespie ffestorag. */
396*c87b03e5Sespie }
397*c87b03e5Sespie if (ffeequiv_layout_cblock (st))
398*c87b03e5Sespie init = TRUE;
399*c87b03e5Sespie ffeglobal_pad_common (s, st->modulo, ffesymbol_where_line (s),
400*c87b03e5Sespie ffesymbol_where_column (s));
401*c87b03e5Sespie if (init)
402*c87b03e5Sespie ffedata_gather (st); /* Gather subordinate inits into one init. */
403*c87b03e5Sespie ffesymbol_signal_unreported (s);
404*c87b03e5Sespie return;
405*c87b03e5Sespie }
406*c87b03e5Sespie }
407*c87b03e5Sespie
408*c87b03e5Sespie /* ffestorag_new -- Create new ffestorag object, append to list
409*c87b03e5Sespie
410*c87b03e5Sespie ffestorag s;
411*c87b03e5Sespie ffestoragList sl;
412*c87b03e5Sespie s = ffestorag_new(sl); */
413*c87b03e5Sespie
414*c87b03e5Sespie ffestorag
ffestorag_new(ffestoragList sl)415*c87b03e5Sespie ffestorag_new (ffestoragList sl)
416*c87b03e5Sespie {
417*c87b03e5Sespie ffestorag s;
418*c87b03e5Sespie
419*c87b03e5Sespie s = (ffestorag) malloc_new_kp (ffe_pool_program_unit (), "ffestorag",
420*c87b03e5Sespie sizeof (*s));
421*c87b03e5Sespie s->next = (ffestorag) &sl->first;
422*c87b03e5Sespie s->previous = sl->last;
423*c87b03e5Sespie #ifdef FFECOM_storageHOOK
424*c87b03e5Sespie s->hook = FFECOM_storageNULL;
425*c87b03e5Sespie #endif
426*c87b03e5Sespie s->previous->next = s;
427*c87b03e5Sespie sl->last = s;
428*c87b03e5Sespie s->equivs_.first = s->equivs_.last = (ffestorag) &s->equivs_.first;
429*c87b03e5Sespie
430*c87b03e5Sespie return s;
431*c87b03e5Sespie }
432*c87b03e5Sespie
433*c87b03e5Sespie /* Report info on LOCAL non-sym-assoc'ed entities if needed. */
434*c87b03e5Sespie
435*c87b03e5Sespie void
ffestorag_report()436*c87b03e5Sespie ffestorag_report ()
437*c87b03e5Sespie {
438*c87b03e5Sespie ffestorag s;
439*c87b03e5Sespie
440*c87b03e5Sespie if (ffestorag_reported_)
441*c87b03e5Sespie return;
442*c87b03e5Sespie
443*c87b03e5Sespie for (s = ffestorag_list_.first;
444*c87b03e5Sespie s != (ffestorag) &ffestorag_list_.first;
445*c87b03e5Sespie s = s->next)
446*c87b03e5Sespie {
447*c87b03e5Sespie if (s->symbol == NULL)
448*c87b03e5Sespie {
449*c87b03e5Sespie ffestorag_reported_ = TRUE;
450*c87b03e5Sespie fputs ("Storage area: ", dmpout);
451*c87b03e5Sespie ffestorag_dump (s);
452*c87b03e5Sespie fputc ('\n', dmpout);
453*c87b03e5Sespie }
454*c87b03e5Sespie }
455*c87b03e5Sespie }
456*c87b03e5Sespie
457*c87b03e5Sespie /* ffestorag_update -- Update type info for ffestorag object
458*c87b03e5Sespie
459*c87b03e5Sespie ffestorag s; // existing object
460*c87b03e5Sespie ffeinfoBasictype bt; // basic type for newly added member of object
461*c87b03e5Sespie ffeinfoKindtype kt; // kind type for it
462*c87b03e5Sespie ffestorag_update(s,bt,kt);
463*c87b03e5Sespie
464*c87b03e5Sespie If the existing type for the storage object agrees with the new type
465*c87b03e5Sespie info, just returns. If the basic types agree but not the kind types,
466*c87b03e5Sespie sets the kind type for the object to NONE. If the basic types
467*c87b03e5Sespie disagree, sets the kind type to NONE, and the basic type to NONE if the
468*c87b03e5Sespie basic types both are not CHARACTER, otherwise to ANY. If the basic
469*c87b03e5Sespie type for the object already is NONE, it is set to ANY if the new basic
470*c87b03e5Sespie type is CHARACTER. Any time a transition is made to ANY and pedantic
471*c87b03e5Sespie mode is on, a message is issued that mixing CHARACTER and non-CHARACTER
472*c87b03e5Sespie stuff in the same COMMON/EQUIVALENCE is invalid. */
473*c87b03e5Sespie
474*c87b03e5Sespie void
ffestorag_update(ffestorag s,ffesymbol sym,ffeinfoBasictype bt,ffeinfoKindtype kt)475*c87b03e5Sespie ffestorag_update (ffestorag s, ffesymbol sym, ffeinfoBasictype bt,
476*c87b03e5Sespie ffeinfoKindtype kt)
477*c87b03e5Sespie {
478*c87b03e5Sespie if (s->basic_type == bt)
479*c87b03e5Sespie {
480*c87b03e5Sespie if (s->kind_type == kt)
481*c87b03e5Sespie return;
482*c87b03e5Sespie s->kind_type = FFEINFO_kindtypeNONE;
483*c87b03e5Sespie return;
484*c87b03e5Sespie }
485*c87b03e5Sespie
486*c87b03e5Sespie switch (s->basic_type)
487*c87b03e5Sespie {
488*c87b03e5Sespie case FFEINFO_basictypeANY:
489*c87b03e5Sespie return; /* No need to do anything further. */
490*c87b03e5Sespie
491*c87b03e5Sespie case FFEINFO_basictypeCHARACTER:
492*c87b03e5Sespie any: /* :::::::::::::::::::: */
493*c87b03e5Sespie s->basic_type = FFEINFO_basictypeANY;
494*c87b03e5Sespie s->kind_type = FFEINFO_kindtypeANY;
495*c87b03e5Sespie if (ffe_is_pedantic ())
496*c87b03e5Sespie {
497*c87b03e5Sespie ffebad_start (FFEBAD_MIXED_TYPES);
498*c87b03e5Sespie ffebad_string (ffesymbol_text (s->type_symbol));
499*c87b03e5Sespie ffebad_string (ffesymbol_text (sym));
500*c87b03e5Sespie ffebad_finish ();
501*c87b03e5Sespie }
502*c87b03e5Sespie return;
503*c87b03e5Sespie
504*c87b03e5Sespie default:
505*c87b03e5Sespie if (bt == FFEINFO_basictypeCHARACTER)
506*c87b03e5Sespie goto any; /* :::::::::::::::::::: */
507*c87b03e5Sespie s->basic_type = FFEINFO_basictypeNONE;
508*c87b03e5Sespie s->kind_type = FFEINFO_kindtypeNONE;
509*c87b03e5Sespie return;
510*c87b03e5Sespie }
511*c87b03e5Sespie }
512*c87b03e5Sespie
513*c87b03e5Sespie /* Update INIT flag for storage object.
514*c87b03e5Sespie
515*c87b03e5Sespie If the INIT flag for the <s> object is already TRUE, return. Else,
516*c87b03e5Sespie set it to TRUE and call ffe*_update_init for all contained objects. */
517*c87b03e5Sespie
518*c87b03e5Sespie void
ffestorag_update_init(ffestorag s)519*c87b03e5Sespie ffestorag_update_init (ffestorag s)
520*c87b03e5Sespie {
521*c87b03e5Sespie ffestorag sq;
522*c87b03e5Sespie
523*c87b03e5Sespie if (s->is_init)
524*c87b03e5Sespie return;
525*c87b03e5Sespie
526*c87b03e5Sespie s->is_init = TRUE;
527*c87b03e5Sespie
528*c87b03e5Sespie if ((s->symbol != NULL)
529*c87b03e5Sespie && !ffesymbol_is_init (s->symbol))
530*c87b03e5Sespie ffesymbol_update_init (s->symbol);
531*c87b03e5Sespie
532*c87b03e5Sespie if (s->parent != NULL)
533*c87b03e5Sespie ffestorag_update_init (s->parent);
534*c87b03e5Sespie
535*c87b03e5Sespie for (sq = s->equivs_.first;
536*c87b03e5Sespie sq != (ffestorag) &s->equivs_.first;
537*c87b03e5Sespie sq = ffestorag_next_ (sq))
538*c87b03e5Sespie {
539*c87b03e5Sespie if (!sq->is_init)
540*c87b03e5Sespie ffestorag_update_init (sq);
541*c87b03e5Sespie }
542*c87b03e5Sespie }
543*c87b03e5Sespie
544*c87b03e5Sespie /* Update SAVE flag for storage object.
545*c87b03e5Sespie
546*c87b03e5Sespie If the SAVE flag for the <s> object is already TRUE, return. Else,
547*c87b03e5Sespie set it to TRUE and call ffe*_update_save for all contained objects. */
548*c87b03e5Sespie
549*c87b03e5Sespie void
ffestorag_update_save(ffestorag s)550*c87b03e5Sespie ffestorag_update_save (ffestorag s)
551*c87b03e5Sespie {
552*c87b03e5Sespie ffestorag sq;
553*c87b03e5Sespie
554*c87b03e5Sespie if (s->is_save)
555*c87b03e5Sespie return;
556*c87b03e5Sespie
557*c87b03e5Sespie s->is_save = TRUE;
558*c87b03e5Sespie
559*c87b03e5Sespie if ((s->symbol != NULL)
560*c87b03e5Sespie && !ffesymbol_is_save (s->symbol))
561*c87b03e5Sespie ffesymbol_update_save (s->symbol);
562*c87b03e5Sespie
563*c87b03e5Sespie if (s->parent != NULL)
564*c87b03e5Sespie ffestorag_update_save (s->parent);
565*c87b03e5Sespie
566*c87b03e5Sespie for (sq = s->equivs_.first;
567*c87b03e5Sespie sq != (ffestorag) &s->equivs_.first;
568*c87b03e5Sespie sq = ffestorag_next_ (sq))
569*c87b03e5Sespie {
570*c87b03e5Sespie if (!sq->is_save)
571*c87b03e5Sespie ffestorag_update_save (sq);
572*c87b03e5Sespie }
573*c87b03e5Sespie }
574