symbol.c

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

  switch (kind)
    {
    case FFEINFO_kindBLOCKDATA:
      okay = ffeglobal_ref_blockdata (s, t);
      break;

    case FFEINFO_kindSUBROUTINE:
      okay = ffeglobal_ref_subroutine (s, t);
      break;

    case FFEINFO_kindFUNCTION:
      okay = ffeglobal_ref_function (s, t);
      break;

    case FFEINFO_kindNONE:
      okay = ffeglobal_ref_external (s, t);
      break;

    default:
      assert ("bad kind in global ref" == NULL);
      return;
    }

  if (! okay)
    ffesymbol_error (s, NULL);
}

/* Report info on the symbol for debugging purposes.  */

#if FFECOM_targetCURRENT == FFECOM_targetFFE
ffesymbol
ffesymbol_report (ffesymbol s)
{
  ffeinfoKind k;
  ffeinfoWhere w;

  assert (s != NULL);

  if (s->reported)
    return s;

  s->reported = TRUE;

  if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE)
    fprintf (dmpout, "\"%s\": %s %s %d%s%s*%" ffetargetCharacterSize_f "u",
	     ffesymbol_text (s),
	     ffesymbol_state_string (s->state),
	     ffesymbol_attrs_string (s->attrs),
	     (int) ffeinfo_rank (s->info),
	     ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
	     ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)),
	     ffeinfo_size (s->info));
  else
    fprintf (dmpout, "\"%s\": %s %s %d%s%s",
	     ffesymbol_text (s),
	     ffesymbol_state_string (s->state),
	     ffesymbol_attrs_string (s->attrs),
	     (int) ffeinfo_rank (s->info),
	     ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
	     ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)));
  if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE)
    fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
  if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE)
    fprintf (dmpout, "@%s", ffeinfo_where_string (w));
  fputc ('\n', dmpout);

  if (s->dims != NULL)
    {
      fprintf (dmpout, "  dims: ");
      ffebld_dump (s->dims);
      fputs ("\n", dmpout);
    }

  if (s->extents != NULL)
    {
      fprintf (dmpout, "  extents: ");
      ffebld_dump (s->extents);
      fputs ("\n", dmpout);
    }

  if (s->dim_syms != NULL)
    {
      fprintf (dmpout, "  dim syms: ");
      ffebld_dump (s->dim_syms);
      fputs ("\n", dmpout);
    }

  if (s->array_size != NULL)
    {
      fprintf (dmpout, "  array size: ");
      ffebld_dump (s->array_size);
      fputs ("\n", dmpout);
    }

  if (s->init != NULL)
    {
      fprintf (dmpout, "  init-value: ");
      if (ffebld_op (s->init) == FFEBLD_opANY)
	fputs ("<any>\n", dmpout);
      else
	{
	  ffebld_dump (s->init);
	  fputs ("\n", dmpout);
	}
    }

  if (s->accretion != NULL)
    {
      fprintf (dmpout, "  accretion (%" ffetargetOffset_f "d left): ",
	       s->accretes);
      ffebld_dump (s->accretion);
      fputs ("\n", dmpout);
    }
  else if (s->accretes != 0)
    fprintf (dmpout, "  accretes!! = %" ffetargetOffset_f "d left\n",
	     s->accretes);

  if (s->dummy_args != NULL)
    {
      fprintf (dmpout, "  dummies: ");
      ffebld_dump (s->dummy_args);
      fputs ("\n", dmpout);
    }

  if (s->namelist != NULL)
    {
      fprintf (dmpout, "  namelist: ");
      ffebld_dump (s->namelist);
      fputs ("\n", dmpout);
    }

  if (s->common_list != NULL)
    {
      fprintf (dmpout, "  common-list: ");
      ffebld_dump (s->common_list);
      fputs ("\n", dmpout);
    }

  if (s->sfunc_expr != NULL)
    {
      fprintf (dmpout, "  sfunc expression: ");
      ffebld_dump (s->sfunc_expr);
      fputs ("\n", dmpout);
    }

  if (s->is_save)
    {
      fprintf (dmpout, "  SAVEd\n");
    }

  if (s->is_init)
    {
      fprintf (dmpout, "  initialized\n");
    }

  if (s->do_iter)
    {
      fprintf (dmpout, "  DO-loop iteration variable (currently)\n");
    }

  if (s->explicit_where)
    {
      fprintf (dmpout, "  Explicit INTRINSIC/EXTERNAL\n");
    }

  if (s->namelisted)
    {
      fprintf (dmpout, "  Namelisted\n");
    }

  if (s->common != NULL)
    {
      fprintf (dmpout, "  COMMON area: %s\n", ffesymbol_text (s->common));
    }

  if (s->equiv != NULL)
    {
      fprintf (dmpout, "  EQUIVALENCE information: ");
      ffeequiv_dump (s->equiv);
      fputs ("\n", dmpout);
    }

  if (s->storage != NULL)
    {
      fprintf (dmpout, "  Storage: ");
      ffestorag_dump (s->storage);
      fputs ("\n", dmpout);
    }

  return s;
}
#endif

