osprey/kgccfe/gnu/f/data.c

Go to the documentation of this file.

/* data.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996, 2002 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)
        && (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; /* Shouldn't happen in this case... */
      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_ = 1;
      ffedata_number_ = 0;
      ffedata_offset_ = ffedata_eval_offset_ (ffebld_right (next),
            ffesymbol_dims (ffedata_symbol_));
      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_opSUBSTR: /* Substring reference to scalar or array
           element. */
      {
  bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF;
  ffebld colon = ffebld_right (next);

  assert (colon != NULL);

  ffedata_symbol_ = ffebld_symter (ffebld_left (arrayref
                ? ffebld_left (next) : 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)
    && (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_ = arrayref ? 1 : ffedata_arraysize_;
  ffedata_number_ = 0;
  ffedata_offset_ = arrayref ? ffedata_eval_offset_ (ffebld_right
    (ffebld_left (next)), ffesymbol_dims (ffedata_symbol_)) : 0;
  ffedata_size_ = ffesymbol_size (ffedata_symbol_);
  ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
  ffedata_charnumber_ = 0;
  ffedata_charoffset_ = ffedata_eval_substr_begin_ (ffebld_head (colon));
  ffedata_charexpected_ = ffedata_eval_substr_end_ (ffebld_head
        (ffebld_trail (colon)), ffedata_charoffset_,
           ffedata_size_) - ffedata_charoffset_ + 1;
      }
      break;

    case FFEBLD_opIMPDO:  /* Implied-DO construct. */
      {
  ffebld itervar;
  ffebld start;
  ffebld end;
  ffebld incr;
  ffebld item = ffebld_right (next);

  itervar = ffebld_head (item);
  item = ffebld_trail (item);
  start = ffebld_head (item);
  item = ffebld_trail (item);
  end = ffebld_head (item);
  item = ffebld_trail (item);
  incr = ffebld_head (item);

  ffedata_push_ ();
  ffedata_stack_->outer_list = ffedata_list_;
  ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next);

  assert (ffeinfo_basictype (ffebld_info (itervar))
    == FFEINFO_basictypeINTEGER);
  assert (ffeinfo_kindtype (ffebld_info (itervar))
    == FFEINFO_kindtypeINTEGERDEFAULT);
  ffedata_stack_->itervar = ffebld_symter (itervar);

  assert (ffeinfo_basictype (ffebld_info (start))
    == FFEINFO_basictypeINTEGER);
  assert (ffeinfo_kindtype (ffebld_info (start))
    == FFEINFO_kindtypeINTEGERDEFAULT);
  ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start));

  assert (ffeinfo_basictype (ffebld_info (end))
    == FFEINFO_basictypeINTEGER);
  assert (ffeinfo_kindtype (ffebld_info (end))
    == FFEINFO_kindtypeINTEGERDEFAULT);
  ffedata_stack_->final = ffedata_eval_integer1_ (end);

  if (incr == NULL)
    ffedata_stack_->increment = 1;
  else
    {
      assert (ffeinfo_basictype (ffebld_info (incr))
        == FFEINFO_basictypeINTEGER);
      assert (ffeinfo_kindtype (ffebld_info (incr))
        == FFEINFO_kindtypeINTEGERDEFAULT);
      ffedata_stack_->increment = ffedata_eval_integer1_ (incr);
      if (ffedata_stack_->increment == 0)
        {
    ffebad_start (FFEBAD_DATA_ZERO);
    ffest_ffebad_here_current_stmt (0);
    ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
    ffebad_finish ();
    ffedata_pop_ ();
    ffedata_reported_error_ = TRUE;
    return FALSE;
        }
    }

  if ((ffedata_stack_->increment > 0)
      ? ffesymbol_value (ffedata_stack_->itervar)
      > ffedata_stack_->final
      : ffesymbol_value (ffedata_stack_->itervar)
      < ffedata_stack_->final)
    {
      ffedata_reported_error_ = TRUE;
      ffebad_start (FFEBAD_DATA_EMPTY);
      ffest_ffebad_here_current_stmt (0);
      ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
      ffebad_finish ();
      ffedata_pop_ ();
      return FALSE;
    }
      }
      goto tail_recurse;  /* :::::::::::::::::::: */

    case FFEBLD_opANY:
      ffedata_reported_error_ = TRUE;
      return FALSE;

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

  return TRUE;
}

/* ffedata_convert_ -- Convert source expression to given type using cache

   ffebld source;
   ffelexToken source_token;
   ffelexToken dest_token;  // Any appropriate token for "destination".
   ffeinfoBasictype bt;
   ffeinfoKindtype kt;
   ffetargetCharactersize sz;
   source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);

   Like ffeexpr_convert, but calls it only if necessary (if the converted
   expression doesn't already exist in the cache) and then puts the result
   in the cache.  */

