gcc/f/data.c

   1 /* data.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 2002 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       ffeinfoKindtype sub_kind, low_kind, hi_kind;
 981       ffebld sub1, low1, hi1;
 982
 983       ++rank;
 984       assert (dims != NULL);
 985
 986       subscript = ffebld_head (subscripts);
 987       dim = ffebld_head (dims);
 988
 989       assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
 990       if (ffebld_op (subscript) == FFEBLD_opCONTER)
 991         {
 992           /* Force to default - it's a constant expression !  */
 993           sub_kind = ffeinfo_kindtype (ffebld_info (subscript));
 994           sub1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
 995                    sub_kind == FFEINFO_kindtypeINTEGER2 ? subscript->u.conter.expr->u.integer2 :
 996                    sub_kind == FFEINFO_kindtypeINTEGER3 ? subscript->u.conter.expr->u.integer3 :
 997                    sub_kind == FFEINFO_kindtypeINTEGER4 ? subscript->u.conter.expr->u.integer4 :
 998                         subscript->u.conter.expr->u.integer1), NULL);
 999           value = ffedata_eval_integer1_ (sub1);
1000         }
1001       else
1002         value = ffedata_eval_integer1_ (subscript);
1003
1004       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
1005       low = ffebld_left (dim);
1006       high = ffebld_right (dim);
1007
1008       if (low == NULL)
1009         lowbound = 1;
1010       else
1011         {
1012           assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
1013           if (ffebld_op (low) == FFEBLD_opCONTER)
1014             {
1015               /* Force to default - it's a constant expression !  */
1016               low_kind = ffeinfo_kindtype (ffebld_info (low));
1017               low1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
1018                         low_kind == FFEINFO_kindtypeINTEGER2 ? low->u.conter.expr->u.integer2 :
1019                         low_kind == FFEINFO_kindtypeINTEGER3 ? low->u.conter.expr->u.integer3 :
1020                         low_kind == FFEINFO_kindtypeINTEGER4 ? low->u.conter.expr->u.integer4 :
1021                                 low->u.conter.expr->u.integer1), NULL);
1022                lowbound = ffedata_eval_integer1_ (low1);
1023              }
1024            else
1025              lowbound = ffedata_eval_integer1_ (low);
1026         }
1027
1028       assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
1029       if (ffebld_op (high) == FFEBLD_opCONTER)
1030         {
1031           /* Force to default - it's a constant expression !  */
1032           hi_kind = ffeinfo_kindtype (ffebld_info (high));
1033           hi1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
1034                    hi_kind == FFEINFO_kindtypeINTEGER2 ? high->u.conter.expr->u.integer2 :
1035                    hi_kind == FFEINFO_kindtypeINTEGER3 ? high->u.conter.expr->u.integer3 :
1036                    hi_kind == FFEINFO_kindtypeINTEGER4 ? high->u.conter.expr->u.integer4 :
1037                         high->u.conter.expr->u.integer1), NULL);
1038           highbound = ffedata_eval_integer1_ (hi1);
1039         }
1040       else
1041         highbound = ffedata_eval_integer1_ (high);
1042
1043       if ((value < lowbound) || (value > highbound))
1044         {
1045           char rankstr[10];
1046
1047           sprintf (rankstr, "%d", rank);
1048           value = lowbound;
1049           ffebad_start (FFEBAD_DATA_SUBSCRIPT);
1050           ffebad_string (ffesymbol_text (ffedata_symbol_));
1051           ffebad_string (rankstr);
1052           ffebad_finish ();
1053         }
1054
1055       subscripts = ffebld_trail (subscripts);
1056       dims = ffebld_trail (dims);
1057
1058       offset += width * (value - lowbound);
1059       if (subscripts != NULL)
1060         width *= highbound - lowbound + 1;
1061     }
1062
1063   assert (dims == NULL);
1064
1065   ok = ffetarget_offset (&final, offset);
1066   assert (ok);
1067
1068   return final;
1069 }
1070
1071 /* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference
1072
1073    ffetargetCharacterSize beginpoint;
1074    ffebld endval;  // head(colon).
1075
1076    beginpoint = ffedata_eval_substr_end_(endval);
1077
1078    If beginval is NULL, returns 0.  Otherwise makes sure beginval is
1079    kindtypeINTEGERDEFAULT, makes sure its value is > 0,
1080    and returns its value minus one, or issues an error message.  */
1081
1082 static ffetargetCharacterSize
1083 ffedata_eval_substr_begin_ (ffebld expr)
1084 {
1085   ffetargetIntegerDefault val;
1086
1087   if (expr == NULL)
1088     return 0;
1089
1090   assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1091   assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);
1092
1093   val = ffedata_eval_integer1_ (expr);
1094
1095   if (val < 1)
1096     {
1097       val = 1;
1098       ffebad_start (FFEBAD_DATA_RANGE);
1099       ffest_ffebad_here_current_stmt (0);
1100       ffebad_string (ffesymbol_text (ffedata_symbol_));
1101       ffebad_finish ();
1102       ffedata_reported_error_ = TRUE;
1103     }
1104
1105   return val - 1;
1106 }
1107
1108 /* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference
1109
1110    ffetargetCharacterSize endpoint;
1111    ffebld endval;  // head(trail(colon)).
1112    ffetargetCharacterSize min;  // beginpoint of substr reference.
1113    ffetargetCharacterSize max;  // size of entity.
1114
1115    endpoint = ffedata_eval_substr_end_(endval,dflt);
1116
1117    If endval is NULL, returns max.  Otherwise makes sure endval is
1118    kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
1119    and returns its value minus one, or issues an error message.  */
1120
1121 static ffetargetCharacterSize
1122 ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
1123                           ffetargetCharacterSize max)
1124 {
1125   ffetargetIntegerDefault val;
1126
1127   if (expr == NULL)
1128     return max - 1;
1129
1130   assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1131   assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);
1132
1133   val = ffedata_eval_integer1_ (expr);
1134
1135   if ((val < (ffetargetIntegerDefault) min)
1136       || (val > (ffetargetIntegerDefault) max))
1137     {
1138       val = 1;
1139       ffebad_start (FFEBAD_DATA_RANGE);
1140       ffest_ffebad_here_current_stmt (0);
1141       ffebad_string (ffesymbol_text (ffedata_symbol_));
1142       ffebad_finish ();
1143       ffedata_reported_error_ = TRUE;
1144     }
1145
1146   return val - 1;
1147 }
1148
1149 /* ffedata_gather_ -- Gather initial values for sym into master sym inits
1150
1151    ffestorag mst;  // A typeCBLOCK or typeLOCAL aggregate.
1152    ffestorag st;  // A typeCOMMON or typeEQUIV member.
1153    ffedata_gather_(mst,st);
1154
1155    If st has any initialization info, transfer that info into mst and
1156    clear st's info.  */
1157
1158 static void
1159 ffedata_gather_ (ffestorag mst, ffestorag st)
1160 {
1161   ffesymbol s;
1162   ffesymbol s_whine;            /* Symbol to complain about in diagnostics. */
1163   ffebld b;
1164   ffetargetOffset offset;
1165   ffetargetOffset units_expected;
1166   ffebitCount actual;
1167   ffebldConstantArray array;
1168   ffebld accter;
1169   ffetargetCopyfunc fn;
1170   void *ptr1;
1171   void *ptr2;
1172   size_t size;
1173   ffeinfoBasictype bt;
1174   ffeinfoKindtype kt;
1175   ffeinfoBasictype ign_bt;
1176   ffeinfoKindtype ign_kt;
1177   ffetargetAlign units;
1178   ffebit bits;
1179   ffetargetOffset source_offset;
1180   bool whine = FALSE;
1181
1182   if (st == NULL)
1183     return;                     /* Nothing to do. */
1184
1185   s = ffestorag_symbol (st);
1186
1187   assert (s != NULL);           /* Must have a corresponding symbol (else how
1188                                    inited?). */
1189   assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */
1190   assert (ffestorag_accretion (st) == NULL);
1191
1192   if ((((b = ffesymbol_init (s)) == NULL)
1193        && ((b = ffesymbol_accretion (s)) == NULL))
1194       || (ffebld_op (b) == FFEBLD_opANY)
1195       || ((ffebld_op (b) == FFEBLD_opCONVERT)
1196           && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
1197     return;                     /* Nothing to do. */
1198
1199   /* b now holds the init/accretion expr. */
1200
1201   ffesymbol_set_init (s, NULL);
1202   ffesymbol_set_accretion (s, NULL);
1203   ffesymbol_set_accretes (s, 0);
1204
1205   s_whine = ffestorag_symbol (mst);
1206   if (s_whine == NULL)
1207     s_whine = s;
1208
1209   /* Make sure we haven't fully accreted during an array init. */
1210
1211   if (ffestorag_init (mst) != NULL)
1212     {
1213       ffebad_start (FFEBAD_DATA_MULTIPLE);
1214       ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1215       ffebad_string (ffesymbol_text (s_whine));
1216       ffebad_finish ();
1217       return;
1218     }
1219
1220   bt = ffeinfo_basictype (ffebld_info (b));
1221   kt = ffeinfo_kindtype (ffebld_info (b));
1222
1223   /* Calculate offset for aggregate area. */
1224
1225   ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
1226     ? ffebld_size (b) : 1;
1227   ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
1228                             kt);/* Find out unit size of source datum. */
1229   assert (units % ffedata_storage_units_ == 0);
1230   units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1231   offset = (ffestorag_offset (st) - ffestorag_offset (mst))
1232     / ffedata_storage_units_;
1233
1234   /* Does an accretion array exist?  If not, create it. */
1235
1236   if (ffestorag_accretion (mst) == NULL)
1237     {
1238 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1239       if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1240         {
1241           char bignum[40];
1242
1243           sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1244           ffebad_start (FFEBAD_TOO_BIG_INIT);
1245           ffebad_here (0, ffesymbol_where_line (s_whine),
1246                        ffesymbol_where_column (s_whine));
1247           ffebad_string (ffesymbol_text (s_whine));
1248           ffebad_string (bignum);
1249           ffebad_finish ();
1250         }
1251 #endif
1252       array = ffebld_constantarray_new (ffedata_storage_bt_,
1253                                 ffedata_storage_kt_, ffedata_storage_size_);
1254       accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
1255                                                      ffedata_storage_size_));
1256       ffebld_set_info (accter, ffeinfo_new
1257                        (ffedata_storage_bt_,
1258                         ffedata_storage_kt_,
1259                         1,
1260                         FFEINFO_kindENTITY,
1261                         FFEINFO_whereCONSTANT,
1262                         (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1263                         ? 1 : FFETARGET_charactersizeNONE));
1264       ffestorag_set_accretion (mst, accter);
1265       ffestorag_set_accretes (mst, ffedata_storage_size_);
1266     }
1267   else
1268     {
1269       accter = ffestorag_accretion (mst);
1270       assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1271       array = ffebld_accter (accter);
1272     }
1273
1274   /* Put value in accretion array at desired offset. */
1275
1276   fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
1277                                        bt, kt);
1278
1279   switch (ffebld_op (b))
1280     {
1281     case FFEBLD_opCONTER:
1282       ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1283                                     ffedata_storage_kt_, offset,
1284                            ffebld_constant_ptr_to_union (ffebld_conter (b)),
1285                                     bt, kt);
1286       (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1287                                    operation. */
1288       ffebit_count (ffebld_accter_bits (accter),
1289                     offset, FALSE, units_expected, &actual);    /* How many FALSE? */
1290       if (units_expected != (ffetargetOffset) actual)
1291         {
1292           ffebad_start (FFEBAD_DATA_MULTIPLE);
1293           ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1294           ffebad_string (ffesymbol_text (s));
1295           ffebad_finish ();
1296         }
1297       ffestorag_set_accretes (mst,
1298                               ffestorag_accretes (mst)
1299                               - actual);        /* Decrement # of values
1300                                                    actually accreted. */
1301       ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1302
1303       /* If done accreting for this storage area, establish as initialized. */
1304
1305       if (ffestorag_accretes (mst) == 0)
1306         {
1307           ffestorag_set_init (mst, accter);
1308           ffestorag_set_accretion (mst, NULL);
1309           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1310           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1311           ffebld_set_arrter (ffestorag_init (mst),
1312                              ffebld_accter (ffestorag_init (mst)));
1313           ffebld_arrter_set_size (ffestorag_init (mst),
1314                                   ffedata_storage_size_);
1315           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1316           ffecom_notify_init_storage (mst);
1317         }
1318
1319       return;
1320
1321     case FFEBLD_opARRTER:
1322       ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1323                              ffedata_storage_kt_, offset, ffebld_arrter (b),
1324                                       bt, kt);
1325       size *= ffebld_arrter_size (b);
1326       units_expected *= ffebld_arrter_size (b);
1327       (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1328                                    operation. */
1329       ffebit_count (ffebld_accter_bits (accter),
1330                     offset, FALSE, units_expected, &actual);    /* How many FALSE? */
1331       if (units_expected != (ffetargetOffset) actual)
1332         {
1333           ffebad_start (FFEBAD_DATA_MULTIPLE);
1334           ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1335           ffebad_string (ffesymbol_text (s));
1336           ffebad_finish ();
1337         }
1338       ffestorag_set_accretes (mst,
1339                               ffestorag_accretes (mst)
1340                               - actual);        /* Decrement # of values
1341                                                    actually accreted. */
1342       ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1343
1344       /* If done accreting for this storage area, establish as initialized. */
1345
1346       if (ffestorag_accretes (mst) == 0)
1347         {
1348           ffestorag_set_init (mst, accter);
1349           ffestorag_set_accretion (mst, NULL);
1350           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1351           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1352           ffebld_set_arrter (ffestorag_init (mst),
1353                              ffebld_accter (ffestorag_init (mst)));
1354           ffebld_arrter_set_size (ffestorag_init (mst),
1355                                   ffedata_storage_size_);
1356           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1357           ffecom_notify_init_storage (mst);
1358         }
1359
1360       return;
1361
1362     case FFEBLD_opACCTER:
1363       ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1364                              ffedata_storage_kt_, offset, ffebld_accter (b),
1365                                       bt, kt);
1366       bits = ffebld_accter_bits (b);
1367       source_offset = 0;
1368
1369       for (;;)
1370         {
1371           ffetargetOffset unexp;
1372           ffetargetOffset siz;
1373           ffebitCount length;
1374           bool value;
1375
1376           ffebit_test (bits, source_offset, &value, &length);
1377           if (length == 0)
1378             break;              /* Exit the loop early. */
1379           siz = size * length;
1380           unexp = units_expected * length;
1381           if (value)
1382             {
1383               (*fn) (ptr1, ptr2, siz);  /* Does memcpy-like operation. */
1384               ffebit_count (ffebld_accter_bits (accter),        /* How many FALSE? */
1385                             offset, FALSE, unexp, &actual);
1386               if (!whine && (unexp != (ffetargetOffset) actual))
1387                 {
1388                   whine = TRUE; /* Don't whine more than once for one gather. */
1389                   ffebad_start (FFEBAD_DATA_MULTIPLE);
1390                   ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1391                   ffebad_string (ffesymbol_text (s));
1392                   ffebad_finish ();
1393                 }
1394               ffestorag_set_accretes (mst,
1395                                       ffestorag_accretes (mst)
1396                                       - actual);        /* Decrement # of values
1397                                                            actually accreted. */
1398               ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
1399             }
1400           source_offset += length;
1401           offset += unexp;
1402           ptr1 = ((char *) ptr1) + siz;
1403           ptr2 = ((char *) ptr2) + siz;
1404         }
1405
1406       /* If done accreting for this storage area, establish as initialized. */
1407
1408       if (ffestorag_accretes (mst) == 0)
1409         {
1410           ffestorag_set_init (mst, accter);
1411           ffestorag_set_accretion (mst, NULL);
1412           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1413           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1414           ffebld_set_arrter (ffestorag_init (mst),
1415                              ffebld_accter (ffestorag_init (mst)));
1416           ffebld_arrter_set_size (ffestorag_init (mst),
1417                                   ffedata_storage_size_);
1418           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1419           ffecom_notify_init_storage (mst);
1420         }
1421
1422       return;
1423
1424     default:
1425       assert ("bad init op in gather_" == NULL);
1426       return;
1427     }
1428 }
1429
1430 /* ffedata_pop_ -- Pop an impdo stack entry
1431
1432    ffedata_pop_();  */
1433
1434 static void
1435 ffedata_pop_ ()
1436 {
1437   ffedataImpdo_ victim = ffedata_stack_;
1438
1439   assert (victim != NULL);
1440
1441   ffedata_stack_ = ffedata_stack_->outer;
1442
1443   malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
1444 }
1445
1446 /* ffedata_push_ -- Push an impdo stack entry
1447
1448    ffedata_push_();  */
1449
1450 static void
1451 ffedata_push_ ()
1452 {
1453   ffedataImpdo_ baby;
1454
1455   baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));
1456
1457   baby->outer = ffedata_stack_;
1458   ffedata_stack_ = baby;
1459 }
1460
1461 /* ffedata_value_ -- Provide an initial value
1462
1463    ffebld value;
1464    ffelexToken t;  // Points to the value.
1465    if (ffedata_value(value,t))
1466        // Everything's ok
1467
1468    Makes sure the value is ok, then remembers it according to the list
1469    provided to ffedata_begin.  */
1470
1471 static bool
1472 ffedata_value_ (ffebld value, ffelexToken token)
1473 {
1474
1475   /* If already reported an error, don't do anything. */
1476
1477   if (ffedata_reported_error_)
1478     return FALSE;
1479
1480   /* If the value is an error marker, remember we've seen one and do nothing
1481      else. */
1482
1483   if ((value != NULL)
1484       && (ffebld_op (value) == FFEBLD_opANY))
1485     {
1486       ffedata_reported_error_ = TRUE;
1487       return FALSE;
1488     }
1489
1490   /* If too many values (no more targets), complain. */
1491
1492   if (ffedata_symbol_ == NULL)
1493     {
1494       ffebad_start (FFEBAD_DATA_TOOMANY);
1495       ffebad_here (0, ffelex_token_where_line (token),
1496                    ffelex_token_where_column (token));
1497       ffebad_finish ();
1498       ffedata_reported_error_ = TRUE;
1499       return FALSE;
1500     }
1501
1502   /* If ffedata_advance_ wanted to register a complaint, do it now
1503      that we have the token to point at instead of just the start
1504      of the whole statement.  */
1505
1506   if (ffedata_reinit_)
1507     {
1508       ffebad_start (FFEBAD_DATA_REINIT);
1509       ffebad_here (0, ffelex_token_where_line (token),
1510                    ffelex_token_where_column (token));
1511       ffebad_string (ffesymbol_text (ffedata_symbol_));
1512       ffebad_finish ();
1513       ffedata_reported_error_ = TRUE;
1514       return FALSE;
1515     }
1516
1517 #if FFEGLOBAL_ENABLED
1518   if (ffesymbol_common (ffedata_symbol_) != NULL)
1519     ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token);
1520 #endif
1521
1522   /* Convert value to desired type. */
1523
1524   if (value != NULL)
1525     {
1526       if (ffedata_convert_cache_use_ == -1)
1527         value = ffeexpr_convert
1528           (value, token, NULL, ffedata_basictype_,
1529            ffedata_kindtype_, 0,
1530            (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1531            ? ffedata_charexpected_ : FFETARGET_charactersizeNONE,
1532            FFEEXPR_contextDATA);
1533       else                              /* Use the cache. */
1534         value = ffedata_convert_
1535           (value, token, NULL, ffedata_basictype_,
1536            ffedata_kindtype_, 0,
1537            (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1538            ? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
1539     }
1540
1541   /* If we couldn't, bug out. */
1542
1543   if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
1544     {
1545       ffedata_reported_error_ = TRUE;
1546       return FALSE;
1547     }
1548
1549   /* Handle the case where initializes go to a parent's storage area. */
1550
1551   if (ffedata_storage_ != NULL)
1552     {
1553       ffetargetOffset offset;
1554       ffetargetOffset units_expected;
1555       ffebitCount actual;
1556       ffebldConstantArray array;
1557       ffebld accter;
1558       ffetargetCopyfunc fn;
1559       void *ptr1;
1560       void *ptr2;
1561       size_t size;
1562       ffeinfoBasictype ign_bt;
1563       ffeinfoKindtype ign_kt;
1564       ffetargetAlign units;
1565
1566       /* Make sure we haven't fully accreted during an array init. */
1567
1568       if (ffestorag_init (ffedata_storage_) != NULL)
1569         {
1570           ffebad_start (FFEBAD_DATA_MULTIPLE);
1571           ffebad_here (0, ffelex_token_where_line (token),
1572                        ffelex_token_where_column (token));
1573           ffebad_string (ffesymbol_text (ffedata_symbol_));
1574           ffebad_finish ();
1575           ffedata_reported_error_ = TRUE;
1576           return FALSE;
1577         }
1578
1579       /* Calculate offset. */
1580
1581       offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1582
1583       /* Is offset within range?  If not, whine, but don't do anything else. */
1584
1585       if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1586         {
1587           ffebad_start (FFEBAD_DATA_RANGE);
1588           ffest_ffebad_here_current_stmt (0);
1589           ffebad_string (ffesymbol_text (ffedata_symbol_));
1590           ffebad_finish ();
1591           ffedata_reported_error_ = TRUE;
1592           return FALSE;
1593         }
1594
1595       /* Now calculate offset for aggregate area. */
1596
1597       ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
1598                                 ffedata_kindtype_);     /* Find out unit size of
1599                                                            source datum. */
1600       assert (units % ffedata_storage_units_ == 0);
1601       units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1602       offset *= units / ffedata_storage_units_;
1603       offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_))
1604                  - ffestorag_offset (ffedata_storage_))
1605         / ffedata_storage_units_;
1606
1607       assert (offset + units_expected - 1 <= ffedata_storage_size_);
1608
1609       /* Does an accretion array exist?  If not, create it. */
1610
1611       if (value != NULL)
1612         {
1613           if (ffestorag_accretion (ffedata_storage_) == NULL)
1614             {
1615 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1616               if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1617                 {
1618                   char bignum[40];
1619
1620                   sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1621                   ffebad_start (FFEBAD_TOO_BIG_INIT);
1622                   ffebad_here (0, ffelex_token_where_line (token),
1623                                ffelex_token_where_column (token));
1624                   ffebad_string (ffesymbol_text (ffedata_symbol_));
1625                   ffebad_string (bignum);
1626                   ffebad_finish ();
1627                 }
1628 #endif
1629               array = ffebld_constantarray_new
1630                 (ffedata_storage_bt_, ffedata_storage_kt_,
1631                  ffedata_storage_size_);
1632               accter = ffebld_new_accter (array,
1633                                           ffebit_new (ffe_pool_program_unit (),
1634                                                       ffedata_storage_size_));
1635               ffebld_set_info (accter, ffeinfo_new
1636                                (ffedata_storage_bt_,
1637                                 ffedata_storage_kt_,
1638                                 1,
1639                                 FFEINFO_kindENTITY,
1640                                 FFEINFO_whereCONSTANT,
1641                                 (ffedata_basictype_
1642                                  == FFEINFO_basictypeCHARACTER)
1643                                 ? 1 : FFETARGET_charactersizeNONE));
1644               ffestorag_set_accretion (ffedata_storage_, accter);
1645               ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_);
1646             }
1647           else
1648             {
1649               accter = ffestorag_accretion (ffedata_storage_);
1650               assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1651               array = ffebld_accter (accter);
1652             }
1653
1654           /* Put value in accretion array at desired offset. */
1655
1656           fn = ffetarget_aggregate_ptr_memcpy
1657             (ffedata_storage_bt_, ffedata_storage_kt_,
1658              ffedata_basictype_, ffedata_kindtype_);
1659           ffebld_constantarray_prepare
1660             (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1661              ffedata_storage_kt_, offset,
1662              ffebld_constant_ptr_to_union (ffebld_conter (value)),
1663              ffedata_basictype_, ffedata_kindtype_);
1664           (*fn) (ptr1, ptr2, size);     /* Does the appropriate memcpy-like
1665                                            operation. */
1666           ffebit_count (ffebld_accter_bits (accter),
1667                         offset, FALSE, units_expected,
1668                         &actual);       /* How many FALSE? */
1669           if (units_expected != (ffetargetOffset) actual)
1670             {
1671               ffebad_start (FFEBAD_DATA_MULTIPLE);
1672               ffebad_here (0, ffelex_token_where_line (token),
1673                            ffelex_token_where_column (token));
1674               ffebad_string (ffesymbol_text (ffedata_symbol_));
1675               ffebad_finish ();
1676             }
1677           ffestorag_set_accretes (ffedata_storage_,
1678                                   ffestorag_accretes (ffedata_storage_)
1679                                   - actual);    /* Decrement # of values
1680                                                    actually accreted. */
1681           ffebit_set (ffebld_accter_bits (accter), offset,
1682                       1, units_expected);
1683
1684           /* If done accreting for this storage area, establish as
1685              initialized. */
1686
1687           if (ffestorag_accretes (ffedata_storage_) == 0)
1688             {
1689               ffestorag_set_init (ffedata_storage_, accter);
1690               ffestorag_set_accretion (ffedata_storage_, NULL);
1691               ffebit_kill (ffebld_accter_bits
1692                            (ffestorag_init (ffedata_storage_)));
1693               ffebld_set_op (ffestorag_init (ffedata_storage_),
1694                              FFEBLD_opARRTER);
1695               ffebld_set_arrter
1696                 (ffestorag_init (ffedata_storage_),
1697                  ffebld_accter (ffestorag_init (ffedata_storage_)));
1698               ffebld_arrter_set_size (ffestorag_init (ffedata_storage_),
1699                                       ffedata_storage_size_);
1700               ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_),
1701                                      0);
1702               ffecom_notify_init_storage (ffedata_storage_);
1703             }
1704         }
1705
1706       /* If still accreting, adjust specs accordingly and return. */
1707
1708       if (++ffedata_number_ < ffedata_expected_)
1709         {
1710           ++ffedata_offset_;
1711           return TRUE;
1712         }
1713
1714       return ffedata_advance_ ();
1715     }
1716
1717   /* Figure out where the value goes -- in an accretion array or directly
1718      into the final initial-value slot for the symbol. */
1719
1720   if ((ffedata_number_ != 0)
1721       || (ffedata_arraysize_ > 1)
1722       || (ffedata_charnumber_ != 0)
1723       || (ffedata_size_ > ffedata_charexpected_))
1724     {                           /* Accrete this value. */
1725       ffetargetOffset offset;
1726       ffebitCount actual;
1727       ffebldConstantArray array;
1728       ffebld accter = NULL;
1729
1730       /* Calculate offset. */
1731
1732       offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1733
1734       /* Is offset within range?  If not, whine, but don't do anything else. */
1735
1736       if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1737         {
1738           ffebad_start (FFEBAD_DATA_RANGE);
1739           ffest_ffebad_here_current_stmt (0);
1740           ffebad_string (ffesymbol_text (ffedata_symbol_));
1741           ffebad_finish ();
1742           ffedata_reported_error_ = TRUE;
1743           return FALSE;
1744         }
1745
1746       /* Does an accretion array exist?  If not, create it. */
1747
1748       if (value != NULL)
1749         {
1750           if (ffesymbol_accretion (ffedata_symbol_) == NULL)
1751             {
1752 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1753               if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ )
1754                 {
1755                   char bignum[40];
1756
1757                   sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_);
1758                   ffebad_start (FFEBAD_TOO_BIG_INIT);
1759                   ffebad_here (0, ffelex_token_where_line (token),
1760                                ffelex_token_where_column (token));
1761                   ffebad_string (ffesymbol_text (ffedata_symbol_));
1762                   ffebad_string (bignum);
1763                   ffebad_finish ();
1764                 }
1765 #endif
1766               array = ffebld_constantarray_new
1767                 (ffedata_basictype_, ffedata_kindtype_,
1768                  ffedata_symbolsize_);
1769               accter = ffebld_new_accter (array,
1770                                           ffebit_new (ffe_pool_program_unit (),
1771                                                       ffedata_symbolsize_));
1772               ffebld_set_info (accter, ffeinfo_new
1773                                (ffedata_basictype_,
1774                                 ffedata_kindtype_,
1775                                 1,
1776                                 FFEINFO_kindENTITY,
1777                                 FFEINFO_whereCONSTANT,
1778                                 (ffedata_basictype_
1779                                  == FFEINFO_basictypeCHARACTER)
1780                                 ? 1 : FFETARGET_charactersizeNONE));
1781               ffesymbol_set_accretion (ffedata_symbol_, accter);
1782               ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_);
1783             }
1784           else
1785             {
1786               accter = ffesymbol_accretion (ffedata_symbol_);
1787               assert (ffedata_symbolsize_
1788                       == (ffetargetOffset) ffebld_accter_size (accter));
1789               array = ffebld_accter (accter);
1790             }
1791
1792           /* Put value in accretion array at desired offset. */
1793
1794           ffebld_constantarray_put
1795             (array, ffedata_basictype_, ffedata_kindtype_,
1796              offset, ffebld_constant_union (ffebld_conter (value)));
1797           ffebit_count (ffebld_accter_bits (accter), offset, FALSE,
1798                         ffedata_charexpected_,
1799                         &actual);       /* How many FALSE? */
1800           if (actual != (unsigned long int) ffedata_charexpected_)
1801             {
1802               ffebad_start (FFEBAD_DATA_MULTIPLE);
1803               ffebad_here (0, ffelex_token_where_line (token),
1804                            ffelex_token_where_column (token));
1805               ffebad_string (ffesymbol_text (ffedata_symbol_));
1806               ffebad_finish ();
1807             }
1808           ffesymbol_set_accretes (ffedata_symbol_,
1809                                   ffesymbol_accretes (ffedata_symbol_)
1810                                   - actual);    /* Decrement # of values
1811                                                    actually accreted. */
1812           ffebit_set (ffebld_accter_bits (accter), offset,
1813                       1, ffedata_charexpected_);
1814           ffesymbol_signal_unreported (ffedata_symbol_);
1815         }
1816
1817       /* If still accreting, adjust specs accordingly and return. */
1818
1819       if (++ffedata_number_ < ffedata_expected_)
1820         {
1821           ++ffedata_offset_;
1822           return TRUE;
1823         }
1824
1825       /* Else, if done accreting for this symbol, establish as initialized. */
1826
1827       if ((value != NULL)
1828           && (ffesymbol_accretes (ffedata_symbol_) == 0))
1829         {
1830           ffesymbol_set_init (ffedata_symbol_, accter);
1831           ffesymbol_set_accretion (ffedata_symbol_, NULL);
1832           ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_)));
1833           ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER);
1834           ffebld_set_arrter (ffesymbol_init (ffedata_symbol_),
1835                           ffebld_accter (ffesymbol_init (ffedata_symbol_)));
1836           ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_),
1837                                   ffedata_symbolsize_);
1838           ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0);
1839           ffecom_notify_init_symbol (ffedata_symbol_);
1840         }
1841     }
1842   else if (value != NULL)
1843     {
1844       /* Simple, direct, one-shot assignment. */
1845       ffesymbol_set_init (ffedata_symbol_, value);
1846       ffecom_notify_init_symbol (ffedata_symbol_);
1847     }
1848
1849   /* Call on advance function to get next target in list. */
1850
1851   return ffedata_advance_ ();
1852 }