freebsd-nq/contrib/gcc/f/storag.c

/* storag.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   Contributed by James Craig Burley (burley@gnu.org).

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.

   Related Modules:
      None

   Description:
      Maintains information on storage (memory) relationships between
      COMMON, dummy, and local variables, plus their equivalences (dummies
      don't have equivalences, however).

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "storag.h"
#include "data.h"
#include "malloc.h"
#include "symbol.h"
#include "target.h"

/* Externals defined here. */

ffestoragList_ ffestorag_list_;

/* Simple definitions and enumerations. */


/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


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

static ffetargetOffset ffestorag_local_size_;	/* #units allocated so far. */
static bool ffestorag_reported_;/* Reports happen only once. */

/* Static functions (internal). */


/* Internal macros. */

#define ffestorag_next_(s) ((s)->next)
#define ffestorag_previous_(s) ((s)->previous)

/* ffestorag_drive -- Drive fn from list of storage objects

   ffestoragList sl;
   void (*fn)(ffestorag mst,ffestorag st);
   ffestorag mst;  // the master ffestorag object (or whatever)
   ffestorag_drive(sl,fn,mst);

   Calls (*fn)(mst,st) for every st in the list sl.  */

void
ffestorag_drive (ffestoragList sl, void (*fn) (ffestorag mst, ffestorag st),
		 ffestorag mst)
{
  ffestorag st;

  for (st = sl->first;
       st != (ffestorag) &sl->first;
       st = st->next)
    (*fn) (mst, st);
}

/* ffestorag_dump -- Dump information on storage object

   ffestorag s;	 // the ffestorag object
   ffestorag_dump(s);

   Dumps information in the storage object.  */

void
ffestorag_dump (ffestorag s)
{
  if (s == NULL)
    {
      fprintf (dmpout, "(no storage object)");
      return;
    }

  switch (s->type)
    {
    case FFESTORAG_typeCBLOCK:
      fprintf (dmpout, "CBLOCK ");
      break;

    case FFESTORAG_typeCOMMON:
      fprintf (dmpout, "COMMON ");
      break;

    case FFESTORAG_typeLOCAL:
      fprintf (dmpout, "LOCAL ");
      break;

    case FFESTORAG_typeEQUIV:
      fprintf (dmpout, "EQUIV ");
      break;

    default:
      fprintf (dmpout, "?%d? ", s->type);
      break;
    }

  if (s->symbol != NULL)
    fprintf (dmpout, "\"%s\" ", ffesymbol_text (s->symbol));

  fprintf (dmpout, "at %" ffetargetOffset_f "d size %" ffetargetOffset_f
	   "d, align loc%%%"
	   ffetargetAlign_f "u=%" ffetargetAlign_f "u, bt=%s, kt=%s",
	   s->offset,
	   s->size, (unsigned int) s->alignment, (unsigned int) s->modulo,
	   ffeinfo_basictype_string (s->basic_type),
	   ffeinfo_kindtype_string (s->kind_type));

  if (s->equivs_.first != (ffestorag) &s->equivs_.first)
    {
      ffestorag sq;

      fprintf (dmpout, " with equivs");
      for (sq = s->equivs_.first;
	   sq != (ffestorag) &s->equivs_.first;
	   sq = ffestorag_next_ (sq))
	{
	  if (ffestorag_previous_ (sq) == (ffestorag) &s->equivs_.first)
	    fputc (' ', dmpout);
	  else
	    fputc (',', dmpout);
	  fprintf (dmpout, "%s", ffesymbol_text (ffestorag_symbol (sq)));
	}
    }
}

/* ffestorag_init_2 -- Initialize for new program unit

   ffestorag_init_2();	*/

void
ffestorag_init_2 ()
{
  ffestorag_list_.first = ffestorag_list_.last
  = (ffestorag) &ffestorag_list_.first;
  ffestorag_local_size_ = 0;
  ffestorag_reported_ = FALSE;
}

/* ffestorag_end_layout -- Do final layout for symbol

   ffesymbol s;
   ffestorag_end_layout(s);  */

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

  ffestorag_exec_layout (s);	/* Do what we have in common. */
#if 0
  assert (ffesymbol_storage (s) == NULL);	/* I'd like to know what
						   cases miss going through
						   ffecom_sym_learned, and
						   why; I don't think we
						   should have to do the
						   exec_layout thing at all
						   here. */
  /* Now I think I know: we have to do exec_layout here, because equivalence
     handling could encounter an error that takes a variable off of its
     equivalence object (and vice versa), and we should then layout the var
     as a local entity. */
#endif
}

/* ffestorag_exec_layout -- Do initial layout for symbol

   ffesymbol s;
   ffestorag_exec_layout(s);  */

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

/* 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);
    }
}