data.c

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

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

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:

   Description:
      Do the tough things for DATA statement (and INTEGER FOO/.../-style
      initializations), like implied-DO and suchlike.

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "data.h"
#include "bit.h"
#include "bld.h"
#include "com.h"
#include "expr.h"
#include "global.h"
#include "malloc.h"
#include "st.h"
#include "storag.h"
#include "top.h"

/* Externals defined here. */


/* Simple definitions and enumerations. */

/* I picked this value as one that, when plugged into a couple of small
   but nearly identical test cases I have called BIG-0.f and BIG-1.f,
   causes BIG-1.f to take about 10 times as long (elapsed) to compile
   (in f771 only) as BIG-0.f.  These test cases differ in that BIG-0.f
   doesn't put the one initialized variable in a common area that has
   a large uninitialized array in it, while BIG-1.f does.  The size of
   the array is this many elements, as long as they all are INTEGER
   type.  Note that, as of 0.5.18, sparse cases are better handled,
   so BIG-2.f now is used; it provides nonzero initial
   values for all elements of the same array BIG-0 has.  */
#ifndef FFEDATA_sizeTOO_BIG_INIT_
#define FFEDATA_sizeTOO_BIG_INIT_ 75*1024
#endif

/* Internal typedefs. */

typedef struct _ffedata_convert_cache_ *ffedataConvertCache_;
typedef struct _ffedata_impdo_ *ffedataImpdo_;

/* Private include files. */


/* Internal structure definitions. */

struct _ffedata_convert_cache_
  {
    ffebld converted;		/* Results of converting expr to following
				   type. */
    ffeinfoBasictype basic_type;
    ffeinfoKindtype kind_type;
    ffetargetCharacterSize size;
    ffeinfoRank rank;
  };

struct _ffedata_impdo_
  {
    ffedataImpdo_ outer;	/* Enclosing IMPDO construct. */
    ffebld outer_list;		/* Item after my IMPDO on the outer list. */
    ffebld my_list;		/* Beginning of list in my IMPDO. */
    ffesymbol itervar;		/* Iteration variable. */
    ffetargetIntegerDefault increment;
    ffetargetIntegerDefault final;
  };

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

static ffedataImpdo_ ffedata_stack_ = NULL;
static ffebld ffedata_list_ = NULL;
static bool ffedata_reinit_;	/* value_ should report REINIT error. */
static bool ffedata_reported_error_;	/* Error has been reported. */
static ffesymbol ffedata_symbol_ = NULL;	/* Symbol being initialized. */
static ffeinfoBasictype ffedata_basictype_;	/* Info on symbol. */
static ffeinfoKindtype ffedata_kindtype_;
static ffestorag ffedata_storage_;	/* If non-NULL, inits go into this parent. */
static ffeinfoBasictype ffedata_storage_bt_;	/* Info on storage. */
static ffeinfoKindtype ffedata_storage_kt_;
static ffetargetOffset ffedata_storage_size_;	/* Size of entire storage. */
static ffetargetAlign ffedata_storage_units_;	/* #units per storage unit. */
static ffetargetOffset ffedata_arraysize_;	/* Size of array being
						   inited. */
static ffetargetOffset ffedata_expected_;	/* Number of elements to
						   init. */
static ffetargetOffset ffedata_number_;	/* #elements inited so far. */
static ffetargetOffset ffedata_offset_;	/* Offset of next element. */
static ffetargetOffset ffedata_symbolsize_;	/* Size of entire sym. */
static ffetargetCharacterSize ffedata_size_;	/* Size of an element. */
static ffetargetCharacterSize ffedata_charexpected_;	/* #char to init. */
static ffetargetCharacterSize ffedata_charnumber_;	/* #chars inited. */
static ffetargetCharacterSize ffedata_charoffset_;	/* Offset of next char. */
static ffedataConvertCache_ ffedata_convert_cache_;	/* Fewer conversions. */
static int ffedata_convert_cache_max_ = 0;	/* #entries available. */
static int ffedata_convert_cache_use_ = 0;	/* #entries in use. */

/* Static functions (internal). */

static bool ffedata_advance_ (void);
static ffebld ffedata_convert_ (ffebld source, ffelexToken source_token,
	    ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt,
				ffeinfoRank rk, ffetargetCharacterSize sz);
static ffetargetInteger1 ffedata_eval_integer1_ (ffebld expr);
static ffetargetOffset ffedata_eval_offset_ (ffebld subscripts,
					     ffebld dims);
static ffetargetCharacterSize ffedata_eval_substr_begin_ (ffebld expr);
static ffetargetCharacterSize ffedata_eval_substr_end_ (ffebld expr,
		    ffetargetCharacterSize min, ffetargetCharacterSize max);
static void ffedata_gather_ (ffestorag mst, ffestorag st);
static void ffedata_pop_ (void);
static void ffedata_push_ (void);
static bool ffedata_value_ (ffebld value, ffelexToken token);

/* Internal macros. */


