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