contrib/gcc/f/storag.c

   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 \f
  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
  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
 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
 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
 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
 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
 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
 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
 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
 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
 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 }