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 / equiv.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  35KB  |  1,147 lines
  1. /* equiv.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.       Handles the EQUIVALENCE relationships in a program unit.
  26.  
  27.    Modifications:
  28. */
  29.  
  30. /* Include files. */
  31.  
  32. #include "proj.h"
  33. #include "equiv.h"
  34. #include "bad.h"
  35. #include "bld.h"
  36. #include "com.h"
  37. #include "data.h"
  38. #include "global.h"
  39. #include "lex.h"
  40. #include "malloc.h"
  41. #include "symbol.h"
  42.  
  43. /* Externals defined here. */
  44.  
  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. struct _ffeequiv_list_
  58.   {
  59.     ffeequiv first;
  60.     ffeequiv last;
  61.   };
  62.  
  63. /* Static objects accessed by functions in this module. */
  64.  
  65. static struct _ffeequiv_list_ ffeequiv_list_;
  66.  
  67. /* Static functions (internal). */
  68.  
  69. static void ffeequiv_layout_local_ (ffeequiv eq);
  70. static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s,
  71.                   ffebld expr, bool subtract,
  72.                   ffetargetOffset adjust);
  73.  
  74. /* Internal macros. */
  75.  
  76.  
  77. /* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars
  78.  
  79.    ffeequiv eq;
  80.    ffeequiv_layout_local_(eq);
  81.  
  82.    Makes a single master ffestorag object that contains all the vars
  83.    in the equivalence, and makes subordinate ffestorag objects for the
  84.    vars with the correct offsets.  */
  85.  
  86. static void
  87. ffeequiv_layout_local_ (ffeequiv eq)
  88. {
  89.   ffesymbol s;            /* Symbol. */
  90.   ffestorag st;            /* Equivalence storage area. */
  91.   ffebld list;            /* List of list of equivalences. */
  92.   ffebld item;            /* List of equivalences. */
  93.   ffebld eqv;            /* Equivalence item. */
  94.   ffebld root;            /* Expression for (1st) root sym (offset=0). */
  95.   ffestorag rst;        /* Storage for root. */
  96.   ffetargetOffset root_offset;    /* Negative offset for root. */
  97.   ffesymbol sr;            /* Root itself. */
  98.   ffebld var;            /* Expression for equivalence. */
  99.   ffestorag vst;        /* Storage for var. */
  100.   ffetargetOffset var_offset;    /* Offset for var into equiv area (from
  101.                    root). */
  102.   ffesymbol sv;            /* Var itself. */
  103.   ffetargetAlign alignment;
  104.   ffetargetAlign modulo;
  105.   ffetargetAlign pad;
  106.   ffetargetOffset size;
  107.   ffetargetOffset num_elements;
  108.   bool new_storage;        /* Established new storage info. */
  109.   bool need_storage;        /* Have need for more storage info. */
  110.   bool ok;
  111.   bool init;
  112.  
  113.   assert (eq != NULL);
  114.   assert (ffeequiv_common (eq) == NULL);
  115.  
  116.   /* First find the symbol which, in the list of lists, has the reference
  117.      with the greatest offset, which means that symbol is the root symbol (it
  118.      will end up with an offset of zero in the equivalence area). */
  119.  
  120.   root_offset = 0;        /* Lowest possible value, to find max value. */
  121.   sr = NULL;            /* No sym found yet. */
  122.   ok = TRUE;
  123.  
  124.   for (list = ffeequiv_list (eq);
  125.        list != NULL;
  126.        list = ffebld_trail (list))
  127.     {                /* For every equivalence list in the list of
  128.                    equivs */
  129.       for (item = ffebld_head (list);
  130.        item != NULL;
  131.        item = ffebld_trail (item))
  132.     {            /* For every equivalence item in the list */
  133.       eqv = ffebld_head (item);
  134.       s = ffeequiv_symbol (eqv);
  135.       if (s == NULL)
  136.         continue;        /* Ignore me. */
  137.       assert (ffesymbol_storage (s) == NULL);    /* No storage yet. */
  138.       ffesymbol_set_equiv (s, NULL);    /* Equiv area slated for
  139.                            death. */
  140.       if (!ffeequiv_offset_ (&var_offset, s, eqv, FALSE, 0))
  141.         ok = FALSE;        /* Can't calc shape of equivalence area. */
  142.       if ((var_offset > root_offset) || (sr == NULL))
  143.         {
  144.           root_offset = var_offset;
  145.           sr = s;
  146.         }
  147.     }
  148.     }
  149.  
  150.   if (!ok)
  151.     {
  152.       ffeequiv_kill (eq);    /* Fully processed, no longer needed. */
  153.       return;
  154.     }
  155.  
  156.   if (sr == NULL)
  157.     return;            /* No syms in lists, return. */
  158.  
  159.   /* We've got work to do, so make the LOCAL storage object that'll hold all
  160.      the equivalenced vars inside it. */
  161.  
  162.   st = ffestorag_new (ffestorag_list_master ());
  163.   ffestorag_set_parent (st, NULL);    /* Initializations happen here. */
  164.   ffestorag_set_init (st, NULL);
  165.   ffestorag_set_accretion (st, NULL);
  166.   ffestorag_set_symbol (st, NULL);    /* LOCAL equiv collection has no
  167.                        single sym. */
  168.   ffestorag_set_offset (st, 0);
  169.   ffestorag_set_alignment (st, 1);
  170.   ffestorag_set_modulo (st, 0);
  171.   ffestorag_set_type (st, FFESTORAG_typeLOCAL);
  172.   ffestorag_set_basictype (st, ffesymbol_basictype (sr));
  173.   ffestorag_set_kindtype (st, ffesymbol_kindtype (sr));
  174.   ffestorag_set_typesymbol (st, sr);
  175.   ffestorag_set_save (st, ffeequiv_save (eq));
  176.   if (ffesymbol_save (sr))
  177.     ffestorag_update_save (st);
  178.  
  179.   /* Make the EQUIV storage object for the root symbol. */
  180.  
  181.   if (ffesymbol_rank (sr) == 0)
  182.     num_elements = 1;
  183.   else
  184.     num_elements = ffebld_constant_integerdefault (ffebld_conter
  185.                         (ffesymbol_arraysize (sr)));
  186.   ffetarget_layout (ffesymbol_text (sr), &alignment, &modulo, &size,
  187.             ffesymbol_basictype (sr), ffesymbol_kindtype (sr),
  188.             ffesymbol_size (sr), num_elements);
  189.   pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
  190.              ffestorag_ptr_to_modulo (st), 0, alignment,
  191.              modulo);
  192.   assert (pad == 0);
  193.  
  194.   rst = ffestorag_new (ffestorag_list_equivs (st));
  195.   ffestorag_set_parent (rst, st);    /* Initializations happen there. */
  196.   ffestorag_set_init (rst, NULL);
  197.   ffestorag_set_accretion (rst, NULL);
  198.   ffestorag_set_symbol (rst, sr);
  199.   ffestorag_set_size (rst, size);
  200.   ffestorag_set_offset (rst, 0);
  201.   ffestorag_set_alignment (rst, alignment);
  202.   ffestorag_set_modulo (rst, modulo);
  203.   ffestorag_set_type (rst, FFESTORAG_typeEQUIV);
  204.   ffestorag_set_basictype (rst, ffesymbol_basictype (sr));
  205.   ffestorag_set_kindtype (rst, ffesymbol_kindtype (sr));
  206.   ffestorag_set_typesymbol (rst, sr);
  207.   ffestorag_set_save (rst, FALSE);    /* Assume FALSE, then... */
  208.   if (ffestorag_save (st))    /* ...update to TRUE if needed. */
  209.     ffestorag_update_save (rst);
  210.   ffestorag_set_size (st, size);
  211.   ffesymbol_set_storage (sr, rst);
  212.   ffesymbol_signal_unreported (sr);
  213.   init = (ffesymbol_init (sr) != NULL) || (ffesymbol_accretion (sr) != NULL);
  214.  
  215.   /* Now that we know the root (offset=0) symbol, revisit all the lists and
  216.      do the actual storage allocation.    Keep doing this until we've gone
  217.      through them all without making any new storage objects. */
  218.  
  219.   do
  220.     {
  221.       new_storage = FALSE;
  222.       need_storage = FALSE;
  223.       for (list = ffeequiv_list (eq);
  224.        list != NULL;
  225.        list = ffebld_trail (list))
  226.     {            /* For every equivalence list in the list of
  227.                    equivs */
  228.       root_offset = 0;
  229.       sr = NULL;
  230.       root = NULL;
  231.       for (item = ffebld_head (list);
  232.            item != NULL;
  233.            item = ffebld_trail (item))
  234.         {            /* For every equivalence item in the list */
  235.           var = ffebld_head (item);
  236.           need_storage = TRUE;    /* Somebody is likely to need
  237.                        storage. */
  238.           sv = ffeequiv_symbol (var);
  239.           if (sv == NULL)
  240.         continue;    /* Ignore me. */
  241.           if ((vst = ffesymbol_storage (sv)) == NULL)
  242.         continue;    /* No storage for this guy, try another. */
  243.           ffeequiv_offset_ (&var_offset, sv, var, FALSE,
  244.                 ffestorag_offset (vst));
  245.           if ((var_offset > root_offset) || (sr == NULL))
  246.         {
  247.           root = var;
  248.           root_offset = var_offset;
  249.           sr = sv;
  250.           rst = vst;
  251.         }
  252.         }
  253.       if (sr == NULL)    /* No storage to go on, try later. */
  254.         continue;
  255.  
  256.       need_storage = FALSE;    /* Everyone in this sublist will get storage! */
  257.  
  258.       /* We now know the root symbol/expr and the operating offset of
  259.          that root into the equivalence area.  The other expressions in
  260.          the list all identify an initial storage unit that must have the
  261.          same offset. */
  262.  
  263.       for (item = ffebld_head (list);
  264.            item != NULL;
  265.            item = ffebld_trail (item))
  266.         {            /* For every equivalence item in the list */
  267.           var = ffebld_head (item);
  268.           if (var == root)
  269.         continue;    /* Except root, of course. */
  270.           sv = ffeequiv_symbol (var);
  271.           if (sv == NULL)
  272.         continue;    /* Except erroneous stuff (opANY). */
  273.           ffesymbol_set_equiv (sv, NULL);    /* Don't need this ref
  274.                            anymore. */
  275.           if (!ffeequiv_offset_ (&var_offset, sv, var, TRUE, root_offset))
  276.         continue;    /* Attempt to start sym prior to equiv area! */
  277.  
  278.           if (ffesymbol_rank (sv) == 0)
  279.         num_elements = 1;
  280.           else
  281.         num_elements = ffebld_constant_integerdefault (ffebld_conter
  282.                         (ffesymbol_arraysize (sv)));
  283.           ffetarget_layout (ffesymbol_text (sv), &alignment, &modulo,
  284.                 &size, ffesymbol_basictype (sv),
  285.                 ffesymbol_kindtype (sv), ffesymbol_size (sv),
  286.                 num_elements);
  287.           pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
  288.                      ffestorag_ptr_to_modulo (st),
  289.                      var_offset, alignment, modulo);
  290.           if (pad != 0)
  291.         {
  292.           ffebad_start (FFEBAD_EQUIV_ALIGN);
  293.           ffebad_string (ffesymbol_text (sv));
  294.           ffebad_finish ();
  295.           continue;
  296.         }
  297.  
  298.           if ((vst = ffesymbol_storage (sv)) == NULL)
  299.         {        /* Create new ffestorag object, extend equiv
  300.                    area. */
  301.           new_storage = TRUE;
  302.           vst = ffestorag_new (ffestorag_list_equivs (st));
  303.           ffestorag_set_parent (vst, st);    /* Initializations
  304.                                happen there. */
  305.           ffestorag_set_init (vst, NULL);
  306.           ffestorag_set_accretion (vst, NULL);
  307.           ffestorag_set_symbol (vst, sv);
  308.           ffestorag_set_size (vst, size);
  309.           ffestorag_set_offset (vst, var_offset);
  310.           ffestorag_set_alignment (vst, alignment);
  311.           ffestorag_set_modulo (vst, modulo);
  312.           ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
  313.           ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
  314.           ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
  315.           ffestorag_set_typesymbol (vst, sv);
  316.           ffestorag_set_save (vst, FALSE);    /* Assume FALSE... */
  317.           if (ffestorag_save (st))    /* ...update TRUE */
  318.             ffestorag_update_save (vst);    /* if needed. */
  319.           if (!ffetarget_offset_add (&size, var_offset, size))
  320.             /* Find one size of equiv area, complain if overflow. */
  321.             ffetarget_offset_overflow (ffesymbol_text (s));
  322.           else if (size > ffestorag_size (st))
  323.             /* Extend equiv area if necessary. */
  324.             ffestorag_set_size (st, size);
  325.           ffesymbol_set_storage (sv, vst);
  326.           ffesymbol_signal_unreported (sv);
  327.           ffestorag_update (st, sv, ffesymbol_basictype (sv),
  328.                     ffesymbol_kindtype (sv));
  329.           if ((ffesymbol_init (sv) != NULL)
  330.               || (ffesymbol_accretion (sv) != NULL))
  331.             init = TRUE;
  332.         }
  333.           else
  334.         {
  335.           /* Make sure offset agrees with known offset. */
  336.           if (var_offset != ffestorag_offset (vst))
  337.             {
  338.               ffebad_start (FFEBAD_EQUIV_MISMATCH);
  339.               ffebad_string (ffesymbol_text (sv));
  340.               ffebad_finish ();
  341.             }
  342.         }
  343.         }            /* (For every equivalence item in the list) */
  344.       ffebld_set_head (list, NULL);    /* Don't do this list again. */
  345.     }            /* (For every equivalence list in the list of
  346.                    equivs) */
  347.     }
  348.   while (new_storage && need_storage);
  349.  
  350.   ffeequiv_kill (eq);        /* Fully processed, no longer needed. */
  351.  
  352.   if (init)
  353.     ffedata_gather (st);    /* Gather subordinate inits into one init. */
  354. }
  355.  
  356. /* ffeequiv_offset_ -- Determine offset from start of symbol
  357.  
  358.    ffetargetOffset offset;
  359.    ffesymbol s;     // Symbol for error reporting.
  360.    ffebld expr;     // opSUBSTR, opARRAYREF, opSYMTER, opANY.
  361.    bool subtract;  // FALSE means add to adjust, TRUE means subtract from it.
  362.    ffetargetOffset adjust;  // Helps keep answer in pos range (unsigned).
  363.    if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust))
  364.        // error doing the calculation, message already printed
  365.  
  366.    Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF
  367.    combination added-to/subtracted-from the adjustment specified.  If there
  368.    is an error of some kind, returns FALSE, else returns TRUE.    Note that
  369.    only the first storage unit specified is considered; A(1:1) and A(1:2000)
  370.    have the same first storage unit and so return the same offset.  */
  371.  
  372. static bool
  373. ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s, ffebld expr,
  374.           bool subtract, ffetargetOffset adjust)
  375. {
  376.   ffetargetIntegerDefault value = 0;
  377.   ffetargetOffset cval;        /* Converted value. */
  378.   ffesymbol sym;
  379.  
  380.   if (expr == NULL)
  381.     return FALSE;
  382.  
  383. again:                /* :::::::::::::::::::: */
  384.  
  385.   switch (ffebld_op (expr))
  386.     {
  387.     case FFEBLD_opANY:
  388.       return FALSE;
  389.  
  390.     case FFEBLD_opSYMTER:
  391.       {
  392.     ffetargetOffset size;    /* Size of a single unit. */
  393.     ffetargetAlign a;    /* Ignored. */
  394.     ffetargetAlign m;    /* Ignored. */
  395.  
  396.     sym = ffebld_symter (expr);
  397.     if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
  398.       return FALSE;
  399.  
  400.     if (value < 0)
  401.       {            /* Really invalid, as in A(-2:5), but in case
  402.                    it's wanted.... */
  403.         if (!ffetarget_offset (&cval, -value))
  404.           return FALSE;
  405.         if (subtract)
  406.           return ffetarget_offset_add (offset, cval, adjust);
  407.  
  408.         if (cval > adjust)
  409.           {
  410.           neg:        /* :::::::::::::::::::: */
  411.         ffebad_start (FFEBAD_COMMON_NEG);
  412.         ffebad_string (ffesymbol_text (sym));
  413.         ffebad_finish ();
  414.         return FALSE;
  415.           }
  416.         *offset = adjust - cval;
  417.         return TRUE;
  418.       }
  419.  
  420.     if (!ffetarget_offset (&cval, value))
  421.       return FALSE;
  422.  
  423.     ffetarget_layout (ffesymbol_text (sym), &a, &m, &size,
  424.               ffesymbol_basictype (sym),
  425.               ffesymbol_kindtype (sym), 1, 1);
  426.  
  427.     if (!ffetarget_offset_multiply (&cval, cval, size))
  428.       return FALSE;
  429.  
  430.     if (subtract)
  431.       if (cval > adjust)
  432.         goto neg;        /* :::::::::::::::::::: */
  433.       else
  434.         *offset = adjust - cval;
  435.     else if (!ffetarget_offset_add (offset, cval, adjust))
  436.       return FALSE;
  437.     return TRUE;
  438.       }
  439.  
  440.     case FFEBLD_opARRAYREF:
  441.       {
  442.     ffebld symexp = ffebld_left (expr);
  443.     ffebld subscripts = ffebld_right (expr);
  444.     ffebld dims;
  445.     ffetargetIntegerDefault width;
  446.     ffetargetIntegerDefault arrayval;
  447.     ffetargetIntegerDefault lowbound;
  448.     ffetargetIntegerDefault highbound;
  449.     ffebld subscript;
  450.     ffebld dim;
  451.     ffebld low;
  452.     ffebld high;
  453.     int rank = 0;
  454.  
  455.     if (ffebld_op (symexp) != FFEBLD_opSYMTER)
  456.       return FALSE;
  457.  
  458.     sym = ffebld_symter (symexp);
  459.     if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
  460.       return FALSE;
  461.  
  462.     if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE)
  463.       width = 1;
  464.     else
  465.       width = ffesymbol_size (sym);
  466.     dims = ffesymbol_dims (sym);
  467.  
  468.     while (subscripts != NULL)
  469.       {
  470.         ++rank;
  471.         if (dims == NULL)
  472.           {
  473.         ffebad_start (FFEBAD_EQUIV_MANY);
  474.         ffebad_string (ffesymbol_text (sym));
  475.         ffebad_finish ();
  476.         return FALSE;
  477.           }
  478.  
  479.         subscript = ffebld_head (subscripts);
  480.         dim = ffebld_head (dims);
  481.  
  482.         assert (ffebld_op (subscript) == FFEBLD_opCONTER);
  483.         assert (ffeinfo_basictype (ffebld_info (subscript))
  484.             == FFEINFO_basictypeINTEGER);
  485.         assert (ffeinfo_kindtype (ffebld_info (subscript))
  486.             == FFEINFO_kindtypeINTEGERDEFAULT);
  487.         arrayval = ffebld_constant_integerdefault (ffebld_conter
  488.                                (subscript));
  489.  
  490.         assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
  491.         low = ffebld_left (dim);
  492.         high = ffebld_right (dim);
  493.  
  494.         if (low == NULL)
  495.           lowbound = 1;
  496.         else
  497.           {
  498.         assert (ffeinfo_basictype (ffebld_info (low))
  499.             == FFEINFO_basictypeINTEGER);
  500.         assert (ffeinfo_kindtype (ffebld_info (low))
  501.             == FFEINFO_kindtypeINTEGERDEFAULT);
  502.         lowbound
  503.           = ffebld_constant_integerdefault (ffebld_conter (low));
  504.           }
  505.  
  506.         assert (ffebld_op (high) == FFEBLD_opCONTER);
  507.         assert (ffeinfo_basictype (ffebld_info (high))
  508.             == FFEINFO_basictypeINTEGER);
  509.         assert (ffeinfo_kindtype (ffebld_info (high))
  510.             == FFEINFO_kindtypeINTEGER1);
  511.         highbound
  512.           = ffebld_constant_integerdefault (ffebld_conter (high));
  513.  
  514.         if ((arrayval < lowbound) || (arrayval > highbound))
  515.           {
  516.         char rankstr[10];
  517.  
  518.         sprintf (rankstr, "%d", rank);
  519.         ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
  520.         ffebad_string (ffesymbol_text (sym));
  521.         ffebad_string (rankstr);
  522.         ffebad_finish ();
  523.           }
  524.  
  525.         subscripts = ffebld_trail (subscripts);
  526.         dims = ffebld_trail (dims);
  527.  
  528.         value += width * (arrayval - lowbound);
  529.         if (subscripts != NULL)
  530.           width *= highbound - lowbound + 1;
  531.       }
  532.  
  533.     if (dims != NULL)
  534.       {
  535.         ffebad_start (FFEBAD_EQUIV_FEW);
  536.         ffebad_string (ffesymbol_text (sym));
  537.         ffebad_finish ();
  538.         return FALSE;
  539.       }
  540.  
  541.     expr = symexp;
  542.       }
  543.       goto again;        /* :::::::::::::::::::: */
  544.  
  545.     case FFEBLD_opSUBSTR:
  546.       {
  547.     ffebld begin = ffebld_head (ffebld_right (expr));
  548.  
  549.     expr = ffebld_left (expr);
  550.     if (ffebld_op (expr) == FFEBLD_opARRAYREF)
  551.       sym = ffebld_symter (ffebld_left (expr));
  552.     else if (ffebld_op (expr) == FFEBLD_opSYMTER)
  553.       sym = ffebld_symter (expr);
  554.     else
  555.       sym = NULL;
  556.  
  557.     if ((sym != NULL)
  558.         && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
  559.       return FALSE;
  560.  
  561.     if (begin == NULL)
  562.       value = 0;
  563.     else
  564.       {
  565.         assert (ffebld_op (begin) == FFEBLD_opCONTER);
  566.         assert (ffeinfo_basictype (ffebld_info (begin))
  567.             == FFEINFO_basictypeINTEGER);
  568.         assert (ffeinfo_kindtype (ffebld_info (begin))
  569.             == FFEINFO_kindtypeINTEGERDEFAULT);
  570.  
  571.         value = ffebld_constant_integerdefault (ffebld_conter (begin));
  572.  
  573.         if ((value < 1)
  574.         || ((sym != NULL)
  575.             && (value > ffesymbol_size (sym))))
  576.           {
  577.         ffebad_start (FFEBAD_EQUIV_RANGE);
  578.         ffebad_string (ffesymbol_text (sym));
  579.         ffebad_finish ();
  580.           }
  581.  
  582.         --value;
  583.       }
  584.     if ((sym != NULL)
  585.         && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
  586.       {
  587.         ffebad_start (FFEBAD_EQUIV_SUBSTR);
  588.         ffebad_string (ffesymbol_text (sym));
  589.         ffebad_finish ();
  590.         value = 0;
  591.       }
  592.       }
  593.       goto again;        /* :::::::::::::::::::: */
  594.  
  595.     default:
  596.       assert ("bad op" == NULL);
  597.       return FALSE;
  598.     }
  599.  
  600. }
  601.  
  602. /* ffeequiv_add -- Add list of equivalences to list of lists for eq object
  603.  
  604.    ffeequiv eq;
  605.    ffebld list;
  606.    ffelexToken t;  // points to first item in equivalence list
  607.    ffeequiv_add(eq,list,t);
  608.  
  609.    Check the list to make sure only one common symbol is involved (even
  610.    if multiple times) and agrees with the common symbol for the equivalence
  611.    object (or it has no common symbol until now).  Prepend (aka append, it
  612.    doesn't matter) the list to the list of lists for the equivalence object.
  613.    Otherwise report an error and return.  */
  614.  
  615. void
  616. ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
  617. {
  618.   ffebld item;
  619.   ffesymbol symbol;
  620.  
  621.   for (item = list; item != NULL; item = ffebld_trail (item))
  622.     {
  623.       symbol = ffeequiv_symbol (ffebld_head (item));
  624.  
  625.       if (ffesymbol_equiv (symbol) == NULL)
  626.     ffesymbol_set_equiv (symbol, eq);
  627.       else
  628.     assert (ffesymbol_equiv (symbol) == eq);
  629.  
  630.       if (ffesymbol_common (symbol) == NULL)    /* Is symbol in a COMMON
  631.                            area? */
  632.     {            /* No (at least not yet). */
  633.       if ((ffesymbol_init (symbol) != NULL)
  634.           || (ffesymbol_accretion (symbol) != NULL))
  635.         eq->init = TRUE;
  636.       if (ffesymbol_save (symbol))
  637.         ffeequiv_update_save (eq);    /* EQUIVALENCE has >=1 SAVEd entity. */
  638.       continue;        /* Nothing more to do here. */
  639.     }
  640.  
  641. #if FFEGLOBAL_ENABLED
  642.       if ((ffesymbol_init (symbol) != NULL)
  643.       || (ffesymbol_accretion (symbol) != NULL))
  644.     ffeglobal_init_common (ffesymbol_common (symbol), t);
  645. #endif
  646.  
  647.       if (ffesymbol_save (ffesymbol_common (symbol)))
  648.     ffeequiv_update_save (eq);    /* EQUIVALENCE is in a SAVEd COMMON
  649.                        block. */
  650.  
  651.       if (ffeequiv_common (eq) == NULL)    /* Is COMMON involved already? */
  652.     /* No, but there is now. */
  653.     ffeequiv_set_common (eq, ffesymbol_common (symbol));
  654.       else if (ffeequiv_common (eq) != ffesymbol_common (symbol))
  655.     {
  656.       /* Yes, and it isn't the same as our new COMMON area. */
  657.       ffebad_start (FFEBAD_EQUIV_COMMON);
  658.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  659.       ffebad_string (ffesymbol_text (ffeequiv_common (eq)));
  660.       ffebad_string (ffesymbol_text (ffesymbol_common (symbol)));
  661.       ffebad_finish ();
  662.       return;
  663.     }
  664.     }
  665.  
  666.   ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
  667. }
  668.  
  669. /* ffeequiv_dump -- Dump info on equivalence object
  670.  
  671.    ffeequiv eq;
  672.    ffeequiv_dump(eq);  */
  673.  
  674. void
  675. ffeequiv_dump (ffeequiv eq)
  676. {
  677.   if (ffeequiv_common (eq) != NULL)
  678.     fprintf (stdout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq)));
  679.   ffebld_dump (ffeequiv_list (eq));
  680. }
  681.  
  682. /* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects
  683.  
  684.    ffeequiv_exec_transition();    */
  685.  
  686. void
  687. ffeequiv_exec_transition ()
  688. {
  689.   while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
  690.     ffeequiv_layout_local_ (ffeequiv_list_.first);
  691. }
  692.  
  693. /* ffeequiv_init_2 -- Initialize for new program unit
  694.  
  695.    ffeequiv_init_2();
  696.  
  697.    Initializes the list of equivalences.  */
  698.  
  699. void
  700. ffeequiv_init_2 ()
  701. {
  702.   ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
  703.   ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
  704. }
  705.  
  706. /* ffeequiv_kill -- Kill equivalence object after removing from list
  707.  
  708.    ffeequiv eq;
  709.    ffeequiv_kill(eq);
  710.  
  711.    Removes equivalence object from master list, then kills it.    */
  712.  
  713. void
  714. ffeequiv_kill (ffeequiv victim)
  715. {
  716.   victim->next->previous = victim->previous;
  717.   victim->previous->next = victim->next;
  718.   malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
  719. }
  720.  
  721. /* ffeequiv_layout_cblock -- Lay out storage for common area
  722.  
  723.    ffestorag st;
  724.    if (ffeequiv_layout_cblock(st))
  725.        // at least one equiv'd symbol has init/accretion expr.
  726.  
  727.    Now that the explicitly COMMONed variables in the common area (whose
  728.    ffestorag object is passed) have been laid out, lay out the storage
  729.    for all variables equivalenced into the area by making subordinate
  730.    ffestorag objects for them.    */
  731.  
  732. bool
  733. ffeequiv_layout_cblock (ffestorag st)
  734. {
  735.   ffesymbol s = ffestorag_symbol (st);    /* CBLOCK symbol. */
  736.   ffebld list;            /* List of explicit common vars, in order, in
  737.                    s. */
  738.   ffebld item;            /* List of list of equivalences in a given
  739.                    explicit common var. */
  740.   ffebld root;            /* Expression for (1st) explicit common var
  741.                    in list of eqs. */
  742.   ffestorag rst;        /* Storage for root. */
  743.   ffetargetOffset root_offset;    /* Offset for root into common area. */
  744.   ffesymbol sr;            /* Root itself. */
  745.   ffeequiv seq;            /* Its equivalence object, if any. */
  746.   ffebld var;            /* Expression for equivalence. */
  747.   ffestorag vst;        /* Storage for var. */
  748.   ffetargetOffset var_offset;    /* Offset for var into common area. */
  749.   ffesymbol sv;            /* Var itself. */
  750.   ffebld altroot;        /* Alternate root. */
  751.   ffesymbol altrootsym;        /* Alternate root symbol. */
  752.   ffetargetAlign alignment;
  753.   ffetargetAlign modulo;
  754.   ffetargetAlign pad;
  755.   ffetargetOffset size;
  756.   ffetargetOffset num_elements;
  757.   bool new_storage;        /* Established new storage info. */
  758.   bool need_storage;        /* Have need for more storage info. */
  759.   bool ok;
  760.   bool init = FALSE;
  761.  
  762.   assert (st != NULL);
  763.   assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK);
  764.   assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON);
  765.  
  766.   for (list = ffesymbol_commonlist (ffestorag_symbol (st));
  767.        list != NULL;
  768.        list = ffebld_trail (list))
  769.     {                /* For every variable in the common area */
  770.       assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER);
  771.       sr = ffebld_symter (ffebld_head (list));
  772.       if ((seq = ffesymbol_equiv (sr)) == NULL)
  773.     continue;        /* No equivalences to process. */
  774.       rst = ffesymbol_storage (sr);
  775.       if (rst == NULL)
  776.     {
  777.       assert (ffesymbol_kind (sr) == FFEINFO_kindANY);
  778.       continue;
  779.     }
  780.       ffesymbol_set_equiv (sr, NULL);    /* Cancel ref to equiv obj. */
  781.       do
  782.     {
  783.       new_storage = FALSE;
  784.       need_storage = FALSE;
  785.       for (item = ffeequiv_list (seq);    /* Get list of equivs. */
  786.            item != NULL;
  787.            item = ffebld_trail (item))
  788.         {            /* For every eqv list in the list of equivs
  789.                    for the variable */
  790.           altroot = NULL;
  791.           altrootsym = NULL;
  792.           for (root = ffebld_head (item);
  793.            root != NULL;
  794.            root = ffebld_trail (root))
  795.         {        /* For every equivalence item in the list */
  796.           sv = ffeequiv_symbol (ffebld_head (root));
  797.           if (sv == sr)
  798.             break;    /* Found first mention of "rooted" symbol. */
  799.           if (ffesymbol_storage (sv) != NULL)
  800.             {
  801.               altroot = root;    /* If no mention, use this guy
  802.                        instead. */
  803.               altrootsym = sv;
  804.             }
  805.         }
  806.           if (root != NULL)
  807.         {
  808.           root = ffebld_head (root);    /* Lose its opITEM. */
  809.           ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE,
  810.                      ffestorag_offset (rst));
  811.           /* Equiv point prior to start of common area? */
  812.         }
  813.           else if (altroot != NULL)
  814.         {
  815.           /* Equiv point prior to start of common area? */
  816.           root = ffebld_head (altroot);
  817.           ok = ffeequiv_offset_ (&root_offset, altrootsym, root,
  818.                      FALSE,
  819.              ffestorag_offset (ffesymbol_storage (altrootsym)));
  820.           ffesymbol_set_equiv (altrootsym, NULL);
  821.         }
  822.           else
  823.         /* No rooted symbol in list of equivalences! */
  824.         {        /* Assume this was due to opANY and ignore
  825.                    this list for now. */
  826.           need_storage = TRUE;
  827.           continue;
  828.         }
  829.  
  830.           /* We now know the root symbol and the operating offset of that
  831.              root into the common area.  The other expressions in the
  832.              list all identify an initial storage unit that must have the
  833.              same offset. */
  834.  
  835.           for (var = ffebld_head (item);
  836.            var != NULL;
  837.            var = ffebld_trail (var))
  838.         {        /* For every equivalence item in the list */
  839.           if (ffebld_head (var) == root)
  840.             continue;    /* Except root, of course. */
  841.           sv = ffeequiv_symbol (ffebld_head (var));
  842.           if (sv == NULL)
  843.             continue;    /* Except erroneous stuff (opANY). */
  844.           ffesymbol_set_equiv (sv, NULL);    /* Don't need this ref
  845.                                anymore. */
  846.           if (!ok
  847.               || !ffeequiv_offset_ (&var_offset, sv,
  848.                         ffebld_head (var), TRUE,
  849.                         root_offset))
  850.             continue;    /* Can't do negative offset wrt COMMON. */
  851.  
  852.           if (ffesymbol_rank (sv) == 0)
  853.             num_elements = 1;
  854.           else
  855.             num_elements = ffebld_constant_integerdefault
  856.               (ffebld_conter (ffesymbol_arraysize (sv)));
  857.           ffetarget_layout (ffesymbol_text (sv), &alignment,
  858.                     &modulo, &size,
  859.                     ffesymbol_basictype (sv),
  860.                     ffesymbol_kindtype (sv),
  861.                     ffesymbol_size (sv), num_elements);
  862.           pad = ffetarget_align (ffestorag_ptr_to_alignment (st),
  863.                      ffestorag_ptr_to_modulo (st),
  864.                      var_offset, alignment, modulo);
  865.           if (pad != 0)
  866.             {
  867.               ffebad_start (FFEBAD_EQUIV_ALIGN);
  868.               ffebad_string (ffesymbol_text (sv));
  869.               ffebad_finish ();
  870.               continue;
  871.             }
  872.  
  873.           if ((vst = ffesymbol_storage (sv)) == NULL)
  874.             {        /* Create new ffestorag object, extend
  875.                    cblock. */
  876.               new_storage = TRUE;
  877.               vst = ffestorag_new (ffestorag_list_equivs (st));
  878.               ffestorag_set_parent (vst, st);    /* Initializations
  879.                                happen there. */
  880.               ffestorag_set_init (vst, NULL);
  881.               ffestorag_set_accretion (vst, NULL);
  882.               ffestorag_set_symbol (vst, sv);
  883.               ffestorag_set_size (vst, size);
  884.               ffestorag_set_offset (vst, var_offset);
  885.               ffestorag_set_alignment (vst, alignment);
  886.               ffestorag_set_modulo (vst, modulo);
  887.               ffestorag_set_type (vst, FFESTORAG_typeEQUIV);
  888.               ffestorag_set_basictype (vst, ffesymbol_basictype (sv));
  889.               ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv));
  890.               ffestorag_set_typesymbol (vst, sv);
  891.               ffestorag_set_save (vst, FALSE);    /* Assume FALSE... */
  892.               if (ffestorag_save (st))    /* ...update TRUE */
  893.             ffestorag_update_save (vst);    /* if needed. */
  894.               if (!ffetarget_offset_add (&size, var_offset, size))
  895.             /* Find one size of common block, complain if
  896.                overflow. */
  897.             ffetarget_offset_overflow (ffesymbol_text (s));
  898.               else if (size > ffestorag_size (st))
  899.             /* Extend common. */
  900.             ffestorag_set_size (st, size);
  901.               ffesymbol_set_storage (sv, vst);
  902.               ffesymbol_set_common (sv, s);
  903.               ffesymbol_signal_unreported (sv);
  904.               ffestorag_update (st, sv, ffesymbol_basictype (sv),
  905.                     ffesymbol_kindtype (sv));
  906.               if ((ffesymbol_init (sv) != NULL)
  907.               || (ffesymbol_accretion (sv) != NULL))
  908.             init = TRUE;
  909.             }
  910.           else
  911.             {
  912.               /* Make sure offset agrees with known offset. */
  913.               if (var_offset != ffestorag_offset (vst))
  914.             {
  915.               ffebad_start (FFEBAD_EQUIV_MISMATCH);
  916.               ffebad_string (ffesymbol_text (sv));
  917.               ffebad_finish ();
  918.             }
  919.             }
  920.         }        /* (For every equivalence item in the list) */
  921.         }            /* (For every eqv list in the list of equivs
  922.                    for the variable) */
  923.     }
  924.       while (new_storage && need_storage);
  925.  
  926.       ffeequiv_kill (seq);    /* Kill equiv obj. */
  927.     }                /* (For every variable in the common area) */
  928.  
  929.   return init;
  930. }
  931.  
  932. /* ffeequiv_merge -- Merge two equivalence objects, return the merged result
  933.  
  934.    ffeequiv eq1;
  935.    ffeequiv eq2;
  936.    ffelexToken t;  // points to current equivalence item forcing the merge.
  937.    eq1 = ffeequiv_merge(eq1,eq2,t);
  938.  
  939.    If the two equivalence objects can be merged, they are, all the
  940.    ffesymbols in their lists of lists are adjusted to point to the merged
  941.    equivalence object, and the merged object is returned.
  942.  
  943.    Otherwise, the two equivalence objects have different non-NULL common
  944.    symbols, so the merge cannot take place.  An error message is issued and
  945.    NULL is returned.  */
  946.  
  947. ffeequiv
  948. ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t)
  949. {
  950.   ffebld list;
  951.   ffebld eqs;
  952.   ffesymbol symbol;
  953.   ffebld last = NULL;
  954.  
  955.   /* If both equivalence objects point to different common-based symbols,
  956.      complain.    Of course, one or both might have NULL common symbols now,
  957.      and get COMMONed later, but the COMMON statement handler checks for
  958.      this. */
  959.  
  960.   if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL)
  961.       && (ffeequiv_common (eq1) != ffeequiv_common (eq2)))
  962.     {
  963.       ffebad_start (FFEBAD_EQUIV_COMMON);
  964.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  965.       ffebad_string (ffesymbol_text (ffeequiv_common (eq1)));
  966.       ffebad_string (ffesymbol_text (ffeequiv_common (eq2)));
  967.       ffebad_finish ();
  968.       return NULL;
  969.     }
  970.  
  971.   /* Make eq1 the new, merged object (arbitrarily). */
  972.  
  973.   if (ffeequiv_common (eq1) == NULL)
  974.     ffeequiv_set_common (eq1, ffeequiv_common (eq2));
  975.  
  976.   /* If the victim object has any init'ed entities, so does the new object. */
  977.  
  978.   if (eq2->init)
  979.     eq1->init = TRUE;
  980.  
  981. #if FFEGLOBAL_ENABLED
  982.   if (eq1->init && (ffeequiv_common (eq1) != NULL))
  983.     ffeglobal_init_common (ffeequiv_common (eq1), t);
  984. #endif
  985.  
  986.   /* If the victim object has any SAVEd entities, then the new object has
  987.      some. */
  988.  
  989.   if (ffeequiv_save (eq2))
  990.     ffeequiv_update_save (eq1);
  991.  
  992.   /* Adjust all the symbols in the list of lists of equivalences for the
  993.      victim equivalence object so they point to the new merged object
  994.      instead. */
  995.  
  996.   for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list))
  997.     {
  998.       for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs))
  999.     {
  1000.       symbol = ffeequiv_symbol (ffebld_head (eqs));
  1001.       if (ffesymbol_equiv (symbol) == eq2)
  1002.         ffesymbol_set_equiv (symbol, eq1);
  1003.       else
  1004.         assert (ffesymbol_equiv (symbol) == eq1);    /* Can see a sym > once. */
  1005.     }
  1006.  
  1007.       /* For convenience, remember where the last ITEM in the outer list is. */
  1008.  
  1009.       if (ffebld_trail (list) == NULL)
  1010.     {
  1011.       last = list;
  1012.       break;
  1013.     }
  1014.     }
  1015.  
  1016.   /* Append the list of lists in the new, merged object to the list of lists
  1017.      in the victim object, then use the new combined list in the new merged
  1018.      object. */
  1019.  
  1020.   ffebld_set_trail (last, ffeequiv_list (eq1));
  1021.   ffeequiv_set_list (eq1, ffeequiv_list (eq2));
  1022.  
  1023.   /* Unlink and kill the victim object. */
  1024.  
  1025.   ffeequiv_kill (eq2);
  1026.  
  1027.   return eq1;            /* Return the new merged object. */
  1028. }
  1029.  
  1030. /* ffeequiv_new -- Create new equivalence object, put in list
  1031.  
  1032.    ffeequiv eq;
  1033.    eq = ffeequiv_new();
  1034.  
  1035.    Creates a new equivalence object and adds it to the list of equivalence
  1036.    objects.  */
  1037.  
  1038. ffeequiv
  1039. ffeequiv_new ()
  1040. {
  1041.   ffeequiv eq;
  1042.  
  1043.   eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq));
  1044.   eq->next = (ffeequiv) &ffeequiv_list_.first;
  1045.   eq->previous = ffeequiv_list_.last;
  1046.   ffeequiv_set_common (eq, NULL);    /* No COMMON area yet. */
  1047.   ffeequiv_set_list (eq, NULL);    /* No list of lists of equivalences yet. */
  1048.   ffeequiv_set_save (eq, FALSE);
  1049.   eq->init = FALSE;
  1050.   eq->next->previous = eq;
  1051.   eq->previous->next = eq;
  1052.  
  1053.   return eq;
  1054. }
  1055.  
  1056. /* ffeequiv_symbol -- Return symbol for equivalence expression
  1057.  
  1058.    ffesymbol symbol;
  1059.    ffebld expr;
  1060.    symbol = ffeequiv_symbol(expr);
  1061.  
  1062.    Finds the terminal SYMTER in an equivalence expression and returns the
  1063.    ffesymbol for it.  */
  1064.  
  1065. ffesymbol
  1066. ffeequiv_symbol (ffebld expr)
  1067. {
  1068.   assert (expr != NULL);
  1069.  
  1070. again:                /* :::::::::::::::::::: */
  1071.  
  1072.   switch (ffebld_op (expr))
  1073.     {
  1074.     case FFEBLD_opARRAYREF:
  1075.     case FFEBLD_opSUBSTR:
  1076.       expr = ffebld_left (expr);
  1077.       goto again;        /* :::::::::::::::::::: */
  1078.  
  1079.     case FFEBLD_opSYMTER:
  1080.       return ffebld_symter (expr);
  1081.  
  1082.     case FFEBLD_opANY:
  1083.       return NULL;
  1084.  
  1085.     default:
  1086.       assert ("bad eq expr" == NULL);
  1087.       return NULL;
  1088.     }
  1089. }
  1090.  
  1091. /* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE
  1092.  
  1093.    ffeequiv eq;
  1094.    ffeequiv_update_save(eq);
  1095.  
  1096.    If the SAVE flag for the <eq> object is already set, return.     Else,
  1097.    set it TRUE and call ffe*_update_save for all objects contained in
  1098.    this one.  */
  1099.  
  1100. void
  1101. ffeequiv_update_save (ffeequiv eq)
  1102. {
  1103.   ffebld list;            /* Current list in list of lists. */
  1104.   ffebld item;            /* Current item in current list. */
  1105.   ffebld expr;            /* Expression in head of current item. */
  1106.  
  1107.   if (eq->save)
  1108.     return;
  1109.  
  1110.   eq->save = TRUE;
  1111.  
  1112.   if (eq->common != NULL)
  1113.     ffesymbol_update_save (eq->common);    /* Shouldn't be needed. */
  1114.  
  1115.   for (list = eq->list; list != NULL; list = ffebld_trail (list))
  1116.     {
  1117.       for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
  1118.     {
  1119.       expr = ffebld_head (item);
  1120.  
  1121.     again:            /* :::::::::::::::::::: */
  1122.  
  1123.       switch (ffebld_op (expr))
  1124.         {
  1125.         case FFEBLD_opANY:
  1126.           break;
  1127.  
  1128.         case FFEBLD_opSYMTER:
  1129.           ffesymbol_update_save (ffebld_symter (expr));
  1130.           break;
  1131.  
  1132.         case FFEBLD_opARRAYREF:
  1133.           expr = ffebld_left (expr);
  1134.           goto again;    /* :::::::::::::::::::: */
  1135.  
  1136.         case FFEBLD_opSUBSTR:
  1137.           expr = ffebld_left (expr);
  1138.           goto again;    /* :::::::::::::::::::: */
  1139.  
  1140.         default:
  1141.           assert ("bad op for ffeequiv_update_save" == NULL);
  1142.           break;
  1143.         }
  1144.     }
  1145.     }
  1146. }
  1147.