static ffebld
ffedata_convert_ (ffebld source, ffelexToken source_token,
      ffelexToken dest_token, ffeinfoBasictype bt,
      ffeinfoKindtype kt, ffeinfoRank rk,
      ffetargetCharacterSize sz)
{
  ffebld converted;
  int i;
  int max;
  ffedataConvertCache_ cache;

  for (i = 0; i < ffedata_convert_cache_use_; ++i)
    if ((bt == ffedata_convert_cache_[i].basic_type)
  && (kt == ffedata_convert_cache_[i].kind_type)
  && (sz == ffedata_convert_cache_[i].size)
  && (rk == ffedata_convert_cache_[i].rank))
      return ffedata_convert_cache_[i].converted;

  converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk,
             sz, FFEEXPR_contextDATA);

  if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_)
    {
      if (ffedata_convert_cache_max_ == 0)
  max = 4;
      else
  max = ffedata_convert_cache_max_ << 1;

      if (max > ffedata_convert_cache_max_)
  {
    cache = (ffedataConvertCache_) malloc_new_ks (malloc_pool_image (),
            "FFEDATA cache", max * sizeof (*cache));
    if (ffedata_convert_cache_max_ != 0)
      {
        memcpy (cache, ffedata_convert_cache_,
          ffedata_convert_cache_max_ * sizeof (*cache));
        malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_,
            ffedata_convert_cache_max_ * sizeof (*cache));
      }
    ffedata_convert_cache_ = cache;
    ffedata_convert_cache_max_ = max;
  }
      else
  return converted; /* In case int overflows! */
    }

  i = ffedata_convert_cache_use_++;

  ffedata_convert_cache_[i].converted = converted;
  ffedata_convert_cache_[i].basic_type = bt;
  ffedata_convert_cache_[i].kind_type = kt;
  ffedata_convert_cache_[i].size = sz;
  ffedata_convert_cache_[i].rank = rk;

  return converted;
}

/* ffedata_eval_integer1_ -- Evaluate expression

   ffetargetIntegerDefault result;
   ffebld expr;  // must be kindtypeINTEGER1.

   result = ffedata_eval_integer1_(expr);

   Evalues the expression (which yields a kindtypeINTEGER1 result) and
   returns the result.  */

