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 / stu.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  28KB  |  964 lines
  1. /* stu.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. */
  22.  
  23. /* Include files. */
  24.  
  25. #include "proj.h"
  26. #include "bld.h"
  27. #include "com.h"
  28. #include "equiv.h"
  29. #include "info.h"
  30. #include "implic.h"
  31. #include "intrin.h"
  32. #include "stu.h"
  33. #include "storag.h"
  34. #include "sta.h"
  35. #include "symbol.h"
  36. #include "target.h"
  37.  
  38. /* Externals defined here. */
  39.  
  40.  
  41. /* Simple definitions and enumerations. */
  42.  
  43.  
  44. /* Internal typedefs. */
  45.  
  46.  
  47. /* Private include files. */
  48.  
  49.  
  50. /* Internal structure definitions. */
  51.  
  52.  
  53. /* Static objects accessed by functions in this module. */
  54.  
  55.  
  56. /* Static functions (internal). */
  57.  
  58. static void ffestu_list_exec_transition_ (ffebld list);
  59. static void ffestu_symter_exec_transition_ (ffebld expr);
  60. static bool ffestu_dummies_transition_ (ffesymbol (*symfunc) (),
  61.                     ffebld list);
  62.  
  63. /* Internal macros. */
  64.  
  65. #define ffestu_equiv_(s) (((ffesymbol_equiv (s) == NULL)              \
  66.   || (ffeequiv_common (ffesymbol_equiv (s)) == NULL)) ? FFEINFO_whereLOCAL    \
  67.   : FFEINFO_whereCOMMON)
  68.  
  69. /* Update symbol info just before end of unit.  */
  70.  
  71. ffesymbol
  72. ffestu_sym_end_transition (ffesymbol s)
  73. {
  74.   ffeinfoKind skd;
  75.   ffeinfoWhere swh;
  76.   ffeinfoKind nkd;
  77.   ffeinfoWhere nwh;
  78.   ffesymbolAttrs sa;
  79.   ffesymbolAttrs na;
  80.   ffesymbolState ss;
  81.   ffesymbolState ns;
  82.   bool needs_type = TRUE;    /* Implicit type assignment might be
  83.                    necessary. */
  84.  
  85.   assert (s != NULL);
  86.   ss = ffesymbol_state (s);
  87.   sa = ffesymbol_attrs (s);
  88.   skd = ffesymbol_kind (s);
  89.   swh = ffesymbol_where (s);
  90.  
  91.   switch (ss)
  92.     {
  93.     case FFESYMBOL_stateUNCERTAIN:
  94.       if ((swh == FFEINFO_whereDUMMY)
  95. #if 0
  96.       && (skd == FFEINFO_kindENTITY)
  97.       && (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
  98. #endif
  99.       && (ffesymbol_numentries (s) == 0))
  100.     {            /* Not actually in any dummy list! */
  101.       ffesymbol_error (s, ffesta_tokens[0]);
  102.     }
  103.       break;
  104.  
  105.     case FFESYMBOL_stateUNDERSTOOD:
  106.       if ((swh == FFEINFO_whereLOCAL)
  107.       && ((skd == FFEINFO_kindFUNCTION)
  108.           || (skd == FFEINFO_kindSUBROUTINE)))
  109.     ffestu_dummies_transition_ (ffecom_sym_end_transition,
  110.                     ffesymbol_dummyargs (s));
  111.       else if ((swh == FFEINFO_whereDUMMY)
  112. #if 0
  113.            && (skd == FFEINFO_kindENTITY)
  114.            && (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
  115. #endif
  116.            && (ffesymbol_numentries (s) == 0))
  117.     {            /* Not actually in any dummy list! */
  118.       ffesymbol_error (s, ffesta_tokens[0]);
  119.     }
  120.  
  121.       ffestorag_end_layout (s);
  122.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  123.       return s;
  124.  
  125.     default:
  126.       assert ("bad status" == NULL);
  127.       return s;
  128.     }
  129.   ns = FFESYMBOL_stateUNDERSTOOD;
  130.  
  131.   na = sa = ffesymbol_attrs (s);
  132.  
  133.   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  134.            | FFESYMBOL_attrsANYLEN
  135.            | FFESYMBOL_attrsARRAY
  136.            | FFESYMBOL_attrsDUMMY
  137.            | FFESYMBOL_attrsEXTERNAL
  138.            | FFESYMBOL_attrsSFARG
  139.            | FFESYMBOL_attrsTYPE)));
  140.  
  141.   nkd = skd;
  142.   nwh = swh;
  143.  
  144.   /* Figure out what kind of object we've got based on previous declarations
  145.      of or references to the object. */
  146.  
  147.   if (sa & FFESYMBOL_attrsEXTERNAL)
  148.     {
  149.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  150.                | FFESYMBOL_attrsDUMMY
  151.                | FFESYMBOL_attrsEXTERNAL
  152.                | FFESYMBOL_attrsTYPE)));
  153.  
  154.       if (sa & FFESYMBOL_attrsTYPE)
  155.     nwh = FFEINFO_whereGLOBAL;
  156.       else
  157.     /* Not TYPE. */
  158.     {
  159.       if (sa & FFESYMBOL_attrsDUMMY)
  160.         {            /* Not TYPE. */
  161.           ns = FFESYMBOL_stateUNCERTAIN;    /* FUNCTION/SUBROUTINE. */
  162.           needs_type = FALSE;    /* Don't assign type to SUBROUTINE! */
  163.         }
  164.       else if (sa & FFESYMBOL_attrsACTUALARG)
  165.         {            /* Not DUMMY or TYPE. */
  166.           ns = FFESYMBOL_stateUNCERTAIN;    /* FUNCTION/SUBROUTINE. */
  167.           needs_type = FALSE;    /* Don't assign type to SUBROUTINE! */
  168.         }
  169.       else
  170.         /* Not ACTUALARG, DUMMY, or TYPE. */
  171.         {            /* This is an assumption, essentially. */
  172.           nkd = FFEINFO_kindBLOCKDATA;
  173.           nwh = FFEINFO_whereGLOBAL;
  174.           needs_type = FALSE;
  175.         }
  176.     }
  177.     }
  178.   else if (sa & FFESYMBOL_attrsDUMMY)
  179.     {
  180.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  181.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  182.                | FFESYMBOL_attrsEXTERNAL
  183.                | FFESYMBOL_attrsTYPE)));
  184.  
  185.       /* Honestly, this appears to be a guess.  I can't find anyplace in the
  186.          standard that makes clear whether this unreferenced dummy argument
  187.          is an ENTITY or a FUNCTION.  And yet, for the f2c interface, picking
  188.          one is critical for CHARACTER entities because it determines whether
  189.          to expect an additional argument specifying the length of an ENTITY
  190.          that is not expected (or needed) for a FUNCTION.  HOWEVER, F90 makes
  191.          this guess a correct one, and it does seem that the Section 18 Notes
  192.          in Appendix B of F77 make it clear the F77 standard at least
  193.          intended to make this guess correct as well, so this seems ok.  */
  194.  
  195.       nkd = FFEINFO_kindENTITY;
  196.     }
  197.   else if (sa & FFESYMBOL_attrsARRAY)
  198.     {
  199.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  200.                | FFESYMBOL_attrsTYPE)));
  201.  
  202.       nwh = FFEINFO_whereLOCAL;
  203.     }
  204.   else if (sa & FFESYMBOL_attrsSFARG)
  205.     {
  206.       assert (!(sa & ~(FFESYMBOL_attrsSFARG
  207.                | FFESYMBOL_attrsTYPE)));
  208.  
  209.       nwh = FFEINFO_whereLOCAL;
  210.     }
  211.   else if (sa & FFESYMBOL_attrsTYPE)
  212.     {
  213.       assert (!(sa & (FFESYMBOL_attrsARRAY
  214.               | FFESYMBOL_attrsDUMMY
  215.               | FFESYMBOL_attrsEXTERNAL
  216.               | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  217.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  218.                | FFESYMBOL_attrsARRAY
  219.                | FFESYMBOL_attrsDUMMY
  220.                | FFESYMBOL_attrsEXTERNAL
  221.                | FFESYMBOL_attrsSFARG
  222.                | FFESYMBOL_attrsTYPE)));
  223.  
  224.       if (sa & FFESYMBOL_attrsANYLEN)
  225.     {            /* Can't touch this. */
  226.       ffesymbol_signal_change (s);
  227.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  228.       ffesymbol_resolve_intrin (s);
  229.       s = ffecom_sym_learned (s);
  230.       ffestorag_end_layout (s);
  231.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  232.       return s;
  233.     }
  234.  
  235.       nkd = FFEINFO_kindENTITY;
  236.       nwh = FFEINFO_whereLOCAL;
  237.     }
  238.   else
  239.     assert ("unexpected attribute set" == NULL);
  240.  
  241.   /* Now see what we've got for a new object: NONE means a new error cropped
  242.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  243.      update the object (symbol) and continue on. */
  244.  
  245.   if (na == FFESYMBOL_attrsetNONE)
  246.     ffesymbol_error (s, ffesta_tokens[0]);
  247.   else if (!(na & FFESYMBOL_attrsANY))
  248.     {
  249.       ffesymbol_signal_change (s);
  250.       ffesymbol_set_attrs (s, na);    /* Establish new info. */
  251.       ffesymbol_set_state (s, ns);
  252.       ffesymbol_set_info (s,
  253.               ffeinfo_new (ffesymbol_basictype (s),
  254.                        ffesymbol_kindtype (s),
  255.                        ffesymbol_rank (s),
  256.                        nkd,
  257.                        nwh,
  258.                        ffesymbol_size (s)));
  259.       if (needs_type && !ffeimplic_establish_symbol (s))
  260.     ffesymbol_error (s, ffesta_tokens[0]);
  261.       else
  262.     ffesymbol_resolve_intrin (s);
  263.       s = ffecom_sym_learned (s);
  264.       ffestorag_end_layout (s);
  265.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  266.     }
  267.  
  268.   return s;
  269. }
  270.  
  271. /* ffestu_sym_exec_transition -- Update symbol just before first exec stmt
  272.  
  273.    ffesymbol s;
  274.    ffestu_sym_exec_transition(s);  */
  275.  
  276. ffesymbol
  277. ffestu_sym_exec_transition (ffesymbol s)
  278. {
  279.   ffeinfoKind skd;
  280.   ffeinfoWhere swh;
  281.   ffeinfoKind nkd;
  282.   ffeinfoWhere nwh;
  283.   ffesymbolAttrs sa;
  284.   ffesymbolAttrs na;
  285.   ffesymbolState ss;
  286.   ffesymbolState ns;
  287.   ffeintrinGen gen;
  288.   ffeintrinSpec spec;
  289.   ffeintrinImp imp;
  290.   bool needs_type = TRUE;    /* Implicit type assignment might be
  291.                    necessary. */
  292.   bool resolve_intrin = TRUE;    /* Might need to resolve intrinsic. */
  293.  
  294.   assert (s != NULL);
  295.  
  296.   sa = ffesymbol_attrs (s);
  297.   skd = ffesymbol_kind (s);
  298.   swh = ffesymbol_where (s);
  299.   ss = ffesymbol_state (s);
  300.  
  301.   switch (ss)
  302.     {
  303.     case FFESYMBOL_stateNONE:
  304.       return s;            /* Assume caller will handle it. */
  305.  
  306.     case FFESYMBOL_stateSEEN:
  307.       break;
  308.  
  309.     case FFESYMBOL_stateUNCERTAIN:
  310.       ffestorag_exec_layout (s);
  311.       return s;            /* Already processed this one, or not
  312.                    necessary. */
  313.  
  314.     case FFESYMBOL_stateUNDERSTOOD:
  315.       if (skd == FFEINFO_kindNAMELIST)
  316.     {
  317.       ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
  318.       ffestu_list_exec_transition_ (ffesymbol_namelist (s));
  319.     }
  320.       else if ((swh == FFEINFO_whereLOCAL)
  321.            && ((skd == FFEINFO_kindFUNCTION)
  322.            || (skd == FFEINFO_kindSUBROUTINE)))
  323.     {
  324.       ffestu_dummies_transition_ (ffecom_sym_exec_transition,
  325.                       ffesymbol_dummyargs (s));
  326.       if ((skd == FFEINFO_kindFUNCTION)
  327.           && !ffeimplic_establish_symbol (s))
  328.         ffesymbol_error (s, ffesta_tokens[0]);
  329.     }
  330.  
  331.       ffestorag_exec_layout (s);
  332.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  333.       return s;
  334.  
  335.     default:
  336.       assert ("bad status" == NULL);
  337.       return s;
  338.     }
  339.  
  340.   ns = FFESYMBOL_stateUNDERSTOOD;    /* Only a few UNCERTAIN exceptions. */
  341.  
  342.   na = sa;
  343.   nkd = skd;
  344.   nwh = swh;
  345.  
  346.   assert (!(sa & FFESYMBOL_attrsANY));
  347.  
  348.   if (sa & FFESYMBOL_attrsCOMMON)
  349.     {
  350.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
  351.                | FFESYMBOL_attrsARRAY
  352.                | FFESYMBOL_attrsCOMMON
  353.                | FFESYMBOL_attrsEQUIV
  354.                | FFESYMBOL_attrsINIT
  355.                | FFESYMBOL_attrsNAMELIST
  356.                | FFESYMBOL_attrsSFARG
  357.                | FFESYMBOL_attrsTYPE)));
  358.  
  359.       nkd = FFEINFO_kindENTITY;
  360.       nwh = FFEINFO_whereCOMMON;
  361.     }
  362.   else if (sa & FFESYMBOL_attrsRESULT)
  363.     {                /* Result variable for function. */
  364.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  365.                | FFESYMBOL_attrsRESULT
  366.                | FFESYMBOL_attrsSFARG
  367.                | FFESYMBOL_attrsTYPE)));
  368.  
  369.       nkd = FFEINFO_kindENTITY;
  370.       nwh = FFEINFO_whereRESULT;
  371.     }
  372.   else if (sa & FFESYMBOL_attrsSFUNC)
  373.     {                /* Statement function. */
  374.       assert (!(sa & ~(FFESYMBOL_attrsSFUNC
  375.                | FFESYMBOL_attrsTYPE)));
  376.  
  377.       nkd = FFEINFO_kindFUNCTION;
  378.       nwh = FFEINFO_whereCONSTANT;
  379.     }
  380.   else if (sa & FFESYMBOL_attrsEXTERNAL)
  381.     {
  382.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  383.                | FFESYMBOL_attrsEXTERNAL
  384.                | FFESYMBOL_attrsTYPE)));
  385.  
  386.       if (sa & FFESYMBOL_attrsTYPE)
  387.     {
  388.       nkd = FFEINFO_kindFUNCTION;
  389.  
  390.       if (sa & FFESYMBOL_attrsDUMMY)
  391.         nwh = FFEINFO_whereDUMMY;
  392.       else
  393.         {
  394.           if (ffesta_is_entry_valid)
  395.         {
  396.           nwh = FFEINFO_whereNONE;    /* DUMMY, GLOBAL. */
  397.           ns = FFESYMBOL_stateUNCERTAIN;
  398.         }
  399.           else
  400.         nwh = FFEINFO_whereGLOBAL;
  401.         }
  402.     }
  403.       else
  404.     /* No TYPE. */
  405.     {
  406.       nkd = FFEINFO_kindNONE;    /* FUNCTION, SUBROUTINE, BLOCKDATA. */
  407.       needs_type = FALSE;    /* Only gets type if FUNCTION. */
  408.       ns = FFESYMBOL_stateUNCERTAIN;
  409.  
  410.       if (sa & FFESYMBOL_attrsDUMMY)
  411.         nwh = FFEINFO_whereDUMMY;    /* Not BLOCKDATA. */
  412.       else
  413.         {
  414.           if (ffesta_is_entry_valid)
  415.         nwh = FFEINFO_whereNONE;    /* DUMMY, GLOBAL. */
  416.           else
  417.         nwh = FFEINFO_whereGLOBAL;
  418.         }
  419.     }
  420.     }
  421.   else if (sa & FFESYMBOL_attrsDUMMY)
  422.     {
  423.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  424.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE    /* Possible. */
  425.                | FFESYMBOL_attrsADJUSTS    /* Possible. */
  426.                | FFESYMBOL_attrsANYLEN    /* Possible. */
  427.                | FFESYMBOL_attrsANYSIZE    /* Possible. */
  428.                | FFESYMBOL_attrsARRAY    /* Possible. */
  429.                | FFESYMBOL_attrsDUMMY    /* Have it. */
  430.                | FFESYMBOL_attrsEXTERNAL
  431.                | FFESYMBOL_attrsSFARG    /* Possible. */
  432.                | FFESYMBOL_attrsTYPE)));    /* Possible. */
  433.  
  434.       nwh = FFEINFO_whereDUMMY;
  435.  
  436.       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
  437.     ffestu_symter_exec_transition_ (ffesymbol_dims (s));
  438.       if (sa & (FFESYMBOL_attrsADJUSTS
  439.         | FFESYMBOL_attrsARRAY
  440.         | FFESYMBOL_attrsANYLEN
  441.         | FFESYMBOL_attrsNAMELIST
  442.         | FFESYMBOL_attrsSFARG))
  443.     nkd = FFEINFO_kindENTITY;
  444.       else
  445.     {
  446.       if (!(sa & FFESYMBOL_attrsTYPE))
  447.         needs_type = FALSE;    /* Don't assign type to SUBROUTINE! */
  448.       nkd = FFEINFO_kindNONE;    /* ENTITY, FUNCTION, SUBROUTINE. */
  449.       ns = FFESYMBOL_stateUNCERTAIN;
  450.     }
  451.     }
  452.   else if (sa & FFESYMBOL_attrsADJUSTS)
  453.     {                /* Must be DUMMY or COMMON at some point. */
  454.       assert (!(sa & (FFESYMBOL_attrsCOMMON
  455.               | FFESYMBOL_attrsDUMMY)));    /* Handled above. */
  456.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS    /* Have it. */
  457.                | FFESYMBOL_attrsCOMMON
  458.                | FFESYMBOL_attrsDUMMY
  459.                | FFESYMBOL_attrsEQUIV    /* Possible. */
  460.                | FFESYMBOL_attrsINIT    /* Possible. */
  461.                | FFESYMBOL_attrsNAMELIST    /* Possible. */
  462.                | FFESYMBOL_attrsSFARG    /* Possible. */
  463.                | FFESYMBOL_attrsTYPE)));    /* Possible. */
  464.  
  465.       nkd = FFEINFO_kindENTITY;
  466.  
  467.       if (sa & FFESYMBOL_attrsEQUIV)
  468.     {
  469.       if ((ffesymbol_equiv (s) == NULL)
  470.           || (ffeequiv_common (ffesymbol_equiv (s)) == NULL))
  471.         na = FFESYMBOL_attrsetNONE;    /* Not equiv'd into COMMON. */
  472.       else
  473.         nwh = FFEINFO_whereCOMMON;
  474.     }
  475.       else if (!ffesta_is_entry_valid
  476.            || (sa & (FFESYMBOL_attrsINIT
  477.              | FFESYMBOL_attrsNAMELIST)))
  478.     na = FFESYMBOL_attrsetNONE;
  479.       else
  480.     nwh = FFEINFO_whereDUMMY;
  481.     }
  482.   else if (sa & FFESYMBOL_attrsSAVE)
  483.     {
  484.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  485.                | FFESYMBOL_attrsEQUIV
  486.                | FFESYMBOL_attrsINIT
  487.                | FFESYMBOL_attrsNAMELIST
  488.                | FFESYMBOL_attrsSAVE
  489.                | FFESYMBOL_attrsSFARG
  490.                | FFESYMBOL_attrsTYPE)));
  491.  
  492.       nkd = FFEINFO_kindENTITY;
  493.       nwh = FFEINFO_whereLOCAL;
  494.     }
  495.   else if (sa & FFESYMBOL_attrsEQUIV)
  496.     {
  497.       assert (!(sa & FFESYMBOL_attrsCOMMON));    /* Handled above. */
  498.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS    /* Possible. */
  499.                | FFESYMBOL_attrsARRAY    /* Possible. */
  500.                | FFESYMBOL_attrsCOMMON
  501.                | FFESYMBOL_attrsEQUIV    /* Have it. */
  502.                | FFESYMBOL_attrsINIT    /* Possible. */
  503.                | FFESYMBOL_attrsNAMELIST    /* Possible. */
  504.                | FFESYMBOL_attrsSAVE    /* Possible. */
  505.                | FFESYMBOL_attrsSFARG    /* Possible. */
  506.                | FFESYMBOL_attrsTYPE)));    /* Possible. */
  507.  
  508.       nkd = FFEINFO_kindENTITY;
  509.       nwh = ffestu_equiv_ (s);
  510.     }
  511.   else if (sa & FFESYMBOL_attrsNAMELIST)
  512.     {
  513.       assert (!(sa & (FFESYMBOL_attrsADJUSTS
  514.               | FFESYMBOL_attrsCOMMON
  515.               | FFESYMBOL_attrsEQUIV
  516.               | FFESYMBOL_attrsSAVE)));    /* Handled above. */
  517.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
  518.                | FFESYMBOL_attrsARRAY    /* Possible. */
  519.                | FFESYMBOL_attrsCOMMON
  520.                | FFESYMBOL_attrsEQUIV
  521.                | FFESYMBOL_attrsINIT    /* Possible. */
  522.                | FFESYMBOL_attrsNAMELIST    /* Have it. */
  523.                | FFESYMBOL_attrsSAVE
  524.                | FFESYMBOL_attrsSFARG    /* Possible. */
  525.                | FFESYMBOL_attrsTYPE)));    /* Possible. */
  526.  
  527.       nkd = FFEINFO_kindENTITY;
  528.       nwh = FFEINFO_whereLOCAL;
  529.     }
  530.   else if (sa & FFESYMBOL_attrsINIT)
  531.     {
  532.       assert (!(sa & (FFESYMBOL_attrsADJUSTS
  533.               | FFESYMBOL_attrsCOMMON
  534.               | FFESYMBOL_attrsEQUIV
  535.               | FFESYMBOL_attrsNAMELIST
  536.               | FFESYMBOL_attrsSAVE)));    /* Handled above. */
  537.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
  538.                | FFESYMBOL_attrsARRAY    /* Possible. */
  539.                | FFESYMBOL_attrsCOMMON
  540.                | FFESYMBOL_attrsEQUIV
  541.                | FFESYMBOL_attrsINIT    /* Have it. */
  542.                | FFESYMBOL_attrsNAMELIST
  543.                | FFESYMBOL_attrsSAVE
  544.                | FFESYMBOL_attrsSFARG    /* Possible. */
  545.                | FFESYMBOL_attrsTYPE)));    /* Possible. */
  546.  
  547.       nkd = FFEINFO_kindENTITY;
  548.       nwh = FFEINFO_whereLOCAL;
  549.     }
  550.   else if (sa & FFESYMBOL_attrsSFARG)
  551.     {
  552.       assert (!(sa & (FFESYMBOL_attrsADJUSTS
  553.               | FFESYMBOL_attrsCOMMON
  554.               | FFESYMBOL_attrsDUMMY
  555.               | FFESYMBOL_attrsEQUIV
  556.               | FFESYMBOL_attrsINIT
  557.               | FFESYMBOL_attrsNAMELIST
  558.               | FFESYMBOL_attrsRESULT
  559.               | FFESYMBOL_attrsSAVE)));    /* Handled above. */
  560.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
  561.                | FFESYMBOL_attrsCOMMON
  562.                | FFESYMBOL_attrsDUMMY
  563.                | FFESYMBOL_attrsEQUIV
  564.                | FFESYMBOL_attrsINIT
  565.                | FFESYMBOL_attrsNAMELIST
  566.                | FFESYMBOL_attrsRESULT
  567.                | FFESYMBOL_attrsSAVE
  568.                | FFESYMBOL_attrsSFARG    /* Have it. */
  569.                | FFESYMBOL_attrsTYPE)));    /* Possible. */
  570.  
  571.       nkd = FFEINFO_kindENTITY;
  572.  
  573.       if (ffesta_is_entry_valid)
  574.     {
  575.       nwh = FFEINFO_whereNONE;    /* DUMMY, LOCAL. */
  576.       ns = FFESYMBOL_stateUNCERTAIN;
  577.     }
  578.       else
  579.     nwh = FFEINFO_whereLOCAL;
  580.     }
  581.   else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
  582.     {
  583.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
  584.                | FFESYMBOL_attrsANYLEN
  585.                | FFESYMBOL_attrsANYSIZE
  586.                | FFESYMBOL_attrsARRAY
  587.                | FFESYMBOL_attrsTYPE)));
  588.  
  589.       if (sa & FFESYMBOL_attrsADJUSTABLE)
  590.     ffestu_symter_exec_transition_ (ffesymbol_dims (s));
  591.       nkd = FFEINFO_kindENTITY;
  592.       nwh = FFEINFO_whereDUMMY;
  593.     }
  594.   else if (sa & FFESYMBOL_attrsARRAY)
  595.     {
  596.       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
  597.               | FFESYMBOL_attrsANYSIZE
  598.               | FFESYMBOL_attrsCOMMON
  599.               | FFESYMBOL_attrsDUMMY
  600.               | FFESYMBOL_attrsEQUIV
  601.               | FFESYMBOL_attrsINIT
  602.               | FFESYMBOL_attrsNAMELIST
  603.               | FFESYMBOL_attrsSAVE)));    /* Handled above. */
  604.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
  605.                | FFESYMBOL_attrsANYLEN    /* Possible. */
  606.                | FFESYMBOL_attrsANYSIZE
  607.                | FFESYMBOL_attrsARRAY    /* Have it. */
  608.                | FFESYMBOL_attrsCOMMON
  609.                | FFESYMBOL_attrsDUMMY
  610.                | FFESYMBOL_attrsEQUIV
  611.                | FFESYMBOL_attrsINIT
  612.                | FFESYMBOL_attrsNAMELIST
  613.                | FFESYMBOL_attrsSAVE
  614.                | FFESYMBOL_attrsTYPE)));    /* Possible. */
  615.  
  616.       nkd = FFEINFO_kindENTITY;
  617.  
  618.       if (sa & FFESYMBOL_attrsANYLEN)
  619.     {
  620.       assert (ffesta_is_entry_valid);    /* Already diagnosed. */
  621.       nwh = FFEINFO_whereDUMMY;
  622.     }
  623.       else
  624.     {
  625.       if (ffesta_is_entry_valid)
  626.         {
  627.           nwh = FFEINFO_whereNONE;    /* DUMMY, LOCAL. */
  628.           ns = FFESYMBOL_stateUNCERTAIN;
  629.         }
  630.       else
  631.         nwh = FFEINFO_whereLOCAL;
  632.     }
  633.     }
  634.   else if (sa & FFESYMBOL_attrsANYLEN)
  635.     {
  636.       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
  637.               | FFESYMBOL_attrsANYSIZE
  638.               | FFESYMBOL_attrsARRAY
  639.               | FFESYMBOL_attrsDUMMY
  640.               | FFESYMBOL_attrsRESULT)));    /* Handled above. */
  641.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
  642.                | FFESYMBOL_attrsANYLEN    /* Have it. */
  643.                | FFESYMBOL_attrsANYSIZE
  644.                | FFESYMBOL_attrsARRAY
  645.                | FFESYMBOL_attrsDUMMY
  646.                | FFESYMBOL_attrsRESULT
  647.                | FFESYMBOL_attrsTYPE)));    /* Have it too. */
  648.  
  649.       if (ffesta_is_entry_valid)
  650.     {
  651.       nkd = FFEINFO_kindNONE;    /* ENTITY, FUNCTION. */
  652.       nwh = FFEINFO_whereNONE;    /* DUMMY, INTRINSIC, RESULT. */
  653.       ns = FFESYMBOL_stateUNCERTAIN;
  654.       resolve_intrin = FALSE;
  655.     }
  656.       else if (ffeintrin_is_intrinsic (ffesymbol_text (s), NULL, FALSE,
  657.                        &gen, &spec, &imp, &nkd))
  658.     {
  659.       ffesymbol_signal_change (s);
  660.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  661.       ffesymbol_set_generic (s, gen);
  662.       ffesymbol_set_specific (s, spec);
  663.       ffesymbol_set_implementation (s, imp);
  664.       ffesymbol_set_info (s,
  665.                   ffeinfo_new (FFEINFO_basictypeNONE,
  666.                        FFEINFO_kindtypeNONE,
  667.                        0,
  668.                        nkd,
  669.                        FFEINFO_whereINTRINSIC,
  670.                        FFETARGET_charactersizeNONE));
  671.       ffesymbol_resolve_intrin (s);
  672.       ffestorag_exec_layout (s);
  673.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  674.       return s;
  675.     }
  676.       else
  677.     {            /* SPECIAL: can't have CHAR*(*) var in
  678.                    PROGRAM/BLOCKDATA, unless it isn't
  679.                    referenced anywhere in the code. */
  680.       ffesymbol_signal_change (s);    /* Can't touch this. */
  681.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  682.       ffesymbol_resolve_intrin (s);
  683.       ffestorag_exec_layout (s);
  684.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  685.       return s;
  686.     }
  687.     }
  688.   else if (sa & FFESYMBOL_attrsTYPE)
  689.     {
  690.       assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
  691.               | FFESYMBOL_attrsADJUSTS
  692.               | FFESYMBOL_attrsANYLEN
  693.               | FFESYMBOL_attrsANYSIZE
  694.               | FFESYMBOL_attrsARRAY
  695.               | FFESYMBOL_attrsCOMMON
  696.               | FFESYMBOL_attrsDUMMY
  697.               | FFESYMBOL_attrsEQUIV
  698.               | FFESYMBOL_attrsEXTERNAL
  699.               | FFESYMBOL_attrsINIT
  700.               | FFESYMBOL_attrsNAMELIST
  701.               | FFESYMBOL_attrsRESULT
  702.               | FFESYMBOL_attrsSAVE
  703.               | FFESYMBOL_attrsSFARG
  704.               | FFESYMBOL_attrsSFUNC)));
  705.       assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
  706.                | FFESYMBOL_attrsADJUSTS
  707.                | FFESYMBOL_attrsANYLEN
  708.                | FFESYMBOL_attrsANYSIZE
  709.                | FFESYMBOL_attrsARRAY
  710.                | FFESYMBOL_attrsCOMMON
  711.                | FFESYMBOL_attrsDUMMY
  712.                | FFESYMBOL_attrsEQUIV
  713.                | FFESYMBOL_attrsEXTERNAL
  714.                | FFESYMBOL_attrsINIT
  715.                | FFESYMBOL_attrsINTRINSIC    /* UNDERSTOOD. */
  716.                | FFESYMBOL_attrsNAMELIST
  717.                | FFESYMBOL_attrsRESULT
  718.                | FFESYMBOL_attrsSAVE
  719.                | FFESYMBOL_attrsSFARG
  720.                | FFESYMBOL_attrsSFUNC
  721.                | FFESYMBOL_attrsTYPE)));    /* Have it. */
  722.  
  723.       nkd = FFEINFO_kindNONE;    /* ENTITY, FUNCTION. */
  724.       nwh = FFEINFO_whereNONE;    /* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */
  725.       ns = FFESYMBOL_stateUNCERTAIN;
  726.       resolve_intrin = FALSE;
  727.     }
  728.   else if (sa & (FFESYMBOL_attrsCBLOCK | FFESYMBOL_attrsSAVECBLOCK))
  729.     {                /* COMMON block. */
  730.       assert (!(sa & ~(FFESYMBOL_attrsCBLOCK
  731.                | FFESYMBOL_attrsSAVECBLOCK)));
  732.  
  733.       if (sa & FFESYMBOL_attrsCBLOCK)
  734.     ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
  735.       else
  736.     ffesymbol_set_commonlist (s, NULL);
  737.       ffestu_list_exec_transition_ (ffesymbol_commonlist (s));
  738.       nkd = FFEINFO_kindCOMMON;
  739.       nwh = FFEINFO_whereLOCAL;
  740.       needs_type = FALSE;
  741.     }
  742.   else
  743.     {                /* First seen in stmt func definition. */
  744.       assert (sa == FFESYMBOL_attrsetNONE);
  745.       assert ("Why are we here again?" == NULL);    /* ~~~~~ */
  746.  
  747.       nkd = FFEINFO_kindNONE;    /* ENTITY, FUNCTION. */
  748.       nwh = FFEINFO_whereNONE;    /* DUMMY, GLOBAL, LOCAL. */
  749.       ns = FFESYMBOL_stateUNCERTAIN;    /* Will get repromoted by caller. */
  750.       needs_type = FALSE;
  751.     }
  752.  
  753.   if (na == FFESYMBOL_attrsetNONE)
  754.     ffesymbol_error (s, ffesta_tokens[0]);
  755.   else if (!(na & FFESYMBOL_attrsANY))
  756.     {
  757.       ffesymbol_signal_change (s);
  758.       ffesymbol_set_attrs (s, na);    /* Establish new info. */
  759.       ffesymbol_set_state (s, ns);
  760.       if ((ffesymbol_common (s) == NULL)
  761.       && (ffesymbol_equiv (s) != NULL))
  762.     ffesymbol_set_common (s, ffeequiv_common (ffesymbol_equiv (s)));
  763.       ffesymbol_set_info (s,
  764.               ffeinfo_new (ffesymbol_basictype (s),
  765.                        ffesymbol_kindtype (s),
  766.                        ffesymbol_rank (s),
  767.                        nkd,
  768.                        nwh,
  769.                        ffesymbol_size (s)));
  770.       if (needs_type && !ffeimplic_establish_symbol (s))
  771.     ffesymbol_error (s, ffesta_tokens[0]);
  772.       else if (resolve_intrin)
  773.     ffesymbol_resolve_intrin (s);
  774.       ffestorag_exec_layout (s);
  775.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  776.     }
  777.  
  778.   return s;
  779. }
  780.  
  781. /* ffestu_list_exec_transition_ -- Update SYMTERs in ITEM list w/in symbol
  782.  
  783.    ffebld list;
  784.    ffestu_list_exec_transition_(list);
  785.  
  786.    list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and
  787.    other things, too, but we'll ignore the known ones).     For each SYMTER,
  788.    we run sym_exec_transition_ on the corresponding ffesymbol (a recursive
  789.    call, since that's the function that's calling us) to update it's
  790.    information.     Then we copy that information into the SYMTER.
  791.  
  792.    Make sure we don't get called recursively ourselves!     */
  793.  
  794. static void
  795. ffestu_list_exec_transition_ (ffebld list)
  796. {
  797.   static in_progress = FALSE;
  798.   ffebld item;
  799.   ffesymbol symbol;
  800.  
  801.   assert (!in_progress);
  802.   in_progress = TRUE;
  803.  
  804.   for (; list != NULL; list = ffebld_trail (list))
  805.     {
  806.       if ((item = ffebld_head (list)) == NULL)
  807.     continue;        /* Try next item. */
  808.  
  809.       switch (ffebld_op (item))
  810.     {
  811.     case FFEBLD_opSTAR:
  812.       break;
  813.  
  814.     case FFEBLD_opSYMTER:
  815.       symbol = ffebld_symter (item);
  816.       if (symbol == NULL)
  817.         break;        /* Detached from stmt func dummy list. */
  818.       symbol = ffecom_sym_exec_transition (symbol);
  819.       assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE);
  820.       assert (ffesymbol_where (symbol) != FFEINFO_whereNONE);
  821.       ffebld_set_info (item, ffesymbol_info (symbol));
  822.       break;
  823.  
  824.     default:
  825.       assert ("Unexpected item on list" == NULL);
  826.       break;
  827.     }
  828.     }
  829.  
  830.   in_progress = FALSE;
  831. }
  832.  
  833. /* ffestu_symter_exec_transition_ -- Update SYMTERs in expr w/in symbol
  834.  
  835.    ffebld expr;
  836.    ffestu_symter_exec_transition_(expr);
  837.  
  838.    Any SYMTER in expr's tree with whereNONE gets updated to the
  839.    (recursively transitioned) sym it identifies (DUMMY or COMMON).
  840.  
  841.    Make sure we don't get called recursively ourselves!     */
  842.  
  843. static void
  844. ffestu_symter_exec_transition_ (ffebld expr)
  845. {
  846.   ffesymbol symbol;
  847.  
  848.   /* Label used for tail recursion (reset expr and go here instead of calling
  849.      self). */
  850.  
  851. tail:                /* :::::::::::::::::::: */
  852.  
  853.   if (expr == NULL)
  854.     return;
  855.  
  856.   switch (ffebld_op (expr))
  857.     {
  858.     case FFEBLD_opITEM:
  859.       while (ffebld_trail (expr) != NULL)
  860.     {
  861.       ffestu_symter_exec_transition_ (ffebld_head (expr));
  862.       expr = ffebld_trail (expr);
  863.     }
  864.       expr = ffebld_head (expr);
  865.       goto tail;        /* :::::::::::::::::::: */
  866.  
  867.     default:
  868.       break;
  869.     }
  870.  
  871.   switch (ffebld_arity (expr))
  872.     {
  873.     case 2:
  874.       ffestu_symter_exec_transition_ (ffebld_left (expr));
  875.       expr = ffebld_right (expr);
  876.       goto tail;        /* :::::::::::::::::::: */
  877.  
  878.     case 1:
  879.       expr = ffebld_left (expr);
  880.       goto tail;        /* :::::::::::::::::::: */
  881.  
  882.     default:
  883.       switch (ffebld_op (expr))
  884.     {
  885.     case FFEBLD_opSYMTER:
  886.       if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereNONE)
  887.         break;        /* Already have needed info. */
  888.       symbol = ffecom_sym_exec_transition (ffebld_symter (expr));
  889.       ffebld_set_info (expr, ffesymbol_info (symbol));
  890.       break;
  891.  
  892.     default:
  893.       break;
  894.     }
  895.       break;
  896.     }
  897.  
  898.   return;
  899. }
  900.  
  901. /* ffestu_dummies_transition_ -- Update SYMTERs in ITEM list w/in entry
  902.  
  903.    ffebld list;
  904.    ffesymbol symfunc(ffesymbol s);
  905.    if (ffestu_dummies_transition_(symfunc,list))
  906.        // One or more items are still UNCERTAIN.
  907.  
  908.    list contains an FFEBLD_opITEM list of SYMTERs (possibly STARs and
  909.    other things, too, but we'll ignore the known ones).     For each SYMTER,
  910.    we run symfunc on the corresponding ffesymbol (a recursive
  911.    call, since that's the function that's calling us) to update it's
  912.    information.     Then we copy that information into the SYMTER.
  913.  
  914.    Return TRUE if any of the SYMTER's has incomplete information.
  915.  
  916.    Make sure we don't get called recursively ourselves!     */
  917.  
  918. static bool
  919. ffestu_dummies_transition_ (ffesymbol (*symfunc) (), ffebld list)
  920. {
  921.   static in_progress = FALSE;
  922.   ffebld item;
  923.   ffesymbol symbol;
  924.   bool uncertain = FALSE;
  925.  
  926.   assert (!in_progress);
  927.   in_progress = TRUE;
  928.  
  929.   for (; list != NULL; list = ffebld_trail (list))
  930.     {
  931.       if ((item = ffebld_head (list)) == NULL)
  932.     continue;        /* Try next item. */
  933.  
  934.       switch (ffebld_op (item))
  935.     {
  936.     case FFEBLD_opSTAR:
  937.       break;
  938.  
  939.     case FFEBLD_opSYMTER:
  940.       symbol = ffebld_symter (item);
  941.       if (symbol == NULL)
  942.         break;        /* Detached from stmt func dummy list. */
  943.       symbol = (*symfunc) (symbol);
  944.       if (ffesymbol_state (symbol) == FFESYMBOL_stateUNCERTAIN)
  945.         uncertain = TRUE;
  946.       else
  947.         {
  948.           assert (ffesymbol_kind (symbol) != FFEINFO_kindNONE);
  949.           assert (ffesymbol_where (symbol) != FFEINFO_whereNONE);
  950.         }
  951.       ffebld_set_info (item, ffesymbol_info (symbol));
  952.       break;
  953.  
  954.     default:
  955.       assert ("Unexpected item on list" == NULL);
  956.       break;
  957.     }
  958.     }
  959.  
  960.   in_progress = FALSE;
  961.  
  962.   return uncertain;
  963. }
  964.