Virgin import of gcc from EGCS 1.1.2

1 files changed, 573 insertions, 0 deletions

diff --git a/contrib/gcc/f/storag.c b/contrib/gcc/f/storag.c
new file mode 100644
index 0000000..76f5cd3
--- /dev/null
+++ b/contrib/gcc/f/storag.c
@@ -0,0 +1,573 @@
+/* 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);
+    }
+}