static ffetargetIntegerDefault
ffedata_eval_integer1_ (ffebld expr)
{
  ffetargetInteger1 result;
  ffebad error;

  assert (expr != NULL);

  switch (ffebld_op (expr))
    {
    case FFEBLD_opCONTER:
      return ffebld_constant_integer1 (ffebld_conter (expr));

    case FFEBLD_opSYMTER:
      return ffesymbol_value (ffebld_symter (expr));

    case FFEBLD_opUPLUS:
      return ffedata_eval_integer1_ (ffebld_left (expr));

    case FFEBLD_opUMINUS:
      error = ffetarget_uminus_integer1 (&result,
             ffedata_eval_integer1_ (ffebld_left (expr)));
      break;

    case FFEBLD_opADD:
      error = ffetarget_add_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opSUBTRACT:
      error = ffetarget_subtract_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opMULTIPLY:
      error = ffetarget_multiply_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opDIVIDE:
      error = ffetarget_divide_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opPOWER:
      {
  ffebld r = ffebld_right (expr);

  if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
      || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
    error = FFEBAD_DATA_EVAL;
  else
    error = ffetarget_power_integerdefault_integerdefault (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (r));
      }
      break;

#if 0       /* Only for character basictype. */
    case FFEBLD_opCONCATENATE:
      error =;
      break;
#endif

    case FFEBLD_opNOT:
      error = ffetarget_not_integer1 (&result,
             ffedata_eval_integer1_ (ffebld_left (expr)));
      break;

#if 0       /* Only for logical basictype. */
    case FFEBLD_opLT:
      error =;
      break;

    case FFEBLD_opLE:
      error =;
      break;

    case FFEBLD_opEQ:
      error =;
      break;

    case FFEBLD_opNE:
      error =;
      break;

    case FFEBLD_opGT:
      error =;
      break;

    case FFEBLD_opGE:
      error =;
      break;
#endif

    case FFEBLD_opAND:
      error = ffetarget_and_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opOR:
      error = ffetarget_or_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opXOR:
      error = ffetarget_xor_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opEQV:
      error = ffetarget_eqv_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opNEQV:
      error = ffetarget_neqv_integer1 (&result,
        ffedata_eval_integer1_ (ffebld_left (expr)),
            ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opPAREN:
      return ffedata_eval_integer1_ (ffebld_left (expr));

#if 0       /* ~~ no idea how to do this */
    case FFEBLD_opPERCENT_LOC:
      error =;
      break;
#endif

#if 0       /* not allowed by ANSI, but perhaps as an
           extension someday? */
    case FFEBLD_opCONVERT:
      switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  {
  case FFEINFO_basictypeINTEGER:
    switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
      {
      default:
        error = FFEBAD_DATA_EVAL;
        break;
      }
    break;

  case FFEINFO_basictypeREAL:
    switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
      {
      default:
        error = FFEBAD_DATA_EVAL;
        break;
      }
    break;
  }
      break;
#endif

#if 0       /* not valid ops */
    case FFEBLD_opREPEAT:
      error =;
      break;

    case FFEBLD_opBOUNDS:
      error =;
      break;
#endif

#if 0       /* not allowed by ANSI, but perhaps as an
           extension someday? */
    case FFEBLD_opFUNCREF:
      error =;
      break;
#endif

#if 0       /* not valid ops */
    case FFEBLD_opSUBRREF:
      error =;
      break;

    case FFEBLD_opARRAYREF:
      error =;
      break;
#endif

#if 0       /* not valid for integer1 */
    case FFEBLD_opSUBSTR:
      error =;
      break;
#endif

    default:
      error = FFEBAD_DATA_EVAL;
      break;
    }

  if (error != FFEBAD)
    {
      ffebad_start (error);
      ffest_ffebad_here_current_stmt (0);
      ffebad_finish ();
      result = 0;
    }

  return result;
}

/* ffedata_eval_offset_ -- Evaluate offset info array

   ffetargetOffset offset;  // 0...max-1.
   ffebld subscripts;  // an opITEM list of subscript exprs.
   ffebld dims;  // an opITEM list of opBOUNDS exprs.

   result = ffedata_eval_offset_(expr);

   Evalues the expression (which yields a kindtypeINTEGER1 result) and
   returns the result.  */

static ffetargetOffset
ffedata_eval_offset_ (ffebld subscripts, ffebld dims)
{
  ffetargetIntegerDefault offset = 0;
  ffetargetIntegerDefault width = 1;
  ffetargetIntegerDefault value;
  ffetargetIntegerDefault lowbound;
  ffetargetIntegerDefault highbound;
  ffetargetOffset final;
  ffebld subscript;
  ffebld dim;
  ffebld low;
  ffebld high;
  int rank = 0;
  bool ok;

  while (subscripts != NULL)
    {
      ffeinfoKindtype sub_kind, low_kind, hi_kind;
      ffebld sub1, low1, hi1;

      ++rank;
      assert (dims != NULL);

      subscript = ffebld_head (subscripts);
      dim = ffebld_head (dims);

      assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
      if (ffebld_op (subscript) == FFEBLD_opCONTER)
  {
    /* Force to default - it's a constant expression !  */
    sub_kind = ffeinfo_kindtype (ffebld_info (subscript));
    sub1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
       sub_kind == FFEINFO_kindtypeINTEGER2 ? subscript->u.conter.expr->u.integer2 :
       sub_kind == FFEINFO_kindtypeINTEGER3 ? subscript->u.conter.expr->u.integer3 :
       sub_kind == FFEINFO_kindtypeINTEGER4 ? subscript->u.conter.expr->u.integer4 :
      subscript->u.conter.expr->u.integer1), NULL);
    value = ffedata_eval_integer1_ (sub1);
  }
      else
  value = ffedata_eval_integer1_ (subscript);

      assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
      low = ffebld_left (dim);
      high = ffebld_right (dim);

      if (low == NULL)
  lowbound = 1;
      else
  {
    assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
    if (ffebld_op (low) == FFEBLD_opCONTER)
      {
        /* Force to default - it's a constant expression !  */
        low_kind = ffeinfo_kindtype (ffebld_info (low));
        low1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
      low_kind == FFEINFO_kindtypeINTEGER2 ? low->u.conter.expr->u.integer2 :
      low_kind == FFEINFO_kindtypeINTEGER3 ? low->u.conter.expr->u.integer3 :
      low_kind == FFEINFO_kindtypeINTEGER4 ? low->u.conter.expr->u.integer4 :
        low->u.conter.expr->u.integer1), NULL);
         lowbound = ffedata_eval_integer1_ (low1);
       }
     else
       lowbound = ffedata_eval_integer1_ (low);
  }

      assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
      if (ffebld_op (high) == FFEBLD_opCONTER)
  {
    /* Force to default - it's a constant expression !  */
    hi_kind = ffeinfo_kindtype (ffebld_info (high));
    hi1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
       hi_kind == FFEINFO_kindtypeINTEGER2 ? high->u.conter.expr->u.integer2 :
       hi_kind == FFEINFO_kindtypeINTEGER3 ? high->u.conter.expr->u.integer3 :
       hi_kind == FFEINFO_kindtypeINTEGER4 ? high->u.conter.expr->u.integer4 :
      high->u.conter.expr->u.integer1), NULL);
    highbound = ffedata_eval_integer1_ (hi1);
  }
      else
  highbound = ffedata_eval_integer1_ (high);

      if ((value < lowbound) || (value > highbound))
  {
    char rankstr[10];

    sprintf (rankstr, "%d", rank);
    value = lowbound;
    ffebad_start (FFEBAD_DATA_SUBSCRIPT);
    ffebad_string (ffesymbol_text (ffedata_symbol_));
    ffebad_string (rankstr);
    ffebad_finish ();
  }

      subscripts = ffebld_trail (subscripts);
      dims = ffebld_trail (dims);

      offset += width * (value - lowbound);
      if (subscripts != NULL)
  width *= highbound - lowbound + 1;
    }

  assert (dims == NULL);

  ok = ffetarget_offset (&final, offset);
  assert (ok);

  return final;
}

/* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference

   ffetargetCharacterSize beginpoint;
   ffebld endval;  // head(colon).

   beginpoint = ffedata_eval_substr_end_(endval);

   If beginval is NULL, returns 0.  Otherwise makes sure beginval is
   kindtypeINTEGERDEFAULT, makes sure its value is > 0,
   and returns its value minus one, or issues an error message.  */

static ffetargetCharacterSize
ffedata_eval_substr_begin_ (ffebld expr)
{
  ffetargetIntegerDefault val;

  if (expr == NULL)
    return 0;

  assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
  assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);

  val = ffedata_eval_integer1_ (expr);

  if (val < 1)
    {
      val = 1;
      ffebad_start (FFEBAD_DATA_RANGE);
      ffest_ffebad_here_current_stmt (0);
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_finish ();
      ffedata_reported_error_ = TRUE;
    }

  return val - 1;
}

/* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference

   ffetargetCharacterSize endpoint;
   ffebld endval;  // head(trail(colon)).
   ffetargetCharacterSize min;  // beginpoint of substr reference.
   ffetargetCharacterSize max;  // size of entity.

   endpoint = ffedata_eval_substr_end_(endval,dflt);

   If endval is NULL, returns max.  Otherwise makes sure endval is
   kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
   and returns its value minus one, or issues an error message.  */

static ffetargetCharacterSize
ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
        ffetargetCharacterSize max)
{
  ffetargetIntegerDefault val;

  if (expr == NULL)
    return max - 1;

  assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
  assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);

  val = ffedata_eval_integer1_ (expr);

  if ((val < (ffetargetIntegerDefault) min)
      || (val > (ffetargetIntegerDefault) max))
    {
      val = 1;
      ffebad_start (FFEBAD_DATA_RANGE);
      ffest_ffebad_here_current_stmt (0);
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_finish ();
      ffedata_reported_error_ = TRUE;
    }

  return val - 1;
}

/* ffedata_gather_ -- Gather initial values for sym into master sym inits

   ffestorag mst;  // A typeCBLOCK or typeLOCAL aggregate.
   ffestorag st;  // A typeCOMMON or typeEQUIV member.
   ffedata_gather_(mst,st);

   If st has any initialization info, transfer that info into mst and
   clear st's info.  */

