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