Beispiel #1
0
void
ffesymbol_error (ffesymbol s, ffelexToken t)
{
  if ((t != NULL)
      && ffest_ffebad_start (FFEBAD_SYMERR))
    {
      ffebad_string (ffesymbol_text (s));
      ffebad_here (0, ffelex_token_where_line (t),
		   ffelex_token_where_column (t));
      ffebad_here (1, ffesymbol_where_line (s), ffesymbol_where_column (s));
      ffebad_finish ();
    }

  if (ffesymbol_attr (s, FFESYMBOL_attrANY))
    return;

  ffesymbol_signal_change (s);	/* May need to back up to previous version. */
  if ((ffesymbol_attrs (s) & FFESYMBOL_attrsCBLOCK)
      || (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
    ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
  ffesymbol_set_attr (s, FFESYMBOL_attrANY);
  ffesymbol_set_info (s, ffeinfo_new_any ());
  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  if (s->check_state == FFESYMBOL_checkstatePENDING_)
    ffelex_token_kill (s->check_token);
  s->check_state = FFESYMBOL_checkstateCHECKED_;
  s = ffecom_sym_learned (s);
  ffesymbol_signal_unreported (s);
}
Beispiel #2
0
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;
	  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;
}
Beispiel #3
0
ffesymbol
ffestu_sym_exec_transition (ffesymbol s)
{
  ffeinfoKind skd;
  ffeinfoWhere swh;
  ffeinfoKind nkd;
  ffeinfoWhere nwh;
  ffesymbolAttrs sa;
  ffesymbolAttrs na;
  ffesymbolState ss;
  ffesymbolState ns;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;
  bool needs_type = TRUE;	/* Implicit type assignment might be
				   necessary. */
  bool resolve_intrin = TRUE;	/* Might need to resolve intrinsic. */

  assert (s != NULL);

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

  switch (ss)
    {
    case FFESYMBOL_stateNONE:
      return s;			/* Assume caller will handle it. */

    case FFESYMBOL_stateSEEN:
      break;

    case FFESYMBOL_stateUNCERTAIN:
      ffestorag_exec_layout (s);
      return s;			/* Already processed this one, or not
				   necessary. */

    case FFESYMBOL_stateUNDERSTOOD:
      if (skd == FFEINFO_kindNAMELIST)
	{
	  ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
	  ffestu_list_exec_transition_ (ffesymbol_namelist (s));
	}
      else if ((swh == FFEINFO_whereLOCAL)
	       && ((skd == FFEINFO_kindFUNCTION)
		   || (skd == FFEINFO_kindSUBROUTINE)))
	{
	  ffestu_dummies_transition_ (ffecom_sym_exec_transition,
				      ffesymbol_dummyargs (s));
	  if ((skd == FFEINFO_kindFUNCTION)
	      && !ffeimplic_establish_symbol (s))
	    ffesymbol_error (s, ffesta_tokens[0]);
	}

      ffesymbol_reference (s, NULL, FALSE);
      ffestorag_exec_layout (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
      return s;

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

  ns = FFESYMBOL_stateUNDERSTOOD;	/* Only a few UNCERTAIN exceptions. */

  na = sa;
  nkd = skd;
  nwh = swh;

  assert (!(sa & FFESYMBOL_attrsANY));

  if (sa & FFESYMBOL_attrsCOMMON)
    {
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsEQUIV
		       | FFESYMBOL_attrsINIT
		       | FFESYMBOL_attrsNAMELIST
		       | FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      nkd = FFEINFO_kindENTITY;
      nwh = FFEINFO_whereCOMMON;
    }
  else if (sa & FFESYMBOL_attrsRESULT)
    {				/* Result variable for function. */
      assert (!(sa & ~(FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsRESULT
		       | FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      nkd = FFEINFO_kindENTITY;
      nwh = FFEINFO_whereRESULT;
    }
  else if (sa & FFESYMBOL_attrsSFUNC)
    {				/* Statement function. */
      assert (!(sa & ~(FFESYMBOL_attrsSFUNC
		       | FFESYMBOL_attrsTYPE)));

      nkd = FFEINFO_kindFUNCTION;
      nwh = FFEINFO_whereCONSTANT;
    }
  else if (sa & FFESYMBOL_attrsEXTERNAL)
    {
      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsTYPE)));

      if (sa & FFESYMBOL_attrsTYPE)
	{
	  nkd = FFEINFO_kindFUNCTION;

	  if (sa & FFESYMBOL_attrsDUMMY)
	    nwh = FFEINFO_whereDUMMY;
	  else
	    {
	      if (ffesta_is_entry_valid)
		{
		  nwh = FFEINFO_whereNONE;	/* DUMMY, GLOBAL. */
		  ns = FFESYMBOL_stateUNCERTAIN;
		}
	      else
		nwh = FFEINFO_whereGLOBAL;
	    }
	}
      else
	/* No TYPE. */
	{
	  nkd = FFEINFO_kindNONE;	/* FUNCTION, SUBROUTINE, BLOCKDATA. */
	  needs_type = FALSE;	/* Only gets type if FUNCTION. */
	  ns = FFESYMBOL_stateUNCERTAIN;

	  if (sa & FFESYMBOL_attrsDUMMY)
	    nwh = FFEINFO_whereDUMMY;	/* Not BLOCKDATA. */
	  else
	    {
	      if (ffesta_is_entry_valid)
		nwh = FFEINFO_whereNONE;	/* DUMMY, GLOBAL. */
	      else
		nwh = FFEINFO_whereGLOBAL;
	    }
	}
    }
  else if (sa & FFESYMBOL_attrsDUMMY)
    {
      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE	/* Possible. */
		       | FFESYMBOL_attrsADJUSTS	/* Possible. */
		       | FFESYMBOL_attrsANYLEN	/* Possible. */
		       | FFESYMBOL_attrsANYSIZE	/* Possible. */
		       | FFESYMBOL_attrsARRAY	/* Possible. */
		       | FFESYMBOL_attrsDUMMY	/* Have it. */
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsSFARG	/* Possible. */
		       | FFESYMBOL_attrsTYPE)));	/* Possible. */

      nwh = FFEINFO_whereDUMMY;

      if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
	na = FFESYMBOL_attrsetNONE;

      if (sa & (FFESYMBOL_attrsADJUSTS
		| FFESYMBOL_attrsARRAY
		| FFESYMBOL_attrsANYLEN
		| FFESYMBOL_attrsNAMELIST
		| FFESYMBOL_attrsSFARG))
	nkd = FFEINFO_kindENTITY;
      else if (sa & FFESYMBOL_attrsDUMMY)	/* Still okay. */
	{
	  if (!(sa & FFESYMBOL_attrsTYPE))
	    needs_type = FALSE;	/* Don't assign type to SUBROUTINE! */
	  nkd = FFEINFO_kindNONE;	/* ENTITY, FUNCTION, SUBROUTINE. */
	  ns = FFESYMBOL_stateUNCERTAIN;
	}
    }
  else if (sa & FFESYMBOL_attrsADJUSTS)
    {				/* Must be DUMMY or COMMON at some point. */
      assert (!(sa & (FFESYMBOL_attrsCOMMON
		      | FFESYMBOL_attrsDUMMY)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTS	/* Have it. */
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEQUIV	/* Possible. */
		       | FFESYMBOL_attrsINIT	/* Possible. */
		       | FFESYMBOL_attrsNAMELIST	/* Possible. */
		       | FFESYMBOL_attrsSFARG	/* Possible. */
		       | FFESYMBOL_attrsTYPE)));	/* Possible. */

      nkd = FFEINFO_kindENTITY;

      if (sa & FFESYMBOL_attrsEQUIV)
	{
	  if ((ffesymbol_equiv (s) == NULL)
	      || (ffeequiv_common (ffesymbol_equiv (s)) == NULL))
	    na = FFESYMBOL_attrsetNONE;	/* Not equiv'd into COMMON. */
	  else
	    nwh = FFEINFO_whereCOMMON;
	}
      else if (!ffesta_is_entry_valid
	       || (sa & (FFESYMBOL_attrsINIT
			 | FFESYMBOL_attrsNAMELIST)))
	na = FFESYMBOL_attrsetNONE;
      else
	nwh = FFEINFO_whereDUMMY;
    }
  else if (sa & FFESYMBOL_attrsSAVE)
    {
      assert (!(sa & ~(FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsEQUIV
		       | FFESYMBOL_attrsINIT
		       | FFESYMBOL_attrsNAMELIST
		       | FFESYMBOL_attrsSAVE
		       | FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsTYPE)));

      nkd = FFEINFO_kindENTITY;
      nwh = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsEQUIV)
    {
      assert (!(sa & FFESYMBOL_attrsCOMMON));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTS	/* Possible. */
		       | FFESYMBOL_attrsARRAY	/* Possible. */
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsEQUIV	/* Have it. */
		       | FFESYMBOL_attrsINIT	/* Possible. */
		       | FFESYMBOL_attrsNAMELIST	/* Possible. */
		       | FFESYMBOL_attrsSAVE	/* Possible. */
		       | FFESYMBOL_attrsSFARG	/* Possible. */
		       | FFESYMBOL_attrsTYPE)));	/* Possible. */

      nkd = FFEINFO_kindENTITY;
      nwh = ffestu_equiv_ (s);
    }
  else if (sa & FFESYMBOL_attrsNAMELIST)
    {
      assert (!(sa & (FFESYMBOL_attrsADJUSTS
		      | FFESYMBOL_attrsCOMMON
		      | FFESYMBOL_attrsEQUIV
		      | FFESYMBOL_attrsSAVE)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
		       | FFESYMBOL_attrsARRAY	/* Possible. */
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsEQUIV
		       | FFESYMBOL_attrsINIT	/* Possible. */
		       | FFESYMBOL_attrsNAMELIST	/* Have it. */
		       | FFESYMBOL_attrsSAVE
		       | FFESYMBOL_attrsSFARG	/* Possible. */
		       | FFESYMBOL_attrsTYPE)));	/* Possible. */

      nkd = FFEINFO_kindENTITY;
      nwh = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsINIT)
    {
      assert (!(sa & (FFESYMBOL_attrsADJUSTS
		      | FFESYMBOL_attrsCOMMON
		      | FFESYMBOL_attrsEQUIV
		      | FFESYMBOL_attrsNAMELIST
		      | FFESYMBOL_attrsSAVE)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
		       | FFESYMBOL_attrsARRAY	/* Possible. */
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsEQUIV
		       | FFESYMBOL_attrsINIT	/* Have it. */
		       | FFESYMBOL_attrsNAMELIST
		       | FFESYMBOL_attrsSAVE
		       | FFESYMBOL_attrsSFARG	/* Possible. */
		       | FFESYMBOL_attrsTYPE)));	/* Possible. */

      nkd = FFEINFO_kindENTITY;
      nwh = FFEINFO_whereLOCAL;
    }
  else if (sa & FFESYMBOL_attrsSFARG)
    {
      assert (!(sa & (FFESYMBOL_attrsADJUSTS
		      | FFESYMBOL_attrsCOMMON
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEQUIV
		      | FFESYMBOL_attrsINIT
		      | FFESYMBOL_attrsNAMELIST
		      | FFESYMBOL_attrsRESULT
		      | FFESYMBOL_attrsSAVE)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTS
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEQUIV
		       | FFESYMBOL_attrsINIT
		       | FFESYMBOL_attrsNAMELIST
		       | FFESYMBOL_attrsRESULT
		       | FFESYMBOL_attrsSAVE
		       | FFESYMBOL_attrsSFARG	/* Have it. */
		       | FFESYMBOL_attrsTYPE)));	/* Possible. */

      nkd = FFEINFO_kindENTITY;

      if (ffesta_is_entry_valid)
	{
	  nwh = FFEINFO_whereNONE;	/* DUMMY, LOCAL. */
	  ns = FFESYMBOL_stateUNCERTAIN;
	}
      else
	nwh = FFEINFO_whereLOCAL;
    }
  else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
    {
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsANYSIZE
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsTYPE)));

      nkd = FFEINFO_kindENTITY;

      if (ffestu_symter_exec_transition_ (ffesymbol_dims (s)))
	na = FFESYMBOL_attrsetNONE;

      if (sa & (FFESYMBOL_attrsANYLEN | FFESYMBOL_attrsANYSIZE))
	nwh = FFEINFO_whereDUMMY;
      else if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYSIZE))
	/* Still okay.  */
	{
	  nwh = FFEINFO_whereNONE;	/* DUMMY, LOCAL. */
	  ns = FFESYMBOL_stateUNCERTAIN;
	}
    }
  else if (sa & FFESYMBOL_attrsARRAY)
    {
      assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
		      | FFESYMBOL_attrsANYSIZE
		      | FFESYMBOL_attrsCOMMON
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEQUIV
		      | FFESYMBOL_attrsINIT
		      | FFESYMBOL_attrsNAMELIST
		      | FFESYMBOL_attrsSAVE)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN	/* Possible. */
		       | FFESYMBOL_attrsANYSIZE
		       | FFESYMBOL_attrsARRAY	/* Have it. */
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEQUIV
		       | FFESYMBOL_attrsINIT
		       | FFESYMBOL_attrsNAMELIST
		       | FFESYMBOL_attrsSAVE
		       | FFESYMBOL_attrsTYPE)));	/* Possible. */

      nkd = FFEINFO_kindENTITY;

      if (sa & FFESYMBOL_attrsANYLEN)
	{
	  assert (ffesta_is_entry_valid);	/* Already diagnosed. */
	  nwh = FFEINFO_whereDUMMY;
	}
      else
	{
	  if (ffesta_is_entry_valid)
	    {
	      nwh = FFEINFO_whereNONE;	/* DUMMY, LOCAL. */
	      ns = FFESYMBOL_stateUNCERTAIN;
	    }
	  else
	    nwh = FFEINFO_whereLOCAL;
	}
    }
  else if (sa & FFESYMBOL_attrsANYLEN)
    {
      assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
		      | FFESYMBOL_attrsANYSIZE
		      | FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsRESULT)));	/* Handled above. */
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsANYLEN	/* Have it. */
		       | FFESYMBOL_attrsANYSIZE
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsRESULT
		       | FFESYMBOL_attrsTYPE)));	/* Have it too. */

      if (ffesta_is_entry_valid)
	{
	  nkd = FFEINFO_kindNONE;	/* ENTITY, FUNCTION. */
	  nwh = FFEINFO_whereNONE;	/* DUMMY, INTRINSIC, RESULT. */
	  ns = FFESYMBOL_stateUNCERTAIN;
	  resolve_intrin = FALSE;
	}
      else if (ffeintrin_is_intrinsic (ffesymbol_text (s), NULL, FALSE,
				       &gen, &spec, &imp))
	{
	  ffesymbol_signal_change (s);
	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
	  ffesymbol_set_generic (s, gen);
	  ffesymbol_set_specific (s, spec);
	  ffesymbol_set_implementation (s, imp);
	  ffesymbol_set_info (s,
			      ffeinfo_new (FFEINFO_basictypeNONE,
					   FFEINFO_kindtypeNONE,
					   0,
					   FFEINFO_kindNONE,
					   FFEINFO_whereINTRINSIC,
					   FFETARGET_charactersizeNONE));
	  ffesymbol_resolve_intrin (s);
	  ffesymbol_reference (s, NULL, FALSE);
	  ffestorag_exec_layout (s);
	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
	  return s;
	}
      else
	{			/* SPECIAL: can't have CHAR*(*) var in
				   PROGRAM/BLOCKDATA, unless it isn't
				   referenced anywhere in the code. */
	  ffesymbol_signal_change (s);	/* Can't touch this. */
	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
	  ffesymbol_resolve_intrin (s);
	  ffesymbol_reference (s, NULL, FALSE);
	  ffestorag_exec_layout (s);
	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
	  return s;
	}
    }
  else if (sa & FFESYMBOL_attrsTYPE)
    {
      assert (!(sa & (FFESYMBOL_attrsADJUSTABLE
		      | FFESYMBOL_attrsADJUSTS
		      | FFESYMBOL_attrsANYLEN
		      | FFESYMBOL_attrsANYSIZE
		      | FFESYMBOL_attrsARRAY
		      | FFESYMBOL_attrsCOMMON
		      | FFESYMBOL_attrsDUMMY
		      | FFESYMBOL_attrsEQUIV
		      | FFESYMBOL_attrsEXTERNAL
		      | FFESYMBOL_attrsINIT
		      | FFESYMBOL_attrsNAMELIST
		      | FFESYMBOL_attrsRESULT
		      | FFESYMBOL_attrsSAVE
		      | FFESYMBOL_attrsSFARG
		      | FFESYMBOL_attrsSFUNC)));
      assert (!(sa & ~(FFESYMBOL_attrsADJUSTABLE
		       | FFESYMBOL_attrsADJUSTS
		       | FFESYMBOL_attrsANYLEN
		       | FFESYMBOL_attrsANYSIZE
		       | FFESYMBOL_attrsARRAY
		       | FFESYMBOL_attrsCOMMON
		       | FFESYMBOL_attrsDUMMY
		       | FFESYMBOL_attrsEQUIV
		       | FFESYMBOL_attrsEXTERNAL
		       | FFESYMBOL_attrsINIT
		       | FFESYMBOL_attrsINTRINSIC	/* UNDERSTOOD. */
		       | FFESYMBOL_attrsNAMELIST
		       | FFESYMBOL_attrsRESULT
		       | FFESYMBOL_attrsSAVE
		       | FFESYMBOL_attrsSFARG
		       | FFESYMBOL_attrsSFUNC
		       | FFESYMBOL_attrsTYPE)));	/* Have it. */

      nkd = FFEINFO_kindNONE;	/* ENTITY, FUNCTION. */
      nwh = FFEINFO_whereNONE;	/* DUMMY, GLOBAL, INTRINSIC, LOCAL, RESULT. */
      ns = FFESYMBOL_stateUNCERTAIN;
      resolve_intrin = FALSE;
    }
  else if (sa & (FFESYMBOL_attrsCBLOCK | FFESYMBOL_attrsSAVECBLOCK))
    {				/* COMMON block. */
      assert (!(sa & ~(FFESYMBOL_attrsCBLOCK
		       | FFESYMBOL_attrsSAVECBLOCK)));

      if (sa & FFESYMBOL_attrsCBLOCK)
	ffebld_end_list (ffesymbol_ptr_to_listbottom (s));
      else
	ffesymbol_set_commonlist (s, NULL);
      ffestu_list_exec_transition_ (ffesymbol_commonlist (s));
      nkd = FFEINFO_kindCOMMON;
      nwh = FFEINFO_whereLOCAL;
      needs_type = FALSE;
    }
  else
    {				/* First seen in stmt func definition. */
      assert (sa == FFESYMBOL_attrsetNONE);
      assert ("Why are we here again?" == NULL);	/* ~~~~~ */

      nkd = FFEINFO_kindNONE;	/* ENTITY, FUNCTION. */
      nwh = FFEINFO_whereNONE;	/* DUMMY, GLOBAL, LOCAL. */
      ns = FFESYMBOL_stateUNCERTAIN;	/* Will get repromoted by caller. */
      needs_type = FALSE;
    }

  if (na == FFESYMBOL_attrsetNONE)
    ffesymbol_error (s, ffesta_tokens[0]);
  else if (!(na & FFESYMBOL_attrsANY)
	   && (needs_type || (nkd != skd) || (nwh != swh)
	       || (na != sa) || (ns != ss)))
    {
      ffesymbol_signal_change (s);
      ffesymbol_set_attrs (s, na);	/* Establish new info. */
      ffesymbol_set_state (s, ns);
      if ((ffesymbol_common (s) == NULL)
	  && (ffesymbol_equiv (s) != NULL))
	ffesymbol_set_common (s, ffeequiv_common (ffesymbol_equiv (s)));
      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 if (resolve_intrin)
	ffesymbol_resolve_intrin (s);
      ffesymbol_reference (s, NULL, FALSE);
      ffestorag_exec_layout (s);
      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
    }

  return s;
}
Beispiel #4
0
void
ffestorag_exec_layout (ffesymbol s)
{
  ffetargetAlign alignment;
  ffetargetAlign modulo;
  ffetargetOffset size;
  ffetargetOffset num_elements;
  ffetargetAlign pad;
  ffestorag st;
  ffestorag stv;
  ffebld list;
  ffebld item;
  ffesymbol var;
  bool init;

  if (ffesymbol_storage (s) != NULL)
    return;			/* Already laid out. */

  switch (ffesymbol_kind (s))
    {
    default:
      return;			/* Do nothing. */

    case FFEINFO_kindENTITY:
      switch (ffesymbol_where (s))
	{
	case FFEINFO_whereLOCAL:
	  if (ffesymbol_equiv (s) != NULL)
	    return;		/* Let ffeequiv handle this guy. */
	  if (ffesymbol_rank (s) == 0)
	    num_elements = 1;
	  else
	    {
	      if (ffebld_op (ffesymbol_arraysize (s))
		  != FFEBLD_opCONTER)
		return;	/* An adjustable local array, just like a dummy. */
	      num_elements
		= ffebld_constant_integerdefault (ffebld_conter
						  (ffesymbol_arraysize (s)));
	    }
	  ffetarget_layout (ffesymbol_text (s), &alignment, &modulo,
			    &size, ffesymbol_basictype (s),
			    ffesymbol_kindtype (s), ffesymbol_size (s),
			    num_elements);
	  st = ffestorag_new (ffestorag_list_master ());
	  st->parent = NULL;	/* Initializations happen at sym level. */
	  st->init = NULL;
	  st->accretion = NULL;
	  st->symbol = s;
	  st->size = size;
	  st->offset = 0;
	  st->alignment = alignment;
	  st->modulo = modulo;
	  st->type = FFESTORAG_typeLOCAL;
	  st->basic_type = ffesymbol_basictype (s);
	  st->kind_type = ffesymbol_kindtype (s);
	  st->type_symbol = s;
	  st->is_save = ffesymbol_is_save (s);
	  st->is_init = ffesymbol_is_init (s);
	  ffesymbol_set_storage (s, st);
	  if (ffesymbol_is_init (s))
	    ffecom_notify_init_symbol (s);	/* Init completed before, but
						   we didn't have a storage
						   object for it; maybe back
						   end wants to see the sym
						   again now. */
	  ffesymbol_signal_unreported (s);
	  return;

	case FFEINFO_whereCOMMON:
	  return;		/* Allocate storage for entire common block
				   at once. */

	case FFEINFO_whereDUMMY:
	  return;		/* Don't do anything about dummies for now. */

	case FFEINFO_whereRESULT:
	case FFEINFO_whereIMMEDIATE:
	case FFEINFO_whereCONSTANT:
	case FFEINFO_whereNONE:
	  return;		/* These don't get storage (esp. NONE, which
				   is UNCERTAIN). */

	default:
	  assert ("bad ENTITY where" == NULL);
	  return;
	}
      break;

    case FFEINFO_kindCOMMON:
      assert (ffesymbol_where (s) == FFEINFO_whereLOCAL);
      st = ffestorag_new (ffestorag_list_master ());
      st->parent = NULL;	/* Initializations happen here. */
      st->init = NULL;
      st->accretion = NULL;
      st->symbol = s;
      st->size = 0;
      st->offset = 0;
      st->alignment = 1;
      st->modulo = 0;
      st->type = FFESTORAG_typeCBLOCK;
      if (ffesymbol_commonlist (s) != NULL)
	{
	  var = ffebld_symter (ffebld_head (ffesymbol_commonlist (s)));
	  st->basic_type = ffesymbol_basictype (var);
	  st->kind_type = ffesymbol_kindtype (var);
	  st->type_symbol = var;
	}
      else
	{			/* Special case for empty common area:
				   NONE/NONE means nothing. */
	  st->basic_type = FFEINFO_basictypeNONE;
	  st->kind_type = FFEINFO_kindtypeNONE;
	  st->type_symbol = NULL;
	}
      st->is_save = ffesymbol_is_save (s);
      st->is_init = ffesymbol_is_init (s);
      if (!ffe_is_mainprog ())
	ffeglobal_save_common (s,
			       st->is_save || ffe_is_saveall (),
			       ffesymbol_where_line (s),
			       ffesymbol_where_column (s));
      ffesymbol_set_storage (s, st);

      init = FALSE;
      for (list = ffesymbol_commonlist (s);
	   list != NULL;
	   list = ffebld_trail (list))
	{
	  item = ffebld_head (list);
	  assert (ffebld_op (item) == FFEBLD_opSYMTER);
	  var = ffebld_symter (item);
	  if (ffesymbol_basictype (var) == FFEINFO_basictypeANY)
	    continue;		/* Ignore any symbols that have errors. */
	  if (ffesymbol_rank (var) == 0)
	    num_elements = 1;
	  else
	    num_elements = ffebld_constant_integerdefault (ffebld_conter
					       (ffesymbol_arraysize (var)));
	  ffetarget_layout (ffesymbol_text (var), &alignment, &modulo,
			    &size, ffesymbol_basictype (var),
			    ffesymbol_kindtype (var), ffesymbol_size (var),
			    num_elements);
	  pad = ffetarget_align (&st->alignment, &st->modulo, st->size,
				 alignment, modulo);
	  if (pad != 0)
	    {			/* Warn about padding in the midst of a
				   common area. */
	      char padding[20];

	      sprintf (&padding[0], "%" ffetargetAlign_f "u", pad);
	      ffebad_start (FFEBAD_COMMON_PAD);
	      ffebad_string (padding);
	      ffebad_string (ffesymbol_text (var));
	      ffebad_string (ffesymbol_text (s));
	      ffebad_string ((pad == 1)
			     ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS);
	      ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
	      ffebad_finish ();
	    }
	  stv = ffestorag_new (ffestorag_list_master ());
	  stv->parent = st;	/* Initializations happen in COMMON block. */
	  stv->init = NULL;
	  stv->accretion = NULL;
	  stv->symbol = var;
	  stv->size = size;
	  if (!ffetarget_offset_add (&stv->offset, st->size, pad))
	    {			/* Common block size plus pad, complain if
				   overflow. */
	      ffetarget_offset_overflow (ffesymbol_text (s));
	    }
	  if (!ffetarget_offset_add (&st->size, stv->offset, stv->size))
	    {			/* Adjust size of common block, complain if
				   overflow. */
	      ffetarget_offset_overflow (ffesymbol_text (s));
	    }
	  stv->alignment = alignment;
	  stv->modulo = modulo;
	  stv->type = FFESTORAG_typeCOMMON;
	  stv->basic_type = ffesymbol_basictype (var);
	  stv->kind_type = ffesymbol_kindtype (var);
	  stv->type_symbol = var;
	  stv->is_save = st->is_save;
	  stv->is_init = st->is_init;
	  ffesymbol_set_storage (var, stv);
	  ffesymbol_signal_unreported (var);
	  ffestorag_update (st, var, ffesymbol_basictype (var),
			    ffesymbol_kindtype (var));
	  if (ffesymbol_is_init (var))
	    init = TRUE;	/* Must move inits over to COMMON's
				   ffestorag. */
	}
      if (ffeequiv_layout_cblock (st))
	init = TRUE;
      ffeglobal_pad_common (s, st->modulo, ffesymbol_where_line (s),
			    ffesymbol_where_column (s));
      if (init)
	ffedata_gather (st);	/* Gather subordinate inits into one init. */
      ffesymbol_signal_unreported (s);
      return;
    }
}