static void
ffedata_gather_ (ffestorag mst, ffestorag st)
{
  ffesymbol s;
  ffesymbol s_whine;    /* Symbol to complain about in diagnostics. */
  ffebld b;
  ffetargetOffset offset;
  ffetargetOffset units_expected;
  ffebitCount actual;
  ffebldConstantArray array;
  ffebld accter;
  ffetargetCopyfunc fn;
  void *ptr1;
  void *ptr2;
  size_t size;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffeinfoBasictype ign_bt;
  ffeinfoKindtype ign_kt;
  ffetargetAlign units;
  ffebit bits;
  ffetargetOffset source_offset;
  bool whine = FALSE;

  if (st == NULL)
    return;     /* Nothing to do. */

  s = ffestorag_symbol (st);

  assert (s != NULL);   /* Must have a corresponding symbol (else how
           inited?). */
  assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */
  assert (ffestorag_accretion (st) == NULL);

  if ((((b = ffesymbol_init (s)) == NULL)
       && ((b = ffesymbol_accretion (s)) == NULL))
      || (ffebld_op (b) == FFEBLD_opANY)
      || ((ffebld_op (b) == FFEBLD_opCONVERT)
    && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
    return;     /* Nothing to do. */

  /* b now holds the init/accretion expr. */

  ffesymbol_set_init (s, NULL);
  ffesymbol_set_accretion (s, NULL);
  ffesymbol_set_accretes (s, 0);

  s_whine = ffestorag_symbol (mst);
  if (s_whine == NULL)
    s_whine = s;

  /* Make sure we haven't fully accreted during an array init. */

  if (ffestorag_init (mst) != NULL)
    {
      ffebad_start (FFEBAD_DATA_MULTIPLE);
      ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
      ffebad_string (ffesymbol_text (s_whine));
      ffebad_finish ();
      return;
    }

  bt = ffeinfo_basictype (ffebld_info (b));
  kt = ffeinfo_kindtype (ffebld_info (b));

  /* Calculate offset for aggregate area. */

  ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
    ? ffebld_size (b) : 1;
  ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
          kt);/* Find out unit size of source datum. */
  assert (units % ffedata_storage_units_ == 0);
  units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
  offset = (ffestorag_offset (st) - ffestorag_offset (mst))
    / ffedata_storage_units_;

  /* Does an accretion array exist?  If not, create it. */

  if (ffestorag_accretion (mst) == NULL)
    {
#if FFEDATA_sizeTOO_BIG_INIT_ != 0
      if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
  {
    char bignum[40];

    sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
    ffebad_start (FFEBAD_TOO_BIG_INIT);
    ffebad_here (0, ffesymbol_where_line (s_whine),
           ffesymbol_where_column (s_whine));
    ffebad_string (ffesymbol_text (s_whine));
    ffebad_string (bignum);
    ffebad_finish ();
  }
#endif
      array = ffebld_constantarray_new (ffedata_storage_bt_,
        ffedata_storage_kt_, ffedata_storage_size_);
      accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
                 ffedata_storage_size_));
      ffebld_set_info (accter, ffeinfo_new
           (ffedata_storage_bt_,
      ffedata_storage_kt_,
      1,
      FFEINFO_kindENTITY,
      FFEINFO_whereCONSTANT,
      (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
      ? 1 : FFETARGET_charactersizeNONE));
      ffestorag_set_accretion (mst, accter);
      ffestorag_set_accretes (mst, ffedata_storage_size_);
    }
  else
    {
      accter = ffestorag_accretion (mst);
      assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
      array = ffebld_accter (accter);
    }

  /* Put value in accretion array at desired offset. */

  fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
               bt, kt);

  switch (ffebld_op (b))
    {
    case FFEBLD_opCONTER:
      ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
            ffedata_storage_kt_, offset,
         ffebld_constant_ptr_to_union (ffebld_conter (b)),
            bt, kt);
      (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
           operation. */
      ffebit_count (ffebld_accter_bits (accter),
        offset, FALSE, units_expected, &actual);  /* How many FALSE? */
      if (units_expected != (ffetargetOffset) actual)
  {
    ffebad_start (FFEBAD_DATA_MULTIPLE);
    ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
    ffebad_string (ffesymbol_text (s));
    ffebad_finish ();
  }
      ffestorag_set_accretes (mst,
            ffestorag_accretes (mst)
            - actual);  /* Decrement # of values
               actually accreted. */
      ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);

      /* If done accreting for this storage area, establish as initialized. */

      if (ffestorag_accretes (mst) == 0)
  {
    ffestorag_set_init (mst, accter);
    ffestorag_set_accretion (mst, NULL);
    ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
    ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
    ffebld_set_arrter (ffestorag_init (mst),
           ffebld_accter (ffestorag_init (mst)));
    ffebld_arrter_set_size (ffestorag_init (mst),
          ffedata_storage_size_);
    ffebld_arrter_set_pad (ffestorag_init (mst), 0);
    ffecom_notify_init_storage (mst);
  }

      return;

    case FFEBLD_opARRTER:
      ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
           ffedata_storage_kt_, offset, ffebld_arrter (b),
              bt, kt);
      size *= ffebld_arrter_size (b);
      units_expected *= ffebld_arrter_size (b);
      (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
           operation. */
      ffebit_count (ffebld_accter_bits (accter),
        offset, FALSE, units_expected, &actual);  /* How many FALSE? */
      if (units_expected != (ffetargetOffset) actual)
  {
    ffebad_start (FFEBAD_DATA_MULTIPLE);
    ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
    ffebad_string (ffesymbol_text (s));
    ffebad_finish ();
  }
      ffestorag_set_accretes (mst,
            ffestorag_accretes (mst)
            - actual);  /* Decrement # of values
               actually accreted. */
      ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);

      /* If done accreting for this storage area, establish as initialized. */

      if (ffestorag_accretes (mst) == 0)
  {
    ffestorag_set_init (mst, accter);
    ffestorag_set_accretion (mst, NULL);
    ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
    ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
    ffebld_set_arrter (ffestorag_init (mst),
           ffebld_accter (ffestorag_init (mst)));
    ffebld_arrter_set_size (ffestorag_init (mst),
          ffedata_storage_size_);
    ffebld_arrter_set_pad (ffestorag_init (mst), 0);
    ffecom_notify_init_storage (mst);
  }

      return;

    case FFEBLD_opACCTER:
      ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
           ffedata_storage_kt_, offset, ffebld_accter (b),
              bt, kt);
      bits = ffebld_accter_bits (b);
      source_offset = 0;

      for (;;)
  {
    ffetargetOffset unexp;
    ffetargetOffset siz;
    ffebitCount length;
    bool value;

    ffebit_test (bits, source_offset, &value, &length);
    if (length == 0)
      break;    /* Exit the loop early. */
    siz = size * length;
    unexp = units_expected * length;
    if (value)
      {
        (*fn) (ptr1, ptr2, siz);  /* Does memcpy-like operation. */
        ffebit_count (ffebld_accter_bits (accter),  /* How many FALSE? */
          offset, FALSE, unexp, &actual);
        if (!whine && (unexp != (ffetargetOffset) actual))
    {
      whine = TRUE; /* Don't whine more than once for one gather. */
      ffebad_start (FFEBAD_DATA_MULTIPLE);
      ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
      ffebad_string (ffesymbol_text (s));
      ffebad_finish ();
    }
        ffestorag_set_accretes (mst,
              ffestorag_accretes (mst)
              - actual);  /* Decrement # of values
                 actually accreted. */
        ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
      }
    source_offset += length;
    offset += unexp;
    ptr1 = ((char *) ptr1) + siz;
    ptr2 = ((char *) ptr2) + siz;
  }

      /* If done accreting for this storage area, establish as initialized. */

      if (ffestorag_accretes (mst) == 0)
  {
    ffestorag_set_init (mst, accter);
    ffestorag_set_accretion (mst, NULL);
    ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
    ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
    ffebld_set_arrter (ffestorag_init (mst),
           ffebld_accter (ffestorag_init (mst)));
    ffebld_arrter_set_size (ffestorag_init (mst),
          ffedata_storage_size_);
    ffebld_arrter_set_pad (ffestorag_init (mst), 0);
    ffecom_notify_init_storage (mst);
  }

      return;

    default:
      assert ("bad init op in gather_" == NULL);
      return;
    }
}

