contrib/gcc/f/data.c

   1 /* data.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23
  24    Description:
  25       Do the tough things for DATA statement (and INTEGER FOO/.../-style
  26       initializations), like implied-DO and suchlike.
  27
  28    Modifications:
  29 */
  30
  31 /* Include files. */
  32
  33 #include "proj.h"
  34 #include "data.h"
  35 #include "bit.h"
  36 #include "bld.h"
  37 #include "com.h"
  38 #include "expr.h"
  39 #include "global.h"
  40 #include "malloc.h"
  41 #include "st.h"
  42 #include "storag.h"
  43 #include "top.h"
  44
  45 /* Externals defined here. */
  46
  47
  48 /* Simple definitions and enumerations. */
  49
  50 /* I picked this value as one that, when plugged into a couple of small
  51    but nearly identical test cases I have called BIG-0.f and BIG-1.f,
  52    causes BIG-1.f to take about 10 times as long (elapsed) to compile
  53    (in f771 only) as BIG-0.f.  These test cases differ in that BIG-0.f
  54    doesn't put the one initialized variable in a common area that has
  55    a large uninitialized array in it, while BIG-1.f does.  The size of
  56    the array is this many elements, as long as they all are INTEGER
  57    type.  Note that, as of 0.5.18, sparse cases are better handled,
  58    so BIG-2.f now is used; it provides nonzero initial
  59    values for all elements of the same array BIG-0 has.  */
  60 #ifndef FFEDATA_sizeTOO_BIG_INIT_
  61 #define FFEDATA_sizeTOO_BIG_INIT_ 75*1024
  62 #endif
  63
  64 /* Internal typedefs. */
  65
  66 typedef struct _ffedata_convert_cache_ *ffedataConvertCache_;
  67 typedef struct _ffedata_impdo_ *ffedataImpdo_;
  68
  69 /* Private include files. */
  70
  71
  72 /* Internal structure definitions. */
  73
  74 struct _ffedata_convert_cache_
  75   {
  76     ffebld converted;           /* Results of converting expr to following
  77                                    type. */
  78     ffeinfoBasictype basic_type;
  79     ffeinfoKindtype kind_type;
  80     ffetargetCharacterSize size;
  81     ffeinfoRank rank;
  82   };
  83
  84 struct _ffedata_impdo_
  85   {
  86     ffedataImpdo_ outer;        /* Enclosing IMPDO construct. */
  87     ffebld outer_list;          /* Item after my IMPDO on the outer list. */
  88     ffebld my_list;             /* Beginning of list in my IMPDO. */
  89     ffesymbol itervar;          /* Iteration variable. */
  90     ffetargetIntegerDefault increment;
  91     ffetargetIntegerDefault final;
  92   };
  93
  94 /* Static objects accessed by functions in this module. */
  95
  96 static ffedataImpdo_ ffedata_stack_ = NULL;
  97 static ffebld ffedata_list_ = NULL;
  98 static bool ffedata_reinit_;    /* value_ should report REINIT error. */
  99 static bool ffedata_reported_error_;    /* Error has been reported. */
 100 static ffesymbol ffedata_symbol_ = NULL;        /* Symbol being initialized. */
 101 static ffeinfoBasictype ffedata_basictype_;     /* Info on symbol. */
 102 static ffeinfoKindtype ffedata_kindtype_;
 103 static ffestorag ffedata_storage_;      /* If non-NULL, inits go into this parent. */
 104 static ffeinfoBasictype ffedata_storage_bt_;    /* Info on storage. */
 105 static ffeinfoKindtype ffedata_storage_kt_;
 106 static ffetargetOffset ffedata_storage_size_;   /* Size of entire storage. */
 107 static ffetargetAlign ffedata_storage_units_;   /* #units per storage unit. */
 108 static ffetargetOffset ffedata_arraysize_;      /* Size of array being
 109                                                    inited. */
 110 static ffetargetOffset ffedata_expected_;       /* Number of elements to
 111                                                    init. */
 112 static ffetargetOffset ffedata_number_; /* #elements inited so far. */
 113 static ffetargetOffset ffedata_offset_; /* Offset of next element. */
 114 static ffetargetOffset ffedata_symbolsize_;     /* Size of entire sym. */
 115 static ffetargetCharacterSize ffedata_size_;    /* Size of an element. */
 116 static ffetargetCharacterSize ffedata_charexpected_;    /* #char to init. */
 117 static ffetargetCharacterSize ffedata_charnumber_;      /* #chars inited. */
 118 static ffetargetCharacterSize ffedata_charoffset_;      /* Offset of next char. */
 119 static ffedataConvertCache_ ffedata_convert_cache_;     /* Fewer conversions. */
 120 static int ffedata_convert_cache_max_ = 0;      /* #entries available. */
 121 static int ffedata_convert_cache_use_ = 0;      /* #entries in use. */
 122
 123 /* Static functions (internal). */
 124
 125 static bool ffedata_advance_ (void);
 126 static ffebld ffedata_convert_ (ffebld source, ffelexToken source_token,
 127             ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt,
 128                                 ffeinfoRank rk, ffetargetCharacterSize sz);
 129 static ffetargetInteger1 ffedata_eval_integer1_ (ffebld expr);
 130 static ffetargetOffset ffedata_eval_offset_ (ffebld subscripts,
 131                                              ffebld dims);
 132 static ffetargetCharacterSize ffedata_eval_substr_begin_ (ffebld expr);
 133 static ffetargetCharacterSize ffedata_eval_substr_end_ (ffebld expr,
 134                     ffetargetCharacterSize min, ffetargetCharacterSize max);
 135 static void ffedata_gather_ (ffestorag mst, ffestorag st);
 136 static void ffedata_pop_ (void);
 137 static void ffedata_push_ (void);
 138 static bool ffedata_value_ (ffebld value, ffelexToken token);
 139
 140 /* Internal macros. */
 141 \f
 142
 143 /* ffedata_begin -- Initialize with list of targets
 144
 145    ffebld list;
 146    ffedata_begin(list);  // ITEM... list of SYMTERs, ARRAYs, SUBSTRs, ...
 147
 148    Remember the list.  After this call, 0...n calls to ffedata_value must
 149    follow, and then a single call to ffedata_end.  */
 150
 151 void
 152 ffedata_begin (ffebld list)
 153 {
 154   assert (ffedata_list_ == NULL);
 155   ffedata_list_ = list;
 156   ffedata_symbol_ = NULL;
 157   ffedata_reported_error_ = FALSE;
 158   ffedata_reinit_ = FALSE;
 159   ffedata_advance_ ();
 160 }
 161
 162 /* ffedata_end -- End of initialization sequence
 163
 164    if (ffedata_end(FALSE))
 165        // everything's ok
 166
 167    Make sure the end of the list is valid here.  */
 168
 169 bool
 170 ffedata_end (bool reported_error, ffelexToken t)
 171 {
 172   reported_error |= ffedata_reported_error_;
 173
 174   /* If still targets to initialize, too few initializers, so complain. */
 175
 176   if ((ffedata_symbol_ != NULL) && !reported_error)
 177     {
 178       reported_error = TRUE;
 179       ffebad_start (FFEBAD_DATA_TOOFEW);
 180       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
 181       ffebad_string (ffesymbol_text (ffedata_symbol_));
 182       ffebad_finish ();
 183     }
 184
 185   /* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */
 186
 187   while (ffedata_stack_ != NULL)
 188     ffedata_pop_ ();
 189
 190   if (ffedata_list_ != NULL)
 191     {
 192       assert (reported_error);
 193       ffedata_list_ = NULL;
 194     }
 195
 196   return TRUE;
 197 }
 198
 199 /* ffedata_gather -- Gather previously disparate initializations into one place
 200
 201    ffestorag st;  // A typeCBLOCK or typeLOCAL aggregate.
 202    ffedata_gather(st);
 203
 204    Prior to this call, st has no init or accretion info, but (presumably
 205    at least one of) its subordinate storage areas has init or accretion
 206    info.  After this call, none of the subordinate storage areas has inits,
 207    because they've all been moved into the newly created init/accretion
 208    info for st.  During this call, conflicting inits produce only one
 209    error message.  */
 210
 211 void
 212 ffedata_gather (ffestorag st)
 213 {
 214   ffesymbol s;
 215   ffebld b;
 216
 217   /* Prepare info on the storage area we're putting init info into. */
 218
 219   ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
 220                             &ffedata_storage_units_, ffestorag_basictype (st),
 221                             ffestorag_kindtype (st));
 222   ffedata_storage_size_ = ffestorag_size (st) / ffedata_storage_units_;
 223   assert (ffestorag_size (st) % ffedata_storage_units_ == 0);
 224
 225   /* If a CBLOCK, gather all the init info for its explicit members. */
 226
 227   if ((ffestorag_type (st) == FFESTORAG_typeCBLOCK)
 228       && (ffestorag_symbol (st) != NULL))
 229     {
 230       s = ffestorag_symbol (st);
 231       for (b = ffesymbol_commonlist (s); b != NULL; b = ffebld_trail (b))
 232         ffedata_gather_ (st,
 233                          ffesymbol_storage (ffebld_symter (ffebld_head (b))));
 234     }
 235
 236   /* For CBLOCK or LOCAL, gather all the init info for equivalenced members. */
 237
 238   ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st);
 239 }
 240
 241 /* ffedata_value -- Provide some number of initial values
 242
 243    ffebld value;
 244    ffelexToken t;  // Points to the value.
 245    if (ffedata_value(1,value,t))
 246        // Everything's ok
 247
 248    Makes sure the value is ok, then remembers it according to the list
 249    provided to ffedata_begin.  As many instances of the value may be
 250    supplied as desired, as indicated by the first argument.  */
 251
 252 bool
 253 ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token)
 254 {
 255   ffetargetIntegerDefault i;
 256
 257   /* Maybe ignore zero values, to speed up compiling, even though we lose
 258      checking for multiple initializations for now.  */
 259
 260   if (!ffe_is_zeros ()
 261       && (value != NULL)
 262       && (ffebld_op (value) == FFEBLD_opCONTER)
 263       && ffebld_constant_is_zero (ffebld_conter (value)))
 264     value = NULL;
 265   else if ((value != NULL)
 266            && (ffebld_op (value) == FFEBLD_opANY))
 267     value = NULL;
 268   else
 269     {
 270       /* Must be a constant. */
 271       assert (value != NULL);
 272       assert (ffebld_op (value) == FFEBLD_opCONTER);
 273     }
 274
 275   /* Later we can optimize certain cases by seeing that the target array can
 276      take some number of values, and provide this number to _value_. */
 277
 278   if (rpt == 1)
 279     ffedata_convert_cache_use_ = -1;    /* Don't bother caching. */
 280   else
 281     ffedata_convert_cache_use_ = 0;     /* Maybe use the cache. */
 282
 283   for (i = 0; i < rpt; ++i)
 284     {
 285       if ((ffedata_symbol_ != NULL)
 286           && !ffesymbol_is_init (ffedata_symbol_))
 287         {
 288           ffesymbol_signal_change (ffedata_symbol_);
 289           ffesymbol_update_init (ffedata_symbol_);
 290           if (1 || ffe_is_90 ())
 291             ffesymbol_update_save (ffedata_symbol_);
 292 #if FFEGLOBAL_ENABLED
 293           if (ffesymbol_common (ffedata_symbol_) != NULL)
 294             ffeglobal_init_common (ffesymbol_common (ffedata_symbol_),
 295                                    token);
 296 #endif
 297           ffesymbol_signal_unreported (ffedata_symbol_);
 298         }
 299       if (!ffedata_value_ (value, token))
 300         return FALSE;
 301     }
 302
 303   return TRUE;
 304 }
 305
 306 /* ffedata_advance_ -- Advance initialization target to next item in list
 307
 308    if (ffedata_advance_())
 309        // everything's ok
 310
 311    Sets common info to characterize the next item in the list.  Handles
 312    IMPDO constructs accordingly.  Does not handle advances within a single
 313    item, as in the common extension "DATA CHARTYPE/33,34,35/", where
 314    CHARTYPE is CHARACTER*3, for example.  */
 315
 316 static bool
 317 ffedata_advance_ ()
 318 {
 319   ffebld next;
 320
 321   /* Come here after handling an IMPDO. */
 322
 323 tail_recurse:                   /* :::::::::::::::::::: */
 324
 325   /* Assume we're not going to find a new target for now. */
 326
 327   ffedata_symbol_ = NULL;
 328
 329   /* If at the end of the list, we're done. */
 330
 331   if (ffedata_list_ == NULL)
 332     {
 333       ffetargetIntegerDefault newval;
 334
 335       if (ffedata_stack_ == NULL)
 336         return TRUE;            /* No IMPDO in progress, we is done! */
 337
 338       /* Iterate the IMPDO. */
 339
 340       newval = ffesymbol_value (ffedata_stack_->itervar)
 341         + ffedata_stack_->increment;
 342
 343       /* See if we're still in the loop. */
 344
 345       if (((ffedata_stack_->increment > 0)
 346            ? newval > ffedata_stack_->final
 347            : newval < ffedata_stack_->final)
 348           || (((ffesymbol_value (ffedata_stack_->itervar) < 0)
 349                == (ffedata_stack_->increment < 0))
 350               && ((ffesymbol_value (ffedata_stack_->itervar) < 0)
 351                   != (newval < 0))))    /* Overflow/underflow? */
 352         {                       /* Done with the loop. */
 353           ffedata_list_ = ffedata_stack_->outer_list;   /* Restore list. */
 354           ffedata_pop_ ();      /* Pop me off the impdo stack. */
 355         }
 356       else
 357         {                       /* Still in the loop, reset the list and
 358                                    update the iter var. */
 359           ffedata_list_ = ffedata_stack_->my_list;      /* Reset list. */
 360           ffesymbol_set_value (ffedata_stack_->itervar, newval);
 361         }
 362       goto tail_recurse;        /* :::::::::::::::::::: */
 363     }
 364
 365   /* Move to the next item in the list. */
 366
 367   next = ffebld_head (ffedata_list_);
 368   ffedata_list_ = ffebld_trail (ffedata_list_);
 369
 370   /* Really shouldn't happen. */
 371
 372   if (next == NULL)
 373     return TRUE;
 374
 375   /* See what kind of target this is. */
 376
 377   switch (ffebld_op (next))
 378     {
 379     case FFEBLD_opSYMTER:       /* Simple reference to scalar or array. */
 380       ffedata_symbol_ = ffebld_symter (next);
 381       ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
 382         : ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
 383       if (ffedata_storage_ != NULL)
 384         {
 385           ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
 386                                     &ffedata_storage_units_,
 387                                     ffestorag_basictype (ffedata_storage_),
 388                                     ffestorag_kindtype (ffedata_storage_));
 389           ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
 390             / ffedata_storage_units_;
 391           assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
 392         }
 393
 394       if ((ffesymbol_init (ffedata_symbol_) != NULL)
 395           || (ffesymbol_accretion (ffedata_symbol_) != NULL)
 396           || ((ffedata_storage_ != NULL)
 397               && (ffestorag_init (ffedata_storage_) != NULL)))
 398         {
 399 #if 0
 400           ffebad_start (FFEBAD_DATA_REINIT);
 401           ffest_ffebad_here_current_stmt (0);
 402           ffebad_string (ffesymbol_text (ffedata_symbol_));
 403           ffebad_finish ();
 404           ffedata_reported_error_ = TRUE;
 405           return FALSE;
 406 #else
 407           ffedata_reinit_ = TRUE;
 408           return TRUE;
 409 #endif
 410         }
 411       ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
 412       ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
 413       if (ffesymbol_rank (ffedata_symbol_) == 0)
 414         ffedata_arraysize_ = 1;
 415       else
 416         {
 417           ffebld size = ffesymbol_arraysize (ffedata_symbol_);
 418
 419           assert (size != NULL);
 420           assert (ffebld_op (size) == FFEBLD_opCONTER);
 421           assert (ffeinfo_basictype (ffebld_info (size))
 422                   == FFEINFO_basictypeINTEGER);
 423           assert (ffeinfo_kindtype (ffebld_info (size))
 424                   == FFEINFO_kindtypeINTEGERDEFAULT);
 425           ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
 426                                                                (size));
 427         }
 428       ffedata_expected_ = ffedata_arraysize_;
 429       ffedata_number_ = 0;
 430       ffedata_offset_ = 0;
 431       ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
 432         ? ffesymbol_size (ffedata_symbol_) : 1;
 433       ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
 434       ffedata_charexpected_ = ffedata_size_;
 435       ffedata_charnumber_ = 0;
 436       ffedata_charoffset_ = 0;
 437       break;
 438
 439     case FFEBLD_opARRAYREF:     /* Reference to element of array. */
 440       ffedata_symbol_ = ffebld_symter (ffebld_left (next));
 441       ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
 442         : ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
 443       if (ffedata_storage_ != NULL)
 444         {
 445           ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
 446                                     &ffedata_storage_units_,
 447                                     ffestorag_basictype (ffedata_storage_),
 448                                     ffestorag_kindtype (ffedata_storage_));
 449           ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
 450             / ffedata_storage_units_;
 451           assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
 452         }
 453
 454       if ((ffesymbol_init (ffedata_symbol_) != NULL)
 455           || ((ffedata_storage_ != NULL)
 456               && (ffestorag_init (ffedata_storage_) != NULL)))
 457         {
 458 #if 0
 459           ffebad_start (FFEBAD_DATA_REINIT);
 460           ffest_ffebad_here_current_stmt (0);
 461           ffebad_string (ffesymbol_text (ffedata_symbol_));
 462           ffebad_finish ();
 463           ffedata_reported_error_ = TRUE;
 464           return FALSE;
 465 #else
 466           ffedata_reinit_ = TRUE;
 467           return TRUE;
 468 #endif
 469         }
 470       ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
 471       ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
 472       if (ffesymbol_rank (ffedata_symbol_) == 0)
 473         ffedata_arraysize_ = 1; /* Shouldn't happen in this case... */
 474       else
 475         {
 476           ffebld size = ffesymbol_arraysize (ffedata_symbol_);
 477
 478           assert (size != NULL);
 479           assert (ffebld_op (size) == FFEBLD_opCONTER);
 480           assert (ffeinfo_basictype (ffebld_info (size))
 481                   == FFEINFO_basictypeINTEGER);
 482           assert (ffeinfo_kindtype (ffebld_info (size))
 483                   == FFEINFO_kindtypeINTEGERDEFAULT);
 484           ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
 485                                                                (size));
 486         }
 487       ffedata_expected_ = 1;
 488       ffedata_number_ = 0;
 489       ffedata_offset_ = ffedata_eval_offset_ (ffebld_right (next),
 490                                           ffesymbol_dims (ffedata_symbol_));
 491       ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
 492         ? ffesymbol_size (ffedata_symbol_) : 1;
 493       ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
 494       ffedata_charexpected_ = ffedata_size_;
 495       ffedata_charnumber_ = 0;
 496       ffedata_charoffset_ = 0;
 497       break;
 498
 499     case FFEBLD_opSUBSTR:       /* Substring reference to scalar or array
 500                                    element. */
 501       {
 502         bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF;
 503         ffebld colon = ffebld_right (next);
 504
 505         assert (colon != NULL);
 506
 507         ffedata_symbol_ = ffebld_symter (ffebld_left (arrayref
 508                                               ? ffebld_left (next) : next));
 509         ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
 510           : ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
 511         if (ffedata_storage_ != NULL)
 512           {
 513             ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
 514                                       &ffedata_storage_units_,
 515                                       ffestorag_basictype (ffedata_storage_),
 516                                       ffestorag_kindtype (ffedata_storage_));
 517             ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
 518               / ffedata_storage_units_;
 519             assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
 520           }
 521
 522         if ((ffesymbol_init (ffedata_symbol_) != NULL)
 523             || ((ffedata_storage_ != NULL)
 524                 && (ffestorag_init (ffedata_storage_) != NULL)))
 525           {
 526 #if 0
 527             ffebad_start (FFEBAD_DATA_REINIT);
 528             ffest_ffebad_here_current_stmt (0);
 529             ffebad_string (ffesymbol_text (ffedata_symbol_));
 530             ffebad_finish ();
 531             ffedata_reported_error_ = TRUE;
 532             return FALSE;
 533 #else
 534             ffedata_reinit_ = TRUE;
 535             return TRUE;
 536 #endif
 537           }
 538         ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
 539         ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
 540         if (ffesymbol_rank (ffedata_symbol_) == 0)
 541           ffedata_arraysize_ = 1;
 542         else
 543           {
 544             ffebld size = ffesymbol_arraysize (ffedata_symbol_);
 545
 546             assert (size != NULL);
 547             assert (ffebld_op (size) == FFEBLD_opCONTER);
 548             assert (ffeinfo_basictype (ffebld_info (size))
 549                     == FFEINFO_basictypeINTEGER);
 550             assert (ffeinfo_kindtype (ffebld_info (size))
 551                     == FFEINFO_kindtypeINTEGERDEFAULT);
 552             ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
 553                                                                  (size));
 554           }
 555         ffedata_expected_ = arrayref ? 1 : ffedata_arraysize_;
 556         ffedata_number_ = 0;
 557         ffedata_offset_ = arrayref ? ffedata_eval_offset_ (ffebld_right
 558                 (ffebld_left (next)), ffesymbol_dims (ffedata_symbol_)) : 0;
 559         ffedata_size_ = ffesymbol_size (ffedata_symbol_);
 560         ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
 561         ffedata_charnumber_ = 0;
 562         ffedata_charoffset_ = ffedata_eval_substr_begin_ (ffebld_head (colon));
 563         ffedata_charexpected_ = ffedata_eval_substr_end_ (ffebld_head
 564                                 (ffebld_trail (colon)), ffedata_charoffset_,
 565                                    ffedata_size_) - ffedata_charoffset_ + 1;
 566       }
 567       break;
 568
 569     case FFEBLD_opIMPDO:        /* Implied-DO construct. */
 570       {
 571         ffebld itervar;
 572         ffebld start;
 573         ffebld end;
 574         ffebld incr;
 575         ffebld item = ffebld_right (next);
 576
 577         itervar = ffebld_head (item);
 578         item = ffebld_trail (item);
 579         start = ffebld_head (item);
 580         item = ffebld_trail (item);
 581         end = ffebld_head (item);
 582         item = ffebld_trail (item);
 583         incr = ffebld_head (item);
 584
 585         ffedata_push_ ();
 586         ffedata_stack_->outer_list = ffedata_list_;
 587         ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next);
 588
 589         assert (ffeinfo_basictype (ffebld_info (itervar))
 590                 == FFEINFO_basictypeINTEGER);
 591         assert (ffeinfo_kindtype (ffebld_info (itervar))
 592                 == FFEINFO_kindtypeINTEGERDEFAULT);
 593         ffedata_stack_->itervar = ffebld_symter (itervar);
 594
 595         assert (ffeinfo_basictype (ffebld_info (start))
 596                 == FFEINFO_basictypeINTEGER);
 597         assert (ffeinfo_kindtype (ffebld_info (start))
 598                 == FFEINFO_kindtypeINTEGERDEFAULT);
 599         ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start));
 600
 601         assert (ffeinfo_basictype (ffebld_info (end))
 602                 == FFEINFO_basictypeINTEGER);
 603         assert (ffeinfo_kindtype (ffebld_info (end))
 604                 == FFEINFO_kindtypeINTEGERDEFAULT);
 605         ffedata_stack_->final = ffedata_eval_integer1_ (end);
 606
 607         if (incr == NULL)
 608           ffedata_stack_->increment = 1;
 609         else
 610           {
 611             assert (ffeinfo_basictype (ffebld_info (incr))
 612                     == FFEINFO_basictypeINTEGER);
 613             assert (ffeinfo_kindtype (ffebld_info (incr))
 614                     == FFEINFO_kindtypeINTEGERDEFAULT);
 615             ffedata_stack_->increment = ffedata_eval_integer1_ (incr);
 616             if (ffedata_stack_->increment == 0)
 617               {
 618                 ffebad_start (FFEBAD_DATA_ZERO);
 619                 ffest_ffebad_here_current_stmt (0);
 620                 ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
 621                 ffebad_finish ();
 622                 ffedata_pop_ ();
 623                 ffedata_reported_error_ = TRUE;
 624                 return FALSE;
 625               }
 626           }
 627
 628         if ((ffedata_stack_->increment > 0)
 629             ? ffesymbol_value (ffedata_stack_->itervar)
 630             > ffedata_stack_->final
 631             : ffesymbol_value (ffedata_stack_->itervar)
 632             < ffedata_stack_->final)
 633           {
 634             ffedata_reported_error_ = TRUE;
 635             ffebad_start (FFEBAD_DATA_EMPTY);
 636             ffest_ffebad_here_current_stmt (0);
 637             ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
 638             ffebad_finish ();
 639             ffedata_pop_ ();
 640             return FALSE;
 641           }
 642       }
 643       goto tail_recurse;        /* :::::::::::::::::::: */
 644
 645     case FFEBLD_opANY:
 646       ffedata_reported_error_ = TRUE;
 647       return FALSE;
 648
 649     default:
 650       assert ("bad op" == NULL);
 651       break;
 652     }
 653
 654   return TRUE;
 655 }
 656
 657 /* ffedata_convert_ -- Convert source expression to given type using cache
 658
 659    ffebld source;
 660    ffelexToken source_token;
 661    ffelexToken dest_token;  // Any appropriate token for "destination".
 662    ffeinfoBasictype bt;
 663    ffeinfoKindtype kt;
 664    ffetargetCharactersize sz;
 665    source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);
 666
 667    Like ffeexpr_convert, but calls it only if necessary (if the converted
 668    expression doesn't already exist in the cache) and then puts the result
 669    in the cache.  */
 670
 671 static ffebld
 672 ffedata_convert_ (ffebld source, ffelexToken source_token,
 673                   ffelexToken dest_token, ffeinfoBasictype bt,
 674                   ffeinfoKindtype kt, ffeinfoRank rk,
 675                   ffetargetCharacterSize sz)
 676 {
 677   ffebld converted;
 678   int i;
 679   int max;
 680   ffedataConvertCache_ cache;
 681
 682   for (i = 0; i < ffedata_convert_cache_use_; ++i)
 683     if ((bt == ffedata_convert_cache_[i].basic_type)
 684         && (kt == ffedata_convert_cache_[i].kind_type)
 685         && (sz == ffedata_convert_cache_[i].size)
 686         && (rk == ffedata_convert_cache_[i].rank))
 687       return ffedata_convert_cache_[i].converted;
 688
 689   converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk,
 690                                sz, FFEEXPR_contextDATA);
 691
 692   if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_)
 693     {
 694       if (ffedata_convert_cache_max_ == 0)
 695         max = 4;
 696       else
 697         max = ffedata_convert_cache_max_ << 1;
 698
 699       if (max > ffedata_convert_cache_max_)
 700         {
 701           cache = (ffedataConvertCache_) malloc_new_ks (malloc_pool_image (),
 702                                     "FFEDATA cache", max * sizeof (*cache));
 703           if (ffedata_convert_cache_max_ != 0)
 704             {
 705               memcpy (cache, ffedata_convert_cache_,
 706                       ffedata_convert_cache_max_ * sizeof (*cache));
 707               malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_,
 708                               ffedata_convert_cache_max_ * sizeof (*cache));
 709             }
 710           ffedata_convert_cache_ = cache;
 711           ffedata_convert_cache_max_ = max;
 712         }
 713       else
 714         return converted;       /* In case int overflows! */
 715     }
 716
 717   i = ffedata_convert_cache_use_++;
 718
 719   ffedata_convert_cache_[i].converted = converted;
 720   ffedata_convert_cache_[i].basic_type = bt;
 721   ffedata_convert_cache_[i].kind_type = kt;
 722   ffedata_convert_cache_[i].size = sz;
 723   ffedata_convert_cache_[i].rank = rk;
 724
 725   return converted;
 726 }
 727
 728 /* ffedata_eval_integer1_ -- Evaluate expression
 729
 730    ffetargetIntegerDefault result;
 731    ffebld expr;  // must be kindtypeINTEGER1.
 732
 733    result = ffedata_eval_integer1_(expr);
 734
 735    Evalues the expression (which yields a kindtypeINTEGER1 result) and
 736    returns the result.  */
 737
 738 static ffetargetIntegerDefault
 739 ffedata_eval_integer1_ (ffebld expr)
 740 {
 741   ffetargetInteger1 result;
 742   ffebad error;
 743
 744   assert (expr != NULL);
 745
 746   switch (ffebld_op (expr))
 747     {
 748     case FFEBLD_opCONTER:
 749       return ffebld_constant_integer1 (ffebld_conter (expr));
 750
 751     case FFEBLD_opSYMTER:
 752       return ffesymbol_value (ffebld_symter (expr));
 753
 754     case FFEBLD_opUPLUS:
 755       return ffedata_eval_integer1_ (ffebld_left (expr));
 756
 757     case FFEBLD_opUMINUS:
 758       error = ffetarget_uminus_integer1 (&result,
 759                                ffedata_eval_integer1_ (ffebld_left (expr)));
 760       break;
 761
 762     case FFEBLD_opADD:
 763       error = ffetarget_add_integer1 (&result,
 764                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 765                               ffedata_eval_integer1_ (ffebld_right (expr)));
 766       break;
 767
 768     case FFEBLD_opSUBTRACT:
 769       error = ffetarget_subtract_integer1 (&result,
 770                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 771                               ffedata_eval_integer1_ (ffebld_right (expr)));
 772       break;
 773
 774     case FFEBLD_opMULTIPLY:
 775       error = ffetarget_multiply_integer1 (&result,
 776                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 777                               ffedata_eval_integer1_ (ffebld_right (expr)));
 778       break;
 779
 780     case FFEBLD_opDIVIDE:
 781       error = ffetarget_divide_integer1 (&result,
 782                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 783                               ffedata_eval_integer1_ (ffebld_right (expr)));
 784       break;
 785
 786     case FFEBLD_opPOWER:
 787       {
 788         ffebld r = ffebld_right (expr);
 789
 790         if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
 791             || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
 792           error = FFEBAD_DATA_EVAL;
 793         else
 794           error = ffetarget_power_integerdefault_integerdefault (&result,
 795                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 796                                                 ffedata_eval_integer1_ (r));
 797       }
 798       break;
 799
 800 #if 0                           /* Only for character basictype. */
 801     case FFEBLD_opCONCATENATE:
 802       error =;
 803       break;
 804 #endif
 805
 806     case FFEBLD_opNOT:
 807       error = ffetarget_not_integer1 (&result,
 808                                ffedata_eval_integer1_ (ffebld_left (expr)));
 809       break;
 810
 811 #if 0                           /* Only for logical basictype. */
 812     case FFEBLD_opLT:
 813       error =;
 814       break;
 815
 816     case FFEBLD_opLE:
 817       error =;
 818       break;
 819
 820     case FFEBLD_opEQ:
 821       error =;
 822       break;
 823
 824     case FFEBLD_opNE:
 825       error =;
 826       break;
 827
 828     case FFEBLD_opGT:
 829       error =;
 830       break;
 831
 832     case FFEBLD_opGE:
 833       error =;
 834       break;
 835 #endif
 836
 837     case FFEBLD_opAND:
 838       error = ffetarget_and_integer1 (&result,
 839                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 840                               ffedata_eval_integer1_ (ffebld_right (expr)));
 841       break;
 842
 843     case FFEBLD_opOR:
 844       error = ffetarget_or_integer1 (&result,
 845                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 846                               ffedata_eval_integer1_ (ffebld_right (expr)));
 847       break;
 848
 849     case FFEBLD_opXOR:
 850       error = ffetarget_xor_integer1 (&result,
 851                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 852                               ffedata_eval_integer1_ (ffebld_right (expr)));
 853       break;
 854
 855     case FFEBLD_opEQV:
 856       error = ffetarget_eqv_integer1 (&result,
 857                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 858                               ffedata_eval_integer1_ (ffebld_right (expr)));
 859       break;
 860
 861     case FFEBLD_opNEQV:
 862       error = ffetarget_neqv_integer1 (&result,
 863                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 864                               ffedata_eval_integer1_ (ffebld_right (expr)));
 865       break;
 866
 867     case FFEBLD_opPAREN:
 868       return ffedata_eval_integer1_ (ffebld_left (expr));
 869
 870 #if 0                           /* ~~ no idea how to do this */
 871     case FFEBLD_opPERCENT_LOC:
 872       error =;
 873       break;
 874 #endif
 875
 876 #if 0                           /* not allowed by ANSI, but perhaps as an
 877                                    extension someday? */
 878     case FFEBLD_opCONVERT:
 879       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
 880         {
 881         case FFEINFO_basictypeINTEGER:
 882           switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
 883             {
 884             default:
 885               error = FFEBAD_DATA_EVAL;
 886               break;
 887             }
 888           break;
 889
 890         case FFEINFO_basictypeREAL:
 891           switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
 892             {
 893             default:
 894               error = FFEBAD_DATA_EVAL;
 895               break;
 896             }
 897           break;
 898         }
 899       break;
 900 #endif
 901
 902 #if 0                           /* not valid ops */
 903     case FFEBLD_opREPEAT:
 904       error =;
 905       break;
 906
 907     case FFEBLD_opBOUNDS:
 908       error =;
 909       break;
 910 #endif
 911
 912 #if 0                           /* not allowed by ANSI, but perhaps as an
 913                                    extension someday? */
 914     case FFEBLD_opFUNCREF:
 915       error =;
 916       break;
 917 #endif
 918
 919 #if 0                           /* not valid ops */
 920     case FFEBLD_opSUBRREF:
 921       error =;
 922       break;
 923
 924     case FFEBLD_opARRAYREF:
 925       error =;
 926       break;
 927 #endif
 928
 929 #if 0                           /* not valid for integer1 */
 930     case FFEBLD_opSUBSTR:
 931       error =;
 932       break;
 933 #endif
 934
 935     default:
 936       error = FFEBAD_DATA_EVAL;
 937       break;
 938     }
 939
 940   if (error != FFEBAD)
 941     {
 942       ffebad_start (error);
 943       ffest_ffebad_here_current_stmt (0);
 944       ffebad_finish ();
 945       result = 0;
 946     }
 947
 948   return result;
 949 }
 950
 951 /* ffedata_eval_offset_ -- Evaluate offset info array
 952
 953    ffetargetOffset offset;  // 0...max-1.
 954    ffebld subscripts;  // an opITEM list of subscript exprs.
 955    ffebld dims;  // an opITEM list of opBOUNDS exprs.
 956
 957    result = ffedata_eval_offset_(expr);
 958
 959    Evalues the expression (which yields a kindtypeINTEGER1 result) and
 960    returns the result.  */
 961
 962 static ffetargetOffset
 963 ffedata_eval_offset_ (ffebld subscripts, ffebld dims)
 964 {
 965   ffetargetIntegerDefault offset = 0;
 966   ffetargetIntegerDefault width = 1;
 967   ffetargetIntegerDefault value;
 968   ffetargetIntegerDefault lowbound;
 969   ffetargetIntegerDefault highbound;
 970   ffetargetOffset final;
 971   ffebld subscript;
 972   ffebld dim;
 973   ffebld low;
 974   ffebld high;
 975   int rank = 0;
 976   bool ok;
 977
 978   while (subscripts != NULL)
 979     {
 980       ++rank;
 981       assert (dims != NULL);
 982
 983       subscript = ffebld_head (subscripts);
 984       dim = ffebld_head (dims);
 985
 986       assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
 987       assert (ffeinfo_kindtype (ffebld_info (subscript)) == FFEINFO_kindtypeINTEGER1);
 988       value = ffedata_eval_integer1_ (subscript);
 989
 990       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
 991       low = ffebld_left (dim);
 992       high = ffebld_right (dim);
 993
 994       if (low == NULL)
 995         lowbound = 1;
 996       else
 997         {
 998           assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
 999           assert (ffeinfo_kindtype (ffebld_info (low)) == FFEINFO_kindtypeINTEGERDEFAULT);
1000           lowbound = ffedata_eval_integer1_ (low);
1001         }
1002
1003       assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
1004       assert (ffeinfo_kindtype (ffebld_info (high)) == FFEINFO_kindtypeINTEGERDEFAULT);
1005       highbound = ffedata_eval_integer1_ (high);
1006
1007       if ((value < lowbound) || (value > highbound))
1008         {
1009           char rankstr[10];
1010
1011           sprintf (rankstr, "%d", rank);
1012           value = lowbound;
1013           ffebad_start (FFEBAD_DATA_SUBSCRIPT);
1014           ffebad_string (ffesymbol_text (ffedata_symbol_));
1015           ffebad_string (rankstr);
1016           ffebad_finish ();
1017         }
1018
1019       subscripts = ffebld_trail (subscripts);
1020       dims = ffebld_trail (dims);
1021
1022       offset += width * (value - lowbound);
1023       if (subscripts != NULL)
1024         width *= highbound - lowbound + 1;
1025     }
1026
1027   assert (dims == NULL);
1028
1029   ok = ffetarget_offset (&final, offset);
1030   assert (ok);
1031
1032   return final;
1033 }
1034
1035 /* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference
1036
1037    ffetargetCharacterSize beginpoint;
1038    ffebld endval;  // head(colon).
1039
1040    beginpoint = ffedata_eval_substr_end_(endval);
1041
1042    If beginval is NULL, returns 0.  Otherwise makes sure beginval is
1043    kindtypeINTEGERDEFAULT, makes sure its value is > 0,
1044    and returns its value minus one, or issues an error message.  */
1045
1046 static ffetargetCharacterSize
1047 ffedata_eval_substr_begin_ (ffebld expr)
1048 {
1049   ffetargetIntegerDefault val;
1050
1051   if (expr == NULL)
1052     return 0;
1053
1054   assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1055   assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);
1056
1057   val = ffedata_eval_integer1_ (expr);
1058
1059   if (val < 1)
1060     {
1061       val = 1;
1062       ffebad_start (FFEBAD_DATA_RANGE);
1063       ffest_ffebad_here_current_stmt (0);
1064       ffebad_string (ffesymbol_text (ffedata_symbol_));
1065       ffebad_finish ();
1066       ffedata_reported_error_ = TRUE;
1067     }
1068
1069   return val - 1;
1070 }
1071
1072 /* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference
1073
1074    ffetargetCharacterSize endpoint;
1075    ffebld endval;  // head(trail(colon)).
1076    ffetargetCharacterSize min;  // beginpoint of substr reference.
1077    ffetargetCharacterSize max;  // size of entity.
1078
1079    endpoint = ffedata_eval_substr_end_(endval,dflt);
1080
1081    If endval is NULL, returns max.  Otherwise makes sure endval is
1082    kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
1083    and returns its value minus one, or issues an error message.  */
1084
1085 static ffetargetCharacterSize
1086 ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
1087                           ffetargetCharacterSize max)
1088 {
1089   ffetargetIntegerDefault val;
1090
1091   if (expr == NULL)
1092     return max - 1;
1093
1094   assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1095   assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);
1096
1097   val = ffedata_eval_integer1_ (expr);
1098
1099   if ((val < (ffetargetIntegerDefault) min)
1100       || (val > (ffetargetIntegerDefault) max))
1101     {
1102       val = 1;
1103       ffebad_start (FFEBAD_DATA_RANGE);
1104       ffest_ffebad_here_current_stmt (0);
1105       ffebad_string (ffesymbol_text (ffedata_symbol_));
1106       ffebad_finish ();
1107       ffedata_reported_error_ = TRUE;
1108     }
1109
1110   return val - 1;
1111 }
1112
1113 /* ffedata_gather_ -- Gather initial values for sym into master sym inits
1114
1115    ffestorag mst;  // A typeCBLOCK or typeLOCAL aggregate.
1116    ffestorag st;  // A typeCOMMON or typeEQUIV member.
1117    ffedata_gather_(mst,st);
1118
1119    If st has any initialization info, transfer that info into mst and
1120    clear st's info.  */
1121
1122 static void
1123 ffedata_gather_ (ffestorag mst, ffestorag st)
1124 {
1125   ffesymbol s;
1126   ffesymbol s_whine;            /* Symbol to complain about in diagnostics. */
1127   ffebld b;
1128   ffetargetOffset offset;
1129   ffetargetOffset units_expected;
1130   ffebitCount actual;
1131   ffebldConstantArray array;
1132   ffebld accter;
1133   ffetargetCopyfunc fn;
1134   void *ptr1;
1135   void *ptr2;
1136   size_t size;
1137   ffeinfoBasictype bt;
1138   ffeinfoKindtype kt;
1139   ffeinfoBasictype ign_bt;
1140   ffeinfoKindtype ign_kt;
1141   ffetargetAlign units;
1142   ffebit bits;
1143   ffetargetOffset source_offset;
1144   bool whine = FALSE;
1145
1146   if (st == NULL)
1147     return;                     /* Nothing to do. */
1148
1149   s = ffestorag_symbol (st);
1150
1151   assert (s != NULL);           /* Must have a corresponding symbol (else how
1152                                    inited?). */
1153   assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */
1154   assert (ffestorag_accretion (st) == NULL);
1155
1156   if ((((b = ffesymbol_init (s)) == NULL)
1157        && ((b = ffesymbol_accretion (s)) == NULL))
1158       || (ffebld_op (b) == FFEBLD_opANY)
1159       || ((ffebld_op (b) == FFEBLD_opCONVERT)
1160           && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
1161     return;                     /* Nothing to do. */
1162
1163   /* b now holds the init/accretion expr. */
1164
1165   ffesymbol_set_init (s, NULL);
1166   ffesymbol_set_accretion (s, NULL);
1167   ffesymbol_set_accretes (s, 0);
1168
1169   s_whine = ffestorag_symbol (mst);
1170   if (s_whine == NULL)
1171     s_whine = s;
1172
1173   /* Make sure we haven't fully accreted during an array init. */
1174
1175   if (ffestorag_init (mst) != NULL)
1176     {
1177       ffebad_start (FFEBAD_DATA_MULTIPLE);
1178       ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1179       ffebad_string (ffesymbol_text (s_whine));
1180       ffebad_finish ();
1181       return;
1182     }
1183
1184   bt = ffeinfo_basictype (ffebld_info (b));
1185   kt = ffeinfo_kindtype (ffebld_info (b));
1186
1187   /* Calculate offset for aggregate area. */
1188
1189   ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
1190     ? ffebld_size (b) : 1;
1191   ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
1192                             kt);/* Find out unit size of source datum. */
1193   assert (units % ffedata_storage_units_ == 0);
1194   units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1195   offset = (ffestorag_offset (st) - ffestorag_offset (mst))
1196     / ffedata_storage_units_;
1197
1198   /* Does an accretion array exist?  If not, create it. */
1199
1200   if (ffestorag_accretion (mst) == NULL)
1201     {
1202 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1203       if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1204         {
1205           char bignum[40];
1206
1207           sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1208           ffebad_start (FFEBAD_TOO_BIG_INIT);
1209           ffebad_here (0, ffesymbol_where_line (s_whine),
1210                        ffesymbol_where_column (s_whine));
1211           ffebad_string (ffesymbol_text (s_whine));
1212           ffebad_string (bignum);
1213           ffebad_finish ();
1214         }
1215 #endif
1216       array = ffebld_constantarray_new (ffedata_storage_bt_,
1217                                 ffedata_storage_kt_, ffedata_storage_size_);
1218       accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
1219                                                      ffedata_storage_size_));
1220       ffebld_set_info (accter, ffeinfo_new
1221                        (ffedata_storage_bt_,
1222                         ffedata_storage_kt_,
1223                         1,
1224                         FFEINFO_kindENTITY,
1225                         FFEINFO_whereCONSTANT,
1226                         (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1227                         ? 1 : FFETARGET_charactersizeNONE));
1228       ffestorag_set_accretion (mst, accter);
1229       ffestorag_set_accretes (mst, ffedata_storage_size_);
1230     }
1231   else
1232     {
1233       accter = ffestorag_accretion (mst);
1234       assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1235       array = ffebld_accter (accter);
1236     }
1237
1238   /* Put value in accretion array at desired offset. */
1239
1240   fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
1241                                        bt, kt);
1242
1243   switch (ffebld_op (b))
1244     {
1245     case FFEBLD_opCONTER:
1246       ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1247                                     ffedata_storage_kt_, offset,
1248                            ffebld_constant_ptr_to_union (ffebld_conter (b)),
1249                                     bt, kt);
1250       (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1251                                    operation. */
1252       ffebit_count (ffebld_accter_bits (accter),
1253                     offset, FALSE, units_expected, &actual);    /* How many FALSE? */
1254       if (units_expected != (ffetargetOffset) actual)
1255         {
1256           ffebad_start (FFEBAD_DATA_MULTIPLE);
1257           ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1258           ffebad_string (ffesymbol_text (s));
1259           ffebad_finish ();
1260         }
1261       ffestorag_set_accretes (mst,
1262                               ffestorag_accretes (mst)
1263                               - actual);        /* Decrement # of values
1264                                                    actually accreted. */
1265       ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1266
1267       /* If done accreting for this storage area, establish as initialized. */
1268
1269       if (ffestorag_accretes (mst) == 0)
1270         {
1271           ffestorag_set_init (mst, accter);
1272           ffestorag_set_accretion (mst, NULL);
1273           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1274           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1275           ffebld_set_arrter (ffestorag_init (mst),
1276                              ffebld_accter (ffestorag_init (mst)));
1277           ffebld_arrter_set_size (ffestorag_init (mst),
1278                                   ffedata_storage_size_);
1279           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1280           ffecom_notify_init_storage (mst);
1281         }
1282
1283       return;
1284
1285     case FFEBLD_opARRTER:
1286       ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1287                              ffedata_storage_kt_, offset, ffebld_arrter (b),
1288                                       bt, kt);
1289       size *= ffebld_arrter_size (b);
1290       units_expected *= ffebld_arrter_size (b);
1291       (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1292                                    operation. */
1293       ffebit_count (ffebld_accter_bits (accter),
1294                     offset, FALSE, units_expected, &actual);    /* How many FALSE? */
1295       if (units_expected != (ffetargetOffset) actual)
1296         {
1297           ffebad_start (FFEBAD_DATA_MULTIPLE);
1298           ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1299           ffebad_string (ffesymbol_text (s));
1300           ffebad_finish ();
1301         }
1302       ffestorag_set_accretes (mst,
1303                               ffestorag_accretes (mst)
1304                               - actual);        /* Decrement # of values
1305                                                    actually accreted. */
1306       ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1307
1308       /* If done accreting for this storage area, establish as initialized. */
1309
1310       if (ffestorag_accretes (mst) == 0)
1311         {
1312           ffestorag_set_init (mst, accter);
1313           ffestorag_set_accretion (mst, NULL);
1314           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1315           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1316           ffebld_set_arrter (ffestorag_init (mst),
1317                              ffebld_accter (ffestorag_init (mst)));
1318           ffebld_arrter_set_size (ffestorag_init (mst),
1319                                   ffedata_storage_size_);
1320           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1321           ffecom_notify_init_storage (mst);
1322         }
1323
1324       return;
1325
1326     case FFEBLD_opACCTER:
1327       ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1328                              ffedata_storage_kt_, offset, ffebld_accter (b),
1329                                       bt, kt);
1330       bits = ffebld_accter_bits (b);
1331       source_offset = 0;
1332
1333       for (;;)
1334         {
1335           ffetargetOffset unexp;
1336           ffetargetOffset siz;
1337           ffebitCount length;
1338           bool value;
1339
1340           ffebit_test (bits, source_offset, &value, &length);
1341           if (length == 0)
1342             break;              /* Exit the loop early. */
1343           siz = size * length;
1344           unexp = units_expected * length;
1345           if (value)
1346             {
1347               (*fn) (ptr1, ptr2, siz);  /* Does memcpy-like operation. */
1348               ffebit_count (ffebld_accter_bits (accter),        /* How many FALSE? */
1349                             offset, FALSE, unexp, &actual);
1350               if (!whine && (unexp != (ffetargetOffset) actual))
1351                 {
1352                   whine = TRUE; /* Don't whine more than once for one gather. */
1353                   ffebad_start (FFEBAD_DATA_MULTIPLE);
1354                   ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1355                   ffebad_string (ffesymbol_text (s));
1356                   ffebad_finish ();
1357                 }
1358               ffestorag_set_accretes (mst,
1359                                       ffestorag_accretes (mst)
1360                                       - actual);        /* Decrement # of values
1361                                                            actually accreted. */
1362               ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
1363             }
1364           source_offset += length;
1365           offset += unexp;
1366           ptr1 = ((char *) ptr1) + siz;
1367           ptr2 = ((char *) ptr2) + siz;
1368         }
1369
1370       /* If done accreting for this storage area, establish as initialized. */
1371
1372       if (ffestorag_accretes (mst) == 0)
1373         {
1374           ffestorag_set_init (mst, accter);
1375           ffestorag_set_accretion (mst, NULL);
1376           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1377           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1378           ffebld_set_arrter (ffestorag_init (mst),
1379                              ffebld_accter (ffestorag_init (mst)));
1380           ffebld_arrter_set_size (ffestorag_init (mst),
1381                                   ffedata_storage_size_);
1382           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1383           ffecom_notify_init_storage (mst);
1384         }
1385
1386       return;
1387
1388     default:
1389       assert ("bad init op in gather_" == NULL);
1390       return;
1391     }
1392 }
1393
1394 /* ffedata_pop_ -- Pop an impdo stack entry
1395
1396    ffedata_pop_();  */
1397
1398 static void
1399 ffedata_pop_ ()
1400 {
1401   ffedataImpdo_ victim = ffedata_stack_;
1402
1403   assert (victim != NULL);
1404
1405   ffedata_stack_ = ffedata_stack_->outer;
1406
1407   malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
1408 }
1409
1410 /* ffedata_push_ -- Push an impdo stack entry
1411
1412    ffedata_push_();  */
1413
1414 static void
1415 ffedata_push_ ()
1416 {
1417   ffedataImpdo_ baby;
1418
1419   baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));
1420
1421   baby->outer = ffedata_stack_;
1422   ffedata_stack_ = baby;
1423 }
1424
1425 /* ffedata_value_ -- Provide an initial value
1426
1427    ffebld value;
1428    ffelexToken t;  // Points to the value.
1429    if (ffedata_value(value,t))
1430        // Everything's ok
1431
1432    Makes sure the value is ok, then remembers it according to the list
1433    provided to ffedata_begin.  */
1434
1435 static bool
1436 ffedata_value_ (ffebld value, ffelexToken token)
1437 {
1438
1439   /* If already reported an error, don't do anything. */
1440
1441   if (ffedata_reported_error_)
1442     return FALSE;
1443
1444   /* If the value is an error marker, remember we've seen one and do nothing
1445      else. */
1446
1447   if ((value != NULL)
1448       && (ffebld_op (value) == FFEBLD_opANY))
1449     {
1450       ffedata_reported_error_ = TRUE;
1451       return FALSE;
1452     }
1453
1454   /* If too many values (no more targets), complain. */
1455
1456   if (ffedata_symbol_ == NULL)
1457     {
1458       ffebad_start (FFEBAD_DATA_TOOMANY);
1459       ffebad_here (0, ffelex_token_where_line (token),
1460                    ffelex_token_where_column (token));
1461       ffebad_finish ();
1462       ffedata_reported_error_ = TRUE;
1463       return FALSE;
1464     }
1465
1466   /* If ffedata_advance_ wanted to register a complaint, do it now
1467      that we have the token to point at instead of just the start
1468      of the whole statement.  */
1469
1470   if (ffedata_reinit_)
1471     {
1472       ffebad_start (FFEBAD_DATA_REINIT);
1473       ffebad_here (0, ffelex_token_where_line (token),
1474                    ffelex_token_where_column (token));
1475       ffebad_string (ffesymbol_text (ffedata_symbol_));
1476       ffebad_finish ();
1477       ffedata_reported_error_ = TRUE;
1478       return FALSE;
1479     }
1480
1481 #if FFEGLOBAL_ENABLED
1482   if (ffesymbol_common (ffedata_symbol_) != NULL)
1483     ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token);
1484 #endif
1485
1486   /* Convert value to desired type. */
1487
1488   if (value != NULL)
1489     {
1490       if (ffedata_convert_cache_use_ == -1)
1491         value = ffeexpr_convert
1492           (value, token, NULL, ffedata_basictype_,
1493            ffedata_kindtype_, 0,
1494            (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1495            ? ffedata_charexpected_ : FFETARGET_charactersizeNONE,
1496            FFEEXPR_contextDATA);
1497       else                              /* Use the cache. */
1498         value = ffedata_convert_
1499           (value, token, NULL, ffedata_basictype_,
1500            ffedata_kindtype_, 0,
1501            (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1502            ? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
1503     }
1504
1505   /* If we couldn't, bug out. */
1506
1507   if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
1508     {
1509       ffedata_reported_error_ = TRUE;
1510       return FALSE;
1511     }
1512
1513   /* Handle the case where initializes go to a parent's storage area. */
1514
1515   if (ffedata_storage_ != NULL)
1516     {
1517       ffetargetOffset offset;
1518       ffetargetOffset units_expected;
1519       ffebitCount actual;
1520       ffebldConstantArray array;
1521       ffebld accter;
1522       ffetargetCopyfunc fn;
1523       void *ptr1;
1524       void *ptr2;
1525       size_t size;
1526       ffeinfoBasictype ign_bt;
1527       ffeinfoKindtype ign_kt;
1528       ffetargetAlign units;
1529
1530       /* Make sure we haven't fully accreted during an array init. */
1531
1532       if (ffestorag_init (ffedata_storage_) != NULL)
1533         {
1534           ffebad_start (FFEBAD_DATA_MULTIPLE);
1535           ffebad_here (0, ffelex_token_where_line (token),
1536                        ffelex_token_where_column (token));
1537           ffebad_string (ffesymbol_text (ffedata_symbol_));
1538           ffebad_finish ();
1539           ffedata_reported_error_ = TRUE;
1540           return FALSE;
1541         }
1542
1543       /* Calculate offset. */
1544
1545       offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1546
1547       /* Is offset within range?  If not, whine, but don't do anything else. */
1548
1549       if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1550         {
1551           ffebad_start (FFEBAD_DATA_RANGE);
1552           ffest_ffebad_here_current_stmt (0);
1553           ffebad_string (ffesymbol_text (ffedata_symbol_));
1554           ffebad_finish ();
1555           ffedata_reported_error_ = TRUE;
1556           return FALSE;
1557         }
1558
1559       /* Now calculate offset for aggregate area. */
1560
1561       ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
1562                                 ffedata_kindtype_);     /* Find out unit size of
1563                                                            source datum. */
1564       assert (units % ffedata_storage_units_ == 0);
1565       units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1566       offset *= units / ffedata_storage_units_;
1567       offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_))
1568                  - ffestorag_offset (ffedata_storage_))
1569         / ffedata_storage_units_;
1570
1571       assert (offset + units_expected - 1 <= ffedata_storage_size_);
1572
1573       /* Does an accretion array exist?  If not, create it. */
1574
1575       if (value != NULL)
1576         {
1577           if (ffestorag_accretion (ffedata_storage_) == NULL)
1578             {
1579 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1580               if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1581                 {
1582                   char bignum[40];
1583
1584                   sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1585                   ffebad_start (FFEBAD_TOO_BIG_INIT);
1586                   ffebad_here (0, ffelex_token_where_line (token),
1587                                ffelex_token_where_column (token));
1588                   ffebad_string (ffesymbol_text (ffedata_symbol_));
1589                   ffebad_string (bignum);
1590                   ffebad_finish ();
1591                 }
1592 #endif
1593               array = ffebld_constantarray_new
1594                 (ffedata_storage_bt_, ffedata_storage_kt_,
1595                  ffedata_storage_size_);
1596               accter = ffebld_new_accter (array,
1597                                           ffebit_new (ffe_pool_program_unit (),
1598                                                       ffedata_storage_size_));
1599               ffebld_set_info (accter, ffeinfo_new
1600                                (ffedata_storage_bt_,
1601                                 ffedata_storage_kt_,
1602                                 1,
1603                                 FFEINFO_kindENTITY,
1604                                 FFEINFO_whereCONSTANT,
1605                                 (ffedata_basictype_
1606                                  == FFEINFO_basictypeCHARACTER)
1607                                 ? 1 : FFETARGET_charactersizeNONE));
1608               ffestorag_set_accretion (ffedata_storage_, accter);
1609               ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_);
1610             }
1611           else
1612             {
1613               accter = ffestorag_accretion (ffedata_storage_);
1614               assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1615               array = ffebld_accter (accter);
1616             }
1617
1618           /* Put value in accretion array at desired offset. */
1619
1620           fn = ffetarget_aggregate_ptr_memcpy
1621             (ffedata_storage_bt_, ffedata_storage_kt_,
1622              ffedata_basictype_, ffedata_kindtype_);
1623           ffebld_constantarray_prepare
1624             (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1625              ffedata_storage_kt_, offset,
1626              ffebld_constant_ptr_to_union (ffebld_conter (value)),
1627              ffedata_basictype_, ffedata_kindtype_);
1628           (*fn) (ptr1, ptr2, size);     /* Does the appropriate memcpy-like
1629                                            operation. */
1630           ffebit_count (ffebld_accter_bits (accter),
1631                         offset, FALSE, units_expected,
1632                         &actual);       /* How many FALSE? */
1633           if (units_expected != (ffetargetOffset) actual)
1634             {
1635               ffebad_start (FFEBAD_DATA_MULTIPLE);
1636               ffebad_here (0, ffelex_token_where_line (token),
1637                            ffelex_token_where_column (token));
1638               ffebad_string (ffesymbol_text (ffedata_symbol_));
1639               ffebad_finish ();
1640             }
1641           ffestorag_set_accretes (ffedata_storage_,
1642                                   ffestorag_accretes (ffedata_storage_)
1643                                   - actual);    /* Decrement # of values
1644                                                    actually accreted. */
1645           ffebit_set (ffebld_accter_bits (accter), offset,
1646                       1, units_expected);
1647
1648           /* If done accreting for this storage area, establish as
1649              initialized. */
1650
1651           if (ffestorag_accretes (ffedata_storage_) == 0)
1652             {
1653               ffestorag_set_init (ffedata_storage_, accter);
1654               ffestorag_set_accretion (ffedata_storage_, NULL);
1655               ffebit_kill (ffebld_accter_bits
1656                            (ffestorag_init (ffedata_storage_)));
1657               ffebld_set_op (ffestorag_init (ffedata_storage_),
1658                              FFEBLD_opARRTER);
1659               ffebld_set_arrter
1660                 (ffestorag_init (ffedata_storage_),
1661                  ffebld_accter (ffestorag_init (ffedata_storage_)));
1662               ffebld_arrter_set_size (ffestorag_init (ffedata_storage_),
1663                                       ffedata_storage_size_);
1664               ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_),
1665                                      0);
1666               ffecom_notify_init_storage (ffedata_storage_);
1667             }
1668         }
1669
1670       /* If still accreting, adjust specs accordingly and return. */
1671
1672       if (++ffedata_number_ < ffedata_expected_)
1673         {
1674           ++ffedata_offset_;
1675           return TRUE;
1676         }
1677
1678       return ffedata_advance_ ();
1679     }
1680
1681   /* Figure out where the value goes -- in an accretion array or directly
1682      into the final initial-value slot for the symbol. */
1683
1684   if ((ffedata_number_ != 0)
1685       || (ffedata_arraysize_ > 1)
1686       || (ffedata_charnumber_ != 0)
1687       || (ffedata_size_ > ffedata_charexpected_))
1688     {                           /* Accrete this value. */
1689       ffetargetOffset offset;
1690       ffebitCount actual;
1691       ffebldConstantArray array;
1692       ffebld accter = NULL;
1693
1694       /* Calculate offset. */
1695
1696       offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1697
1698       /* Is offset within range?  If not, whine, but don't do anything else. */
1699
1700       if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1701         {
1702           ffebad_start (FFEBAD_DATA_RANGE);
1703           ffest_ffebad_here_current_stmt (0);
1704           ffebad_string (ffesymbol_text (ffedata_symbol_));
1705           ffebad_finish ();
1706           ffedata_reported_error_ = TRUE;
1707           return FALSE;
1708         }
1709
1710       /* Does an accretion array exist?  If not, create it. */
1711
1712       if (value != NULL)
1713         {
1714           if (ffesymbol_accretion (ffedata_symbol_) == NULL)
1715             {
1716 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1717               if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ )
1718                 {
1719                   char bignum[40];
1720
1721                   sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_);
1722                   ffebad_start (FFEBAD_TOO_BIG_INIT);
1723                   ffebad_here (0, ffelex_token_where_line (token),
1724                                ffelex_token_where_column (token));
1725                   ffebad_string (ffesymbol_text (ffedata_symbol_));
1726                   ffebad_string (bignum);
1727                   ffebad_finish ();
1728                 }
1729 #endif
1730               array = ffebld_constantarray_new
1731                 (ffedata_basictype_, ffedata_kindtype_,
1732                  ffedata_symbolsize_);
1733               accter = ffebld_new_accter (array,
1734                                           ffebit_new (ffe_pool_program_unit (),
1735                                                       ffedata_symbolsize_));
1736               ffebld_set_info (accter, ffeinfo_new
1737                                (ffedata_basictype_,
1738                                 ffedata_kindtype_,
1739                                 1,
1740                                 FFEINFO_kindENTITY,
1741                                 FFEINFO_whereCONSTANT,
1742                                 (ffedata_basictype_
1743                                  == FFEINFO_basictypeCHARACTER)
1744                                 ? 1 : FFETARGET_charactersizeNONE));
1745               ffesymbol_set_accretion (ffedata_symbol_, accter);
1746               ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_);
1747             }
1748           else
1749             {
1750               accter = ffesymbol_accretion (ffedata_symbol_);
1751               assert (ffedata_symbolsize_
1752                       == (ffetargetOffset) ffebld_accter_size (accter));
1753               array = ffebld_accter (accter);
1754             }
1755
1756           /* Put value in accretion array at desired offset. */
1757
1758           ffebld_constantarray_put
1759             (array, ffedata_basictype_, ffedata_kindtype_,
1760              offset, ffebld_constant_union (ffebld_conter (value)));
1761           ffebit_count (ffebld_accter_bits (accter), offset, FALSE,
1762                         ffedata_charexpected_,
1763                         &actual);       /* How many FALSE? */
1764           if (actual != (unsigned long int) ffedata_charexpected_)
1765             {
1766               ffebad_start (FFEBAD_DATA_MULTIPLE);
1767               ffebad_here (0, ffelex_token_where_line (token),
1768                            ffelex_token_where_column (token));
1769               ffebad_string (ffesymbol_text (ffedata_symbol_));
1770               ffebad_finish ();
1771             }
1772           ffesymbol_set_accretes (ffedata_symbol_,
1773                                   ffesymbol_accretes (ffedata_symbol_)
1774                                   - actual);    /* Decrement # of values
1775                                                    actually accreted. */
1776           ffebit_set (ffebld_accter_bits (accter), offset,
1777                       1, ffedata_charexpected_);
1778           ffesymbol_signal_unreported (ffedata_symbol_);
1779         }
1780
1781       /* If still accreting, adjust specs accordingly and return. */
1782
1783       if (++ffedata_number_ < ffedata_expected_)
1784         {
1785           ++ffedata_offset_;
1786           return TRUE;
1787         }
1788
1789       /* Else, if done accreting for this symbol, establish as initialized. */
1790
1791       if ((value != NULL)
1792           && (ffesymbol_accretes (ffedata_symbol_) == 0))
1793         {
1794           ffesymbol_set_init (ffedata_symbol_, accter);
1795           ffesymbol_set_accretion (ffedata_symbol_, NULL);
1796           ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_)));
1797           ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER);
1798           ffebld_set_arrter (ffesymbol_init (ffedata_symbol_),
1799                           ffebld_accter (ffesymbol_init (ffedata_symbol_)));
1800           ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_),
1801                                   ffedata_symbolsize_);
1802           ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0);
1803           ffecom_notify_init_symbol (ffedata_symbol_);
1804         }
1805     }
1806   else if (value != NULL)
1807     {
1808       /* Simple, direct, one-shot assignment. */
1809       ffesymbol_set_init (ffedata_symbol_, value);
1810       ffecom_notify_init_symbol (ffedata_symbol_);
1811     }
1812
1813   /* Call on advance function to get next target in list. */
1814
1815   return ffedata_advance_ ();
1816 }