stu.c

gcc-2.95.3 Linux下最常用的C编译器

/* stu.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995-1997 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

*/

/* Include files. */

#include "proj.h"
#include "bld.h"
#include "com.h"
#include "equiv.h"
#include "global.h"
#include "info.h"
#include "implic.h"
#include "intrin.h"
#include "stu.h"
#include "storag.h"
#include "sta.h"
#include "symbol.h"
#include "target.h"

/* Externals defined here. */


/* Simple definitions and enumerations. */


/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


/* Static objects accessed by functions in this module. */


/* Static functions (internal). */

static void ffestu_list_exec_transition_ (ffebld list);
static bool ffestu_symter_end_transition_ (ffebld expr);
static bool ffestu_symter_exec_transition_ (ffebld expr);
static bool ffestu_dummies_transition_ (ffesymbol (*symfunc) (ffesymbol),
					ffebld list);

/* Internal macros. */

#define ffestu_equiv_(s) (((ffesymbol_equiv (s) == NULL)		      \
  || (ffeequiv_common (ffesymbol_equiv (s)) == NULL)) ? FFEINFO_whereLOCAL    \
  : FFEINFO_whereCOMMON)

/* Update symbol info just before end of unit.  */

ffesymbol
ffestu_sym_end_transition (ffesymbol s)
{
  ffeinfoKind skd;
  ffeinfoWhere swh;
  ffeinfoKind nkd;
  ffeinfoWhere nwh;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffesymbolState ss;
  ffesymbolState ns;
  bool needs_type = TRUE;	/* Implicit type assignment might be
				   necessary. */

  assert (s != NULL);
  ss = ffesymbol_state (s);
  sa = ffesymbol_attrs (s);
  skd = ffesymbol_kind (s);
  swh = ffesymbol_where (s);

  switch (ss)
    {
    case FFESYMBOL_stateUNCERTAIN:
      if ((swh == FFEINFO_whereDUMMY)
	  && (ffesymbol_numentries (s) == 0))
	{			/* Not actually in any dummy list! */
	  ffesymbol_error (s, ffesta_tokens[0]);
	  return s;
	}
      else if (((swh == FFEINFO_whereLOCAL)
		|| (swh == FFEINFO_whereNONE))
	       && (skd == FFEINFO_kindENTITY)
	       && ffestu_symter_end_transition_ (ffesymbol_dims (s)))
	{			/* Bad dimension expressions. */
	  ffesymbol_error (s, NULL);
	  return s;
	}
      break;

    case FFESYMBOL_stateUNDERSTOOD:
      if ((swh == FFEINFO_whereLOCAL)
	  && ((skd == FFEINFO_kindFUNCTION)
	      || (skd == FFEINFO_kindSUBROUTINE)))
	{
	  int n_args;
	  ffebld list;
	  ffebld item;
	  ffeglobalArgSummary as;
	  ffeinfoBasictype bt;
	  ffeinfoKindtype kt;
	  bool array;
	  const char *name = NULL;

	  ffestu_dummies_transition_ (ffecom_sym_end_transition,
				      ffesymbol_dummyargs (s));

	  n_args = ffebld_list_length (ffesymbol_dummyargs (s));
	  ffeglobal_proc_def_nargs (s, n_args);
	  for (list = ffesymbol_dummyargs (s), n_args = 0;
	       list != NULL;
	       list = ffebld_trail (list), ++n_args)
	    {
	      item = ffebld_head (list);
	      array = FALSE;
	      if (item != NULL)
		{
		  bt = ffeinfo_basictype (ffebld_info (item));
		  kt = ffeinfo_kindtype (ffebld_info (item));
		  array = (ffeinfo_rank (ffebld_info (item)) > 0);
		  switch (ffebld_op (item))
		    {
		    case FFEBLD_opSTAR:
		      as = FFEGLOBAL_argsummaryALTRTN;
		      break;

		    case FFEBLD_opSYMTER:
		      name = ffesymbol_text (ffebld_symter (item));
		      as = FFEGLOBAL_argsummaryNONE;

		      switch (ffeinfo_kind (ffebld_info (item)))
			{
			case FFEINFO_kindFUNCTION:
			  as = FFEGLOBAL_argsummaryFUNC;
			  break;

			case FFEINFO_kindSUBROUTINE:
			  as = FFEGLOBAL_argsummarySUBR;
			  break;

			case FFEINFO_kindNONE:
			  as = FFEGLOBAL_argsummaryPROC;
			  break;

			default:
			  break;
			}

		      if (as != FFEGLOBAL_argsummaryNONE)
			break;

		      /* Fall through.  */
		    default:
		      if (bt == FFEINFO_basictypeCHARACTER)
			as = FFEGLOBAL_argsummaryDESCR;
		      else
			as = FFEGLOBAL_argsummaryREF;
		      break;
		    }
		}
	      else
		{
		  as = FFEGLOBAL_argsummaryNONE;
		  bt = FFEINFO_basictypeNONE;
		  kt = FFEINFO_kindtypeNONE;
		}
	      ffeglobal_proc_def_arg (s, n_args, name, as, bt, kt, array);
	    }
	}
      else if (swh == FFEINFO_whereDUMMY)
	{
	  if (ffesymbol_numentries (s) == 0)
	    {			/* Not actually in any dummy list! */
	      ffesymbol_error (s, ffesta_tokens[0]);
	      return s;
	    }
	  if (ffestu_symter_end_transition_ (ffesymbol_dims (s)))
	    {			/* Bad dimension expressions. */
	      ffesymbol_error (s, NULL);
	      return s;
	    }
	}
      else if ((swh == FFEINFO_whereLOCAL)
	       && ffestu_symter_end_transition_ (ffesymbol_dims (s)))
	{			/* Bad dimension expressions. */
	  ffesymbol_error (s, NULL);
	  return s;
	}

      ffestorag_end_layout (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
      return s;

    default:
      assert ("bad status" == NULL);
      return s;
    }

  ns = FFESYMBOL_stateUNDERSTOOD;
  na = sa = ffesymbol_attrs (s);

  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		   | FFESYMBOL_attrsADJUSTABLE
		   | FFESYMBOL_attrsANYLEN
		   | FFESYMBOL_attrsARRAY
		   | FFESYMBOL_attrsDUMMY
		   | FFESYMBOL_attrsEXTERNAL
		   | FFESYMBOL_attrsSFARG
		   | FFESYMBOL_attrsTYPE)));

  nkd = skd;
  nwh = swh;

  /* Figure out what kind of object we've got based on previous declarations
     of or references to the object. */

  if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsTYPE)
	nwh = FFEINFO_whereGLOBAL;
      else
	/* Not TYPE. */
	{
	  if (sa & FFESYMBOL_attrsDUMMY)
	    {			/* Not TYPE. */
	      ns = FFESYMBOL_stateUNCERTAIN;	/* FUNCTION/SUBROUTINE. */
	      needs_type = FALSE;	/* Don't assign type to SUBROUTINE! */
	    }
	  else if (sa & FFESYMBOL_attrsACTUALARG)
	    {			/* Not DUMMY or TYPE. */
	      ns = FFESYMBOL_stateUNCERTAIN;	/* FUNCTION/SUBROUTINE. */
	      needs_type = FALSE;	/* Don't assign type to SUBROUTINE! */
	    }
	  else
	    /* Not ACTUALARG, DUMMY, or TYPE. */
	    {			/* This is an assumption, essentially. */
	      nkd = FFEINFO_kindBLOCKDATA;
	      nwh = FFEINFO_whereGLOBAL;
	      needs_type = FALSE;
	    }
	}
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      /* Honestly, this appears to be a guess.  I can't find anyplace in the
	 standard that makes clear whether this unreferenced dummy argument
	 is an ENTITY or a FUNCTION.  And yet, for the f2c interface, picking
	 one is critical for CHARACTER entities because it determines whether
	 to expect an additional argument specifying the length of an ENTITY
	 that is not expected (or needed) for a FUNCTION.  HOWEVER, F90 makes
	 this guess a correct one, and it does seem that the Section 18 Notes
	 in Appendix B of F77 make it clear the F77 standard at least
	 intended to make this guess correct as well, so this seems ok.  */

      nkd = FFEINFO_kindENTITY;
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsTYPE)));

      if (ffestu_symter_end_transition_ (ffesymbol_dims (s)))
	{
	  ffesymbol_error (s, NULL);
	  return s;
	}

      if (sa & FFESYMBOL_attrsADJUSTABLE)
	{			/* Not actually in any dummy list! */
	  if (ffe_is_pedantic ()
	      && ffebad_start_msg ("Local adjustable symbol `%A' at %0",
				   FFEBAD_severityPEDANTIC))
	    {
	      ffebad_string (ffesymbol_text (s));
	      ffebad_here (0, ffesymbol_where_line (s),
			   ffesymbol_where_column (s));
	      ffebad_finish ();
	    }
	}
      nwh = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & ~(FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      nwh = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsTYPE
		       | FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG)));

      if (sa & FFESYMBOL_attrsANYLEN)
	{			/* Can't touch this. */
	  ffesymbol_signal_change (s);
	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
	  ffesymbol_resolve_intrin (s);
	  s = ffecom_sym_learned (s);
	  ffesymbol_reference (s, NULL, FALSE);
	  ffestorag_end_layout (s);
	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
	  return s;
	}

      nkd = FFEINFO_kindENTITY;
      nwh = FFEINFO_whereLOCAL;
    }
  else
    assert ("unexpected attribute set" == NULL);

  /* Now see what we've got for a new object: NONE means a new error cropped
     up; ANY means an old error to be ignored; otherwise, everything's ok,
     update the object (symbol) and continue on. */

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, ffesta_tokens[0]);
  else if (!(na & FFESYMBOL_attrsANY))
    {
      ffesymbol_signal_change (s);
      ffesymbol_set_attrs (s, na);	/* Establish new info. */
      ffesymbol_set_state (s, ns);
      ffesymbol_set_info (s,
			  ffeinfo_new (ffesymbol_basictype (s),
				       ffesymbol_kindtype (s),
				       ffesymbol_rank (s),
				       nkd,
				       nwh,
				       ffesymbol_size (s)));
      if (needs_type && !ffeimplic_establish_symbol (s))
	ffesymbol_error (s, ffesta_tokens[0]);
      else
	ffesymbol_resolve_intrin (s);
      s = ffecom_sym_learned (s);
      ffesymbol_reference (s, NULL, FALSE);
      ffestorag_end_layout (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}

/* ffestu_sym_exec_transition -- Update symbol just before first exec stmt

   ffesymbol s;
   ffestu_sym_exec_transition(s);  */