/* ffedata_pop_ -- Pop an impdo stack entry

   ffedata_pop_();  */

static void
ffedata_pop_ ()
{
  ffedataImpdo_ victim = ffedata_stack_;

  assert (victim != NULL);

  ffedata_stack_ = ffedata_stack_->outer;

  malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
}

/* ffedata_push_ -- Push an impdo stack entry

   ffedata_push_();  */

static void
ffedata_push_ ()
{
  ffedataImpdo_ baby;

  baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));

  baby->outer = ffedata_stack_;
  ffedata_stack_ = baby;
}

/* ffedata_value_ -- Provide an initial value

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

   Makes sure the value is ok, then remembers it according to the list
   provided to ffedata_begin.  */

static bool
ffedata_value_ (ffebld value, ffelexToken token)
{

  /* If already reported an error, don't do anything. */

  if (ffedata_reported_error_)
    return FALSE;

  /* If the value is an error marker, remember we've seen one and do nothing
     else. */

  if ((value != NULL)
      && (ffebld_op (value) == FFEBLD_opANY))
    {
      ffedata_reported_error_ = TRUE;
      return FALSE;
    }

  /* If too many values (no more targets), complain. */

  if (ffedata_symbol_ == NULL)
    {
      ffebad_start (FFEBAD_DATA_TOOMANY);
      ffebad_here (0, ffelex_token_where_line (token),
       ffelex_token_where_column (token));
      ffebad_finish ();
      ffedata_reported_error_ = TRUE;
      return FALSE;
    }

  /* If ffedata_advance_ wanted to register a complaint, do it now
     that we have the token to point at instead of just the start
     of the whole statement.  */

  if (ffedata_reinit_)
    {
      ffebad_start (FFEBAD_DATA_REINIT);
      ffebad_here (0, ffelex_token_where_line (token),
       ffelex_token_where_column (token));
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_finish ();
      ffedata_reported_error_ = TRUE;
      return FALSE;
    }

#if FFEGLOBAL_ENABLED
  if (ffesymbol_common (ffedata_symbol_) != NULL)
    ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token);