/* ffedata_begin -- Initialize with list of targets

   ffebld list;
   ffedata_begin(list);	 // ITEM... list of SYMTERs, ARRAYs, SUBSTRs, ...

   Remember the list.  After this call, 0...n calls to ffedata_value must
   follow, and then a single call to ffedata_end.  */

void
ffedata_begin (ffebld list)
{
  assert (ffedata_list_ == NULL);
  ffedata_list_ = list;
  ffedata_symbol_ = NULL;
  ffedata_reported_error_ = FALSE;
  ffedata_reinit_ = FALSE;
  ffedata_advance_ ();
}

/* ffedata_end -- End of initialization sequence

   if (ffedata_end(FALSE))
       // everything's ok

   Make sure the end of the list is valid here.	 */

bool
ffedata_end (bool reported_error, ffelexToken t)
{
  reported_error |= ffedata_reported_error_;

  /* If still targets to initialize, too few initializers, so complain. */

  if ((ffedata_symbol_ != NULL) && !reported_error)
    {
      reported_error = TRUE;
      ffebad_start (FFEBAD_DATA_TOOFEW);
      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_finish ();
    }

  /* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */

  while (ffedata_stack_ != NULL)
    ffedata_pop_ ();

  if (ffedata_list_ != NULL)
    {
      assert (reported_error);
      ffedata_list_ = NULL;
    }

  return TRUE;
}

/* ffedata_gather -- Gather previously disparate initializations into one place

   ffestorag st;  // A typeCBLOCK or typeLOCAL aggregate.
   ffedata_gather(st);

   Prior to this call, st has no init or accretion info, but (presumably
   at least one of) its subordinate storage areas has init or accretion
   info.  After this call, none of the subordinate storage areas has inits,
   because they've all been moved into the newly created init/accretion
   info for st.	 During this call, conflicting inits produce only one
   error message.  */

void
ffedata_gather (ffestorag st)
{
  ffesymbol s;
  ffebld b;

  /* Prepare info on the storage area we're putting init info into. */

  ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
			    &ffedata_storage_units_, ffestorag_basictype (st),
			    ffestorag_kindtype (st));
  ffedata_storage_size_ = ffestorag_size (st) / ffedata_storage_units_;
  assert (ffestorag_size (st) % ffedata_storage_units_ == 0);

  /* If a CBLOCK, gather all the init info for its explicit members. */

  if ((ffestorag_type (st) == FFESTORAG_typeCBLOCK)
      && (ffestorag_symbol (st) != NULL))
    {
      s = ffestorag_symbol (st);
      for (b = ffesymbol_commonlist (s); b != NULL; b = ffebld_trail (b))
	ffedata_gather_ (st,
			 ffesymbol_storage (ffebld_symter (ffebld_head (b))));
    }

  /* For CBLOCK or LOCAL, gather all the init info for equivalenced members. */

  ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st);
}

/* ffedata_value -- Provide some number of initial values

   ffebld value;
   ffelexToken t;  // Points to the value.
   if (ffedata_value(1,value,t))
       // Everything's ok

   Makes sure the value is ok, then remembers it according to the list
   provided to ffedata_begin.  As many instances of the value may be
   supplied as desired, as indicated by the first argument.  */

bool
ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token)
{
  ffetargetIntegerDefault i;

  /* Maybe ignore zero values, to speed up compiling, even though we lose
     checking for multiple initializations for now.  */

  if (!ffe_is_zeros ()
      && (value != NULL)
      && (ffebld_op (value) == FFEBLD_opCONTER)
      && ffebld_constant_is_zero (ffebld_conter (value)))
    value = NULL;
  else if ((value != NULL)
	   && (ffebld_op (value) == FFEBLD_opANY))
    value = NULL;
  else
    {
      /* Must be a constant. */
      assert (value != NULL);
      assert (ffebld_op (value) == FFEBLD_opCONTER);
    }

  /* Later we can optimize certain cases by seeing that the target array can
     take some number of values, and provide this number to _value_. */

  if (rpt == 1)
    ffedata_convert_cache_use_ = -1;	/* Don't bother caching. */
  else
    ffedata_convert_cache_use_ = 0;	/* Maybe use the cache. */

  for (i = 0; i < rpt; ++i)
    {
      if ((ffedata_symbol_ != NULL)
	  && !ffesymbol_is_init (ffedata_symbol_))
	{
	  ffesymbol_signal_change (ffedata_symbol_);
	  ffesymbol_update_init (ffedata_symbol_);
	  if (1 || ffe_is_90 ())
	    ffesymbol_update_save (ffedata_symbol_);
#if FFEGLOBAL_ENABLED
	  if (ffesymbol_common (ffedata_symbol_) != NULL)
	    ffeglobal_init_common (ffesymbol_common (ffedata_symbol_),
				   token);
#endif
	  ffesymbol_signal_unreported (ffedata_symbol_);
	}
      if (!ffedata_value_ (value, token))
	return FALSE;
    }

  return TRUE;
}

