storag.c

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

	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;
    }
}

/* ffestorag_new -- Create new ffestorag object, append to list

   ffestorag s;
   ffestoragList sl;
   s = ffestorag_new(sl);  */

ffestorag
ffestorag_new (ffestoragList sl)
{
  ffestorag s;

  s = (ffestorag) malloc_new_kp (ffe_pool_program_unit (), "ffestorag",
				 sizeof (*s));
  s->next = (ffestorag) &sl->first;
  s->previous = sl->last;
#ifdef FFECOM_storageHOOK
  s->hook = FFECOM_storageNULL;
#endif
  s->previous->next = s;
  sl->last = s;
  s->equivs_.first = s->equivs_.last = (ffestorag) &s->equivs_.first;

  return s;
}

/* Report info on LOCAL non-sym-assoc'ed entities if needed.  */

void
ffestorag_report ()
{
  ffestorag s;

  if (ffestorag_reported_)
    return;

  for (s = ffestorag_list_.first;
       s != (ffestorag) &ffestorag_list_.first;
       s = s->next)
    {
      if (s->symbol == NULL)
	{
	  ffestorag_reported_ = TRUE;
	  fputs ("Storage area: ", dmpout);
	  ffestorag_dump (s);
	  fputc ('\n', dmpout);
	}
    }
}

/* ffestorag_update -- Update type info for ffestorag object

   ffestorag s;	 // existing object
   ffeinfoBasictype bt;	 // basic type for newly added member of object
   ffeinfoKindtype kt;	// kind type for it
   ffestorag_update(s,bt,kt);

   If the existing type for the storage object agrees with the new type
   info, just returns.	If the basic types agree but not the kind types,
   sets the kind type for the object to NONE.  If the basic types
   disagree, sets the kind type to NONE, and the basic type to NONE if the
   basic types both are not CHARACTER, otherwise to ANY.  If the basic
   type for the object already is NONE, it is set to ANY if the new basic
   type is CHARACTER.  Any time a transition is made to ANY and pedantic
   mode is on, a message is issued that mixing CHARACTER and non-CHARACTER
   stuff in the same COMMON/EQUIVALENCE is invalid.  */

void
ffestorag_update (ffestorag s, ffesymbol sym, ffeinfoBasictype bt,
		  ffeinfoKindtype kt)
{
  if (s->basic_type == bt)
    {
      if (s->kind_type == kt)
	return;
      s->kind_type = FFEINFO_kindtypeNONE;
      return;
    }

  switch (s->basic_type)
    {
    case FFEINFO_basictypeANY:
      return;			/* No need to do anything further. */

    case FFEINFO_basictypeCHARACTER:
    any:			/* :::::::::::::::::::: */
      s->basic_type = FFEINFO_basictypeANY;
      s->kind_type = FFEINFO_kindtypeANY;
      if (ffe_is_pedantic ())
	{
	  ffebad_start (FFEBAD_MIXED_TYPES);
	  ffebad_string (ffesymbol_text (s->type_symbol));
	  ffebad_string (ffesymbol_text (sym));
	  ffebad_finish ();
	}
      return;

    default:
      if (bt == FFEINFO_basictypeCHARACTER)
	goto any;		/* :::::::::::::::::::: */
      s->basic_type = FFEINFO_basictypeNONE;
      s->kind_type = FFEINFO_kindtypeNONE;
      return;
    }
}

/* Update INIT flag for storage object.

   If the INIT flag for the <s> object is already TRUE, return.	 Else,
   set it to TRUE and call ffe*_update_init for all contained objects.	*/

void
ffestorag_update_init (ffestorag s)
{
  ffestorag sq;

  if (s->is_init)
    return;

  s->is_init = TRUE;

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

  if (s->parent != NULL)
    ffestorag_update_init (s->parent);

  for (sq = s->equivs_.first;
       sq != (ffestorag) &s->equivs_.first;
       sq = ffestorag_next_ (sq))
    {
      if (!sq->is_init)
	ffestorag_update_init (sq);
    }
}

/* Update SAVE flag for storage object.

   If the SAVE flag for the <s> object is already TRUE, return.	 Else,
   set it to TRUE and call ffe*_update_save for all contained objects.	*/

void
ffestorag_update_save (ffestorag s)
{
  ffestorag sq;

  if (s->is_save)
    return;

  s->is_save = TRUE;

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

  if (s->parent != NULL)
    ffestorag_update_save (s->parent);

  for (sq = s->equivs_.first;
       sq != (ffestorag) &s->equivs_.first;
       sq = ffestorag_next_ (sq))
    {
      if (!sq->is_save)
	ffestorag_update_save (sq);
    }
}