#endif

  /* Convert value to desired type. */

  if (value != NULL)
    {
      if (ffedata_convert_cache_use_ == -1)
  value = ffeexpr_convert
    (value, token, NULL, ffedata_basictype_,
     ffedata_kindtype_, 0,
     (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
     ? ffedata_charexpected_ : FFETARGET_charactersizeNONE,
     FFEEXPR_contextDATA);
      else        /* Use the cache. */
  value = ffedata_convert_
    (value, token, NULL, ffedata_basictype_,
     ffedata_kindtype_, 0,
     (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
     ? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
    }

  /* If we couldn't, bug out. */

  if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
    {
      ffedata_reported_error_ = TRUE;
      return FALSE;
    }

  /* Handle the case where initializes go to a parent's storage area. */

  if (ffedata_storage_ != NULL)
    {
      ffetargetOffset offset;
      ffetargetOffset units_expected;
      ffebitCount actual;
      ffebldConstantArray array;
      ffebld accter;
      ffetargetCopyfunc fn;
      void *ptr1;
      void *ptr2;
      size_t size;
      ffeinfoBasictype ign_bt;
      ffeinfoKindtype ign_kt;
      ffetargetAlign units;

      /* Make sure we haven't fully accreted during an array init. */

      if (ffestorag_init (ffedata_storage_) != NULL)
  {
    ffebad_start (FFEBAD_DATA_MULTIPLE);
    ffebad_here (0, ffelex_token_where_line (token),
           ffelex_token_where_column (token));
    ffebad_string (ffesymbol_text (ffedata_symbol_));
    ffebad_finish ();
    ffedata_reported_error_ = TRUE;
    return FALSE;
  }

      /* Calculate offset. */

      offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;

      /* Is offset within range?  If not, whine, but don't do anything else. */

      if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
  {
    ffebad_start (FFEBAD_DATA_RANGE);
    ffest_ffebad_here_current_stmt (0);
    ffebad_string (ffesymbol_text (ffedata_symbol_));
    ffebad_finish ();
    ffedata_reported_error_ = TRUE;
    return FALSE;
  }

      /* Now calculate offset for aggregate area. */

      ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
        ffedata_kindtype_); /* Find out unit size of
                 source datum. */
      assert (units % ffedata_storage_units_ == 0);
      units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
      offset *= units / ffedata_storage_units_;
      offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_))
     - ffestorag_offset (ffedata_storage_))
  / ffedata_storage_units_;

      assert (offset + units_expected - 1 <= ffedata_storage_size_);

      /* Does an accretion array exist?  If not, create it. */

      if (value != NULL)
  {
    if (ffestorag_accretion (ffedata_storage_) == NULL)
      {
#if FFEDATA_sizeTOO_BIG_INIT_ != 0
        if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
    {
      char bignum[40];

      sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
      ffebad_start (FFEBAD_TOO_BIG_INIT);
      ffebad_here (0, ffelex_token_where_line (token),
             ffelex_token_where_column (token));
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_string (bignum);
      ffebad_finish ();
    }
#endif
        array = ffebld_constantarray_new
    (ffedata_storage_bt_, ffedata_storage_kt_,
     ffedata_storage_size_);
        accter = ffebld_new_accter (array,
            ffebit_new (ffe_pool_program_unit (),
                  ffedata_storage_size_));
        ffebld_set_info (accter, ffeinfo_new
             (ffedata_storage_bt_,
        ffedata_storage_kt_,
        1,
        FFEINFO_kindENTITY,
        FFEINFO_whereCONSTANT,
        (ffedata_basictype_
         == FFEINFO_basictypeCHARACTER)
        ? 1 : FFETARGET_charactersizeNONE));
        ffestorag_set_accretion (ffedata_storage_, accter);
        ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_);
      }
    else
      {
        accter = ffestorag_accretion (ffedata_storage_);
        assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
        array = ffebld_accter (accter);
      }

    /* Put value in accretion array at desired offset. */

    fn = ffetarget_aggregate_ptr_memcpy
      (ffedata_storage_bt_, ffedata_storage_kt_,
       ffedata_basictype_, ffedata_kindtype_);
    ffebld_constantarray_prepare
      (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
       ffedata_storage_kt_, offset,
       ffebld_constant_ptr_to_union (ffebld_conter (value)),
       ffedata_basictype_, ffedata_kindtype_);
    (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
             operation. */
    ffebit_count (ffebld_accter_bits (accter),
      offset, FALSE, units_expected,
      &actual); /* How many FALSE? */
    if (units_expected != (ffetargetOffset) actual)
      {
        ffebad_start (FFEBAD_DATA_MULTIPLE);
        ffebad_here (0, ffelex_token_where_line (token),
         ffelex_token_where_column (token));
        ffebad_string (ffesymbol_text (ffedata_symbol_));
        ffebad_finish ();
      }
    ffestorag_set_accretes (ffedata_storage_,
          ffestorag_accretes (ffedata_storage_)
          - actual);  /* Decrement # of values
               actually accreted. */
    ffebit_set (ffebld_accter_bits (accter), offset,
          1, units_expected);

    /* If done accreting for this storage area, establish as
       initialized. */

    if (ffestorag_accretes (ffedata_storage_) == 0)
      {
        ffestorag_set_init (ffedata_storage_, accter);
        ffestorag_set_accretion (ffedata_storage_, NULL);
        ffebit_kill (ffebld_accter_bits
         (ffestorag_init (ffedata_storage_)));
        ffebld_set_op (ffestorag_init (ffedata_storage_),
           FFEBLD_opARRTER);
        ffebld_set_arrter
    (ffestorag_init (ffedata_storage_),
     ffebld_accter (ffestorag_init (ffedata_storage_)));
        ffebld_arrter_set_size (ffestorag_init (ffedata_storage_),
              ffedata_storage_size_);
        ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_),
             0);
        ffecom_notify_init_storage (ffedata_storage_);
      }
  }

      /* If still accreting, adjust specs accordingly and return. */

      if (++ffedata_number_ < ffedata_expected_)
  {
    ++ffedata_offset_;
    return TRUE;
  }

      return ffedata_advance_ ();
    }

  /* Figure out where the value goes -- in an accretion array or directly
     into the final initial-value slot for the symbol. */

  if ((ffedata_number_ != 0)
      || (ffedata_arraysize_ > 1)
      || (ffedata_charnumber_ != 0)
      || (ffedata_size_ > ffedata_charexpected_))
    {       /* Accrete this value. */
      ffetargetOffset offset;
      ffebitCount actual;
      ffebldConstantArray array;
      ffebld accter = NULL;

      /* Calculate offset. */

      offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;

      /* Is offset within range?  If not, whine, but don't do anything else. */

      if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
  {
    ffebad_start (FFEBAD_DATA_RANGE);
    ffest_ffebad_here_current_stmt (0);
    ffebad_string (ffesymbol_text (ffedata_symbol_));
    ffebad_finish ();
    ffedata_reported_error_ = TRUE;
    return FALSE;
  }

      /* Does an accretion array exist?  If not, create it. */

      if (value != NULL)
  {
    if (ffesymbol_accretion (ffedata_symbol_) == NULL)
      {
#if FFEDATA_sizeTOO_BIG_INIT_ != 0
        if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ )
    {
      char bignum[40];

      sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_);
      ffebad_start (FFEBAD_TOO_BIG_INIT);
      ffebad_here (0, ffelex_token_where_line (token),
             ffelex_token_where_column (token));
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_string (bignum);
      ffebad_finish ();
    }
#endif
        array = ffebld_constantarray_new
    (ffedata_basictype_, ffedata_kindtype_,
     ffedata_symbolsize_);
        accter = ffebld_new_accter (array,
            ffebit_new (ffe_pool_program_unit (),
                  ffedata_symbolsize_));
        ffebld_set_info (accter, ffeinfo_new
             (ffedata_basictype_,
        ffedata_kindtype_,
        1,
        FFEINFO_kindENTITY,
        FFEINFO_whereCONSTANT,
        (ffedata_basictype_
         == FFEINFO_basictypeCHARACTER)
        ? 1 : FFETARGET_charactersizeNONE));
        ffesymbol_set_accretion (ffedata_symbol_, accter);
        ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_);
      }
    else
      {
        accter = ffesymbol_accretion (ffedata_symbol_);
        assert (ffedata_symbolsize_
          == (ffetargetOffset) ffebld_accter_size (accter));
        array = ffebld_accter (accter);
      }

    /* Put value in accretion array at desired offset. */

    ffebld_constantarray_put
      (array, ffedata_basictype_, ffedata_kindtype_,
       offset, ffebld_constant_union (ffebld_conter (value)));
    ffebit_count (ffebld_accter_bits (accter), offset, FALSE,
      ffedata_charexpected_,
      &actual); /* How many FALSE? */
    if (actual != (unsigned long int) ffedata_charexpected_)
      {
        ffebad_start (FFEBAD_DATA_MULTIPLE);
        ffebad_here (0, ffelex_token_where_line (token),
         ffelex_token_where_column (token));
        ffebad_string (ffesymbol_text (ffedata_symbol_));
        ffebad_finish ();
      }
    ffesymbol_set_accretes (ffedata_symbol_,
          ffesymbol_accretes (ffedata_symbol_)
          - actual);  /* Decrement # of values
               actually accreted. */
    ffebit_set (ffebld_accter_bits (accter), offset,
          1, ffedata_charexpected_);
    ffesymbol_signal_unreported (ffedata_symbol_);
  }

      /* If still accreting, adjust specs accordingly and return. */

      if (++ffedata_number_ < ffedata_expected_)
  {
    ++ffedata_offset_;
    return TRUE;
  }

      /* Else, if done accreting for this symbol, establish as initialized. */

      if ((value != NULL)
    && (ffesymbol_accretes (ffedata_symbol_) == 0))
  {
    ffesymbol_set_init (ffedata_symbol_, accter);
    ffesymbol_set_accretion (ffedata_symbol_, NULL);
    ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_)));
    ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER);
    ffebld_set_arrter (ffesymbol_init (ffedata_symbol_),
        ffebld_accter (ffesymbol_init (ffedata_symbol_)));
    ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_),
          ffedata_symbolsize_);
    ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0);
    ffecom_notify_init_symbol (ffedata_symbol_);
  }
    }
  else if (value != NULL)
    {
      /* Simple, direct, one-shot assignment. */
      ffesymbol_set_init (ffedata_symbol_, value);
      ffecom_notify_init_symbol (ffedata_symbol_);
    }

  /* Call on advance function to get next target in list. */

  return ffedata_advance_ ();
}

---