contrib/gcc-3.4/gcc/f/storag.c

   1 /* storag.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 2003 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 (void)
 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 = malloc_new_kp (ffe_pool_program_unit (), "ffestorag", sizeof (*s));
 420   s->next = (ffestorag) &sl->first;
 421   s->previous = sl->last;
 422   s->hook = FFECOM_storageNULL;
 423   s->previous->next = s;
 424   sl->last = s;
 425   s->equivs_.first = s->equivs_.last = (ffestorag) &s->equivs_.first;
 426
 427   return s;
 428 }
 429
 430 /* Report info on LOCAL non-sym-assoc'ed entities if needed.  */
 431
 432 void
 433 ffestorag_report (void)
 434 {
 435   ffestorag s;
 436
 437   if (ffestorag_reported_)
 438     return;
 439
 440   for (s = ffestorag_list_.first;
 441        s != (ffestorag) &ffestorag_list_.first;
 442        s = s->next)
 443     {
 444       if (s->symbol == NULL)
 445         {
 446           ffestorag_reported_ = TRUE;
 447           fputs ("Storage area: ", dmpout);
 448           ffestorag_dump (s);
 449           fputc ('\n', dmpout);
 450         }
 451     }
 452 }
 453
 454 /* ffestorag_update -- Update type info for ffestorag object
 455
 456    ffestorag s;  // existing object
 457    ffeinfoBasictype bt;  // basic type for newly added member of object
 458    ffeinfoKindtype kt;  // kind type for it
 459    ffestorag_update(s,bt,kt);
 460
 461    If the existing type for the storage object agrees with the new type
 462    info, just returns.  If the basic types agree but not the kind types,
 463    sets the kind type for the object to NONE.  If the basic types
 464    disagree, sets the kind type to NONE, and the basic type to NONE if the
 465    basic types both are not CHARACTER, otherwise to ANY.  If the basic
 466    type for the object already is NONE, it is set to ANY if the new basic
 467    type is CHARACTER.  Any time a transition is made to ANY and pedantic
 468    mode is on, a message is issued that mixing CHARACTER and non-CHARACTER
 469    stuff in the same COMMON/EQUIVALENCE is invalid.  */
 470
 471 void
 472 ffestorag_update (ffestorag s, ffesymbol sym, ffeinfoBasictype bt,
 473                   ffeinfoKindtype kt)
 474 {
 475   if (s->basic_type == bt)
 476     {
 477       if (s->kind_type == kt)
 478         return;
 479       s->kind_type = FFEINFO_kindtypeNONE;
 480       return;
 481     }
 482
 483   switch (s->basic_type)
 484     {
 485     case FFEINFO_basictypeANY:
 486       return;                   /* No need to do anything further. */
 487
 488     case FFEINFO_basictypeCHARACTER:
 489     any:                        /* :::::::::::::::::::: */
 490       s->basic_type = FFEINFO_basictypeANY;
 491       s->kind_type = FFEINFO_kindtypeANY;
 492       if (ffe_is_pedantic ())
 493         {
 494           ffebad_start (FFEBAD_MIXED_TYPES);
 495           ffebad_string (ffesymbol_text (s->type_symbol));
 496           ffebad_string (ffesymbol_text (sym));
 497           ffebad_finish ();
 498         }
 499       return;
 500
 501     default:
 502       if (bt == FFEINFO_basictypeCHARACTER)
 503         goto any;               /* :::::::::::::::::::: */
 504       s->basic_type = FFEINFO_basictypeNONE;
 505       s->kind_type = FFEINFO_kindtypeNONE;
 506       return;
 507     }
 508 }
 509
 510 /* Update INIT flag for storage object.
 511
 512    If the INIT flag for the <s> object is already TRUE, return.  Else,
 513    set it to TRUE and call ffe*_update_init for all contained objects.  */
 514
 515 void
 516 ffestorag_update_init (ffestorag s)
 517 {
 518   ffestorag sq;
 519
 520   if (s->is_init)
 521     return;
 522
 523   s->is_init = TRUE;
 524
 525   if ((s->symbol != NULL)
 526       && !ffesymbol_is_init (s->symbol))
 527     ffesymbol_update_init (s->symbol);
 528
 529   if (s->parent != NULL)
 530     ffestorag_update_init (s->parent);
 531
 532   for (sq = s->equivs_.first;
 533        sq != (ffestorag) &s->equivs_.first;
 534        sq = ffestorag_next_ (sq))
 535     {
 536       if (!sq->is_init)
 537         ffestorag_update_init (sq);
 538     }
 539 }
 540
 541 /* Update SAVE flag for storage object.
 542
 543    If the SAVE flag for the <s> object is already TRUE, return.  Else,
 544    set it to TRUE and call ffe*_update_save for all contained objects.  */
 545
 546 void
 547 ffestorag_update_save (ffestorag s)
 548 {
 549   ffestorag sq;
 550
 551   if (s->is_save)
 552     return;
 553
 554   s->is_save = TRUE;
 555
 556   if ((s->symbol != NULL)
 557       && !ffesymbol_is_save (s->symbol))
 558     ffesymbol_update_save (s->symbol);
 559
 560   if (s->parent != NULL)
 561     ffestorag_update_save (s->parent);
 562
 563   for (sq = s->equivs_.first;
 564        sq != (ffestorag) &s->equivs_.first;
 565        sq = ffestorag_next_ (sq))
 566     {
 567       if (!sq->is_save)
 568         ffestorag_update_save (sq);
 569     }
 570 }