/* Report info on the symbols.	*/

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffesymbol_report_all ()
{
  ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_report);
  ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_report);
  ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_report);
}
#endif

/* Resolve symbol that has become known intrinsic or non-intrinsic.  */

void
ffesymbol_resolve_intrin (ffesymbol s)
{
  char c;
  ffebad bad;

  if (!ffesrc_check_symbol ())
    return;
  if (s->check_state != FFESYMBOL_checkstatePENDING_)
    return;
  if (ffebad_inhibit ())
    return;			/* We'll get back to this later. */

  if (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
    {
      bad = ffesymbol_check_token_ (s->check_token, &c);
      assert (bad != FFEBAD);	/* How did this suddenly become ok? */
      ffesymbol_whine_state_ (bad, s->check_token, c);
    }

  s->check_state = FFESYMBOL_checkstateCHECKED_;
  ffelex_token_kill (s->check_token);
}

/* Retract or cancel retract list.  */

void
ffesymbol_retract (bool retract)
{
  ffesymbolRetract_ r;
  ffename name;
  ffename other_space_name;
  ffesymbol ls;
  ffesymbol os;

  assert (ffesymbol_retractable_);

  ffesymbol_retractable_ = FALSE;

  for (r = ffesymbol_retract_first_; r != NULL; r = r->next)
    {
      ls = r->live;
      os = r->symbol;
      switch (r->command)
	{
	case FFESYMBOL_retractcommandDELETE_:
	  if (retract)
	    {
	      ffecom_sym_retract (ls);
	      name = ls->name;
	      other_space_name = ls->other_space_name;
	      ffesymbol_unhook_ (ls);
	      malloc_kill_ks (FFESYMBOL_SPACE_POOL_, ls, sizeof (*ls));
	      if (name != NULL)
		ffename_set_symbol (name, NULL);
	      if (other_space_name != NULL)
		ffename_set_symbol (other_space_name, NULL);
	    }
	  else
	    {
	      ffecom_sym_commit (ls);
	      ls->have_old = FALSE;
	    }
	  break;

	case FFESYMBOL_retractcommandRETRACT_:
	  if (retract)
	    {
	      ffecom_sym_retract (ls);
	      ffesymbol_unhook_ (ls);
	      *ls = *os;
	      malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os));
	    }
	  else
	    {
	      ffecom_sym_commit (ls);
	      ffesymbol_unhook_ (os);
	      malloc_kill_ks (FFESYMBOL_SPACE_POOL_, os, sizeof (*os));
	      ls->have_old = FALSE;
	    }
	  break;

	default:
	  assert ("bad command" == NULL);
	  break;
	}
    }
}

/* Return retractable flag.  */

bool
ffesymbol_retractable ()
{
  return ffesymbol_retractable_;
}

/* Set retractable flag, retract pool.

   Between this call and ffesymbol_retract, any changes made to existing
   symbols cause the previous versions of those symbols to be saved, and any
   newly created symbols to have their previous nonexistence saved.  When
   ffesymbol_retract is called, this information either is used to retract
   the changes and new symbols, or is discarded.  */

void
ffesymbol_set_retractable (mallocPool pool)
{
  assert (!ffesymbol_retractable_);

  ffesymbol_retractable_ = TRUE;
  ffesymbol_retract_pool_ = pool;
  ffesymbol_retract_list_ = &ffesymbol_retract_first_;
  ffesymbol_retract_first_ = NULL;
}

/* Existing symbol about to be changed; save?

   Call this function before changing a symbol if it is possible that
   the current actions may need to be undone (i.e. one of several possible
   statement forms are being used to analyze the current system).

   If the "retractable" flag is not set, just return.
   Else, if the symbol's "have_old" flag is set, just return.
   Else, make a copy of the symbol and add it to the "retract" list, set
   the "have_old" flag, and return.  */