/* ffedata_advance_ -- Advance initialization target to next item in list

   if (ffedata_advance_())
       // everything's ok

   Sets common info to characterize the next item in the list.	Handles
   IMPDO constructs accordingly.  Does not handle advances within a single
   item, as in the common extension "DATA CHARTYPE/33,34,35/", where
   CHARTYPE is CHARACTER*3, for example.  */

static bool
ffedata_advance_ ()
{
  ffebld next;

  /* Come here after handling an IMPDO. */

tail_recurse:			/* :::::::::::::::::::: */

  /* Assume we're not going to find a new target for now. */

  ffedata_symbol_ = NULL;

  /* If at the end of the list, we're done. */

  if (ffedata_list_ == NULL)
    {
      ffetargetIntegerDefault newval;

      if (ffedata_stack_ == NULL)
	return TRUE;		/* No IMPDO in progress, we is done! */

      /* Iterate the IMPDO. */

      newval = ffesymbol_value (ffedata_stack_->itervar)
	+ ffedata_stack_->increment;

      /* See if we're still in the loop. */

      if (((ffedata_stack_->increment > 0)
	   ? newval > ffedata_stack_->final
	   : newval < ffedata_stack_->final)
	  || (((ffesymbol_value (ffedata_stack_->itervar) < 0)
	       == (ffedata_stack_->increment < 0))
	      && ((ffesymbol_value (ffedata_stack_->itervar) < 0)
		  != (newval < 0))))	/* Overflow/underflow? */
	{			/* Done with the loop. */
	  ffedata_list_ = ffedata_stack_->outer_list;	/* Restore list. */
	  ffedata_pop_ ();	/* Pop me off the impdo stack. */
	}
      else
	{			/* Still in the loop, reset the list and
				   update the iter var. */
	  ffedata_list_ = ffedata_stack_->my_list;	/* Reset list. */
	  ffesymbol_set_value (ffedata_stack_->itervar, newval);
	}
      goto tail_recurse;	/* :::::::::::::::::::: */
    }

  /* Move to the next item in the list. */

  next = ffebld_head (ffedata_list_);
  ffedata_list_ = ffebld_trail (ffedata_list_);

  /* Really shouldn't happen. */

  if (next == NULL)
    return TRUE;

  /* See what kind of target this is. */

  switch (ffebld_op (next))
    {
    case FFEBLD_opSYMTER:	/* Simple reference to scalar or array. */
      ffedata_symbol_ = ffebld_symter (next);
      ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
	: ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
      if (ffedata_storage_ != NULL)
	{
	  ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
				    &ffedata_storage_units_,
				    ffestorag_basictype (ffedata_storage_),
				    ffestorag_kindtype (ffedata_storage_));
	  ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
	    / ffedata_storage_units_;
	  assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
	}

      if ((ffesymbol_init (ffedata_symbol_) != NULL)
	  || (ffesymbol_accretion (ffedata_symbol_) != NULL)
	  || ((ffedata_storage_ != NULL)
	      && (ffestorag_init (ffedata_storage_) != NULL)))
	{
#if 0
	  ffebad_start (FFEBAD_DATA_REINIT);
	  ffest_ffebad_here_current_stmt (0);
	  ffebad_string (ffesymbol_text (ffedata_symbol_));
	  ffebad_finish ();
	  ffedata_reported_error_ = TRUE;
	  return FALSE;
#else
	  ffedata_reinit_ = TRUE;
	  return TRUE;
#endif
	}
      ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
      ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
      if (ffesymbol_rank (ffedata_symbol_) == 0)
	ffedata_arraysize_ = 1;
      else
	{
	  ffebld size = ffesymbol_arraysize (ffedata_symbol_);

	  assert (size != NULL);
	  assert (ffebld_op (size) == FFEBLD_opCONTER);
	  assert (ffeinfo_basictype (ffebld_info (size))
		  == FFEINFO_basictypeINTEGER);
	  assert (ffeinfo_kindtype (ffebld_info (size))
		  == FFEINFO_kindtypeINTEGERDEFAULT);
	  ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
							       (size));
	}
      ffedata_expected_ = ffedata_arraysize_;
      ffedata_number_ = 0;
      ffedata_offset_ = 0;
      ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
	? ffesymbol_size (ffedata_symbol_) : 1;
      ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
      ffedata_charexpected_ = ffedata_size_;
      ffedata_charnumber_ = 0;
      ffedata_charoffset_ = 0;
      break;

    case FFEBLD_opARRAYREF:	/* Reference to element of array. */
      ffedata_symbol_ = ffebld_symter (ffebld_left (next));
      ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
	: ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
      if (ffedata_storage_ != NULL)
	{
	  ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
				    &ffedata_storage_units_,
				    ffestorag_basictype (ffedata_storage_),
				    ffestorag_kindtype (ffedata_storage_));
	  ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
	    / ffedata_storage_units_;
	  assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
	}

      if ((ffesymbol_init (ffedata_symbol_) != NULL)
	  || ((ffedata_storage_ != NULL)