void
ffesymbol_signal_change (ffesymbol s)
{
  ffesymbolRetract_ r;
  ffesymbol sym;

  if (!ffesymbol_retractable_ || s->have_old)
    return;

  r = (ffesymbolRetract_) malloc_new_kp (ffesymbol_retract_pool_,
					 "FFESYMBOL retract", sizeof (*r));
  r->next = NULL;
  r->command = FFESYMBOL_retractcommandRETRACT_;
  r->live = s;
  r->symbol = sym = (ffesymbol) malloc_new_ks (FFESYMBOL_SPACE_POOL_,
					       "FFESYMBOL", sizeof (*sym));
  *sym = *s;			/* Make an exact copy of the symbol in case
				   we need it back. */
  sym->info = ffeinfo_use (s->info);
  if (s->check_state == FFESYMBOL_checkstatePENDING_)
    sym->check_token = ffelex_token_use (s->check_token);

  *ffesymbol_retract_list_ = r;
  ffesymbol_retract_list_ = &r->next;

  s->have_old = TRUE;
}

/* Returns the string based on the state.  */

const char *
ffesymbol_state_string (ffesymbolState state)
{
  if (state >= ARRAY_SIZE (ffesymbol_state_name_))
    return "?\?\?";
  return ffesymbol_state_name_[state];
}

void
ffesymbol_terminate_0 ()
{
}

void
ffesymbol_terminate_1 ()
{
#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalFILE_
  ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_);
  ffename_space_kill (ffesymbol_global_);
  ffesymbol_global_ = NULL;

  ffesymbol_kill_manifest_ ();
#endif
}

void
ffesymbol_terminate_2 ()
{
#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
  ffesymbol_kill_manifest_ ();
#endif
}

void
ffesymbol_terminate_3 ()
{
#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
  ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_unhook_);
  ffename_space_kill (ffesymbol_global_);
#endif
  ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_unhook_);
  ffename_space_kill (ffesymbol_local_);
#if FFESYMBOL_globalCURRENT_ == FFESYMBOL_globalPROGUNIT_
  ffesymbol_global_ = NULL;
#endif
  ffesymbol_local_ = NULL;
}

void
ffesymbol_terminate_4 ()
{
  ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_unhook_);
  ffename_space_kill (ffesymbol_sfunc_);
  ffesymbol_sfunc_ = NULL;
}

/* Update INIT info to TRUE and all equiv/storage too.

   If INIT flag is TRUE, does nothing.	Else sets it to TRUE and calls
   on the ffeequiv and ffestorag modules to update their INIT flags if
   the <s> symbol has those objects, and also updates the common area if
   it exists.  */

void
ffesymbol_update_init (ffesymbol s)
{
  ffebld item;

  if (s->is_init)
    return;

  s->is_init = TRUE;

  if ((s->equiv != NULL)
      && !ffeequiv_is_init (s->equiv))
    ffeequiv_update_init (s->equiv);

  if ((s->storage != NULL)
      && !ffestorag_is_init (s->storage))
    ffestorag_update_init (s->storage);

  if ((s->common != NULL)
      && (!ffesymbol_is_init (s->common)))
    ffesymbol_update_init (s->common);

  for (item = s->common_list; item != NULL; item = ffebld_trail (item))
    {
      if (!ffesymbol_is_init (ffebld_symter (ffebld_head (item))))
	ffesymbol_update_init (ffebld_symter (ffebld_head (item)));
    }
}

/* Update SAVE info to TRUE and all equiv/storage too.

   If SAVE flag is TRUE, does nothing.	Else sets it to TRUE and calls
   on the ffeequiv and ffestorag modules to update their SAVE flags if
   the <s> symbol has those objects, and also updates the common area if
   it exists.  */

void
ffesymbol_update_save (ffesymbol s)
{
  ffebld item;

  if (s->is_save)
    return;

  s->is_save = TRUE;

  if ((s->equiv != NULL)
      && !ffeequiv_is_save (s->equiv))
    ffeequiv_update_save (s->equiv);

  if ((s->storage != NULL)
      && !ffestorag_is_save (s->storage))
    ffestorag_update_save (s->storage);

  if ((s->common != NULL)
      && (!ffesymbol_is_save (s->common)))
    ffesymbol_update_save (s->common);

  for (item = s->common_list; item != NULL; item = ffebld_trail (item))
    {
      if (!ffesymbol_is_save (ffebld_symter (ffebld_head (item))))
	ffesymbol_update_save (ffebld_symter (ffebld_head (item)));
    }
}