contrib/gcc-3.4/gcc/f/data.c

   1 /* data.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 2002, 2003 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_ (void)
 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         if (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
 595           {
 596             ffebad_start (FFEBAD_DATA_EVAL);
 597             ffest_ffebad_here_current_stmt (0);
 598             ffebad_finish ();
 599             ffedata_pop_ ();
 600             ffedata_reported_error_ = TRUE;
 601             return FALSE;
 602           }
 603         assert (ffeinfo_basictype (ffebld_info (start))
 604                 == FFEINFO_basictypeINTEGER);
 605         assert (ffeinfo_kindtype (ffebld_info (start))
 606                 == FFEINFO_kindtypeINTEGERDEFAULT);
 607         ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start));
 608         if (ffeinfo_basictype (ffebld_info (end)) != FFEINFO_basictypeINTEGER)
 609           {
 610             ffebad_start (FFEBAD_DATA_EVAL);
 611             ffest_ffebad_here_current_stmt (0);
 612             ffebad_finish ();
 613             ffedata_pop_ ();
 614             ffedata_reported_error_ = TRUE;
 615             return FALSE;
 616           }
 617         assert (ffeinfo_basictype (ffebld_info (end))
 618                 == FFEINFO_basictypeINTEGER);
 619         assert (ffeinfo_kindtype (ffebld_info (end))
 620                 == FFEINFO_kindtypeINTEGERDEFAULT);
 621         ffedata_stack_->final = ffedata_eval_integer1_ (end);
 622
 623         if (incr == NULL)
 624           ffedata_stack_->increment = 1;
 625         else
 626           {
 627             if (ffeinfo_basictype (ffebld_info (incr)) != FFEINFO_basictypeINTEGER)
 628               {
 629                 ffebad_start (FFEBAD_DATA_EVAL);
 630                 ffest_ffebad_here_current_stmt (0);
 631                 ffebad_finish ();
 632                 ffedata_pop_ ();
 633                 ffedata_reported_error_ = TRUE;
 634                 return FALSE;
 635               }
 636             assert (ffeinfo_basictype (ffebld_info (incr))
 637                     == FFEINFO_basictypeINTEGER);
 638             assert (ffeinfo_kindtype (ffebld_info (incr))
 639                     == FFEINFO_kindtypeINTEGERDEFAULT);
 640             ffedata_stack_->increment = ffedata_eval_integer1_ (incr);
 641             if (ffedata_stack_->increment == 0)
 642               {
 643                 ffebad_start (FFEBAD_DATA_ZERO);
 644                 ffest_ffebad_here_current_stmt (0);
 645                 ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
 646                 ffebad_finish ();
 647                 ffedata_pop_ ();
 648                 ffedata_reported_error_ = TRUE;
 649                 return FALSE;
 650               }
 651           }
 652
 653         if ((ffedata_stack_->increment > 0)
 654             ? ffesymbol_value (ffedata_stack_->itervar)
 655             > ffedata_stack_->final
 656             : ffesymbol_value (ffedata_stack_->itervar)
 657             < ffedata_stack_->final)
 658           {
 659             ffedata_reported_error_ = TRUE;
 660             ffebad_start (FFEBAD_DATA_EMPTY);
 661             ffest_ffebad_here_current_stmt (0);
 662             ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
 663             ffebad_finish ();
 664             ffedata_pop_ ();
 665             return FALSE;
 666           }
 667       }
 668       goto tail_recurse;        /* :::::::::::::::::::: */
 669
 670     case FFEBLD_opANY:
 671       ffedata_reported_error_ = TRUE;
 672       return FALSE;
 673
 674     default:
 675       assert ("bad op" == NULL);
 676       break;
 677     }
 678
 679   return TRUE;
 680 }
 681
 682 /* ffedata_convert_ -- Convert source expression to given type using cache
 683
 684    ffebld source;
 685    ffelexToken source_token;
 686    ffelexToken dest_token;  // Any appropriate token for "destination".
 687    ffeinfoBasictype bt;
 688    ffeinfoKindtype kt;
 689    ffetargetCharactersize sz;
 690    source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);
 691
 692    Like ffeexpr_convert, but calls it only if necessary (if the converted
 693    expression doesn't already exist in the cache) and then puts the result
 694    in the cache.  */
 695
 696 static ffebld
 697 ffedata_convert_ (ffebld source, ffelexToken source_token,
 698                   ffelexToken dest_token, ffeinfoBasictype bt,
 699                   ffeinfoKindtype kt, ffeinfoRank rk,
 700                   ffetargetCharacterSize sz)
 701 {
 702   ffebld converted;
 703   int i;
 704   int max;
 705   ffedataConvertCache_ cache;
 706
 707   for (i = 0; i < ffedata_convert_cache_use_; ++i)
 708     if ((bt == ffedata_convert_cache_[i].basic_type)
 709         && (kt == ffedata_convert_cache_[i].kind_type)
 710         && (sz == ffedata_convert_cache_[i].size)
 711         && (rk == ffedata_convert_cache_[i].rank))
 712       return ffedata_convert_cache_[i].converted;
 713
 714   converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk,
 715                                sz, FFEEXPR_contextDATA);
 716
 717   if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_)
 718     {
 719       if (ffedata_convert_cache_max_ == 0)
 720         max = 4;
 721       else
 722         max = ffedata_convert_cache_max_ << 1;
 723
 724       if (max > ffedata_convert_cache_max_)
 725         {
 726           cache = malloc_new_ks (malloc_pool_image (),
 727                                  "FFEDATA cache", max * sizeof (*cache));
 728           if (ffedata_convert_cache_max_ != 0)
 729             {
 730               memcpy (cache, ffedata_convert_cache_,
 731                       ffedata_convert_cache_max_ * sizeof (*cache));
 732               malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_,
 733                               ffedata_convert_cache_max_ * sizeof (*cache));
 734             }
 735           ffedata_convert_cache_ = cache;
 736           ffedata_convert_cache_max_ = max;
 737         }
 738       else
 739         return converted;       /* In case int overflows! */
 740     }
 741
 742   i = ffedata_convert_cache_use_++;
 743
 744   ffedata_convert_cache_[i].converted = converted;
 745   ffedata_convert_cache_[i].basic_type = bt;
 746   ffedata_convert_cache_[i].kind_type = kt;
 747   ffedata_convert_cache_[i].size = sz;
 748   ffedata_convert_cache_[i].rank = rk;
 749
 750   return converted;
 751 }
 752
 753 /* ffedata_eval_integer1_ -- Evaluate expression
 754
 755    ffetargetIntegerDefault result;
 756    ffebld expr;  // must be kindtypeINTEGER1.
 757
 758    result = ffedata_eval_integer1_(expr);
 759
 760    Evalues the expression (which yields a kindtypeINTEGER1 result) and
 761    returns the result.  */
 762
 763 static ffetargetIntegerDefault
 764 ffedata_eval_integer1_ (ffebld expr)
 765 {
 766   ffetargetInteger1 result;
 767   ffebad error;
 768
 769   assert (expr != NULL);
 770
 771   switch (ffebld_op (expr))
 772     {
 773     case FFEBLD_opCONTER:
 774       return ffebld_constant_integer1 (ffebld_conter (expr));
 775
 776     case FFEBLD_opSYMTER:
 777       return ffesymbol_value (ffebld_symter (expr));
 778
 779     case FFEBLD_opUPLUS:
 780       return ffedata_eval_integer1_ (ffebld_left (expr));
 781
 782     case FFEBLD_opUMINUS:
 783       error = ffetarget_uminus_integer1 (&result,
 784                                ffedata_eval_integer1_ (ffebld_left (expr)));
 785       break;
 786
 787     case FFEBLD_opADD:
 788       error = ffetarget_add_integer1 (&result,
 789                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 790                               ffedata_eval_integer1_ (ffebld_right (expr)));
 791       break;
 792
 793     case FFEBLD_opSUBTRACT:
 794       error = ffetarget_subtract_integer1 (&result,
 795                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 796                               ffedata_eval_integer1_ (ffebld_right (expr)));
 797       break;
 798
 799     case FFEBLD_opMULTIPLY:
 800       error = ffetarget_multiply_integer1 (&result,
 801                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 802                               ffedata_eval_integer1_ (ffebld_right (expr)));
 803       break;
 804
 805     case FFEBLD_opDIVIDE:
 806       error = ffetarget_divide_integer1 (&result,
 807                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 808                               ffedata_eval_integer1_ (ffebld_right (expr)));
 809       break;
 810
 811     case FFEBLD_opPOWER:
 812       {
 813         ffebld r = ffebld_right (expr);
 814
 815         if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
 816             || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
 817           error = FFEBAD_DATA_EVAL;
 818         else
 819           error = ffetarget_power_integerdefault_integerdefault (&result,
 820                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 821                                                 ffedata_eval_integer1_ (r));
 822       }
 823       break;
 824
 825 #if 0                           /* Only for character basictype. */
 826     case FFEBLD_opCONCATENATE:
 827       error =;
 828       break;
 829 #endif
 830
 831     case FFEBLD_opNOT:
 832       error = ffetarget_not_integer1 (&result,
 833                                ffedata_eval_integer1_ (ffebld_left (expr)));
 834       break;
 835
 836 #if 0                           /* Only for logical basictype. */
 837     case FFEBLD_opLT:
 838       error =;
 839       break;
 840
 841     case FFEBLD_opLE:
 842       error =;
 843       break;
 844
 845     case FFEBLD_opEQ:
 846       error =;
 847       break;
 848
 849     case FFEBLD_opNE:
 850       error =;
 851       break;
 852
 853     case FFEBLD_opGT:
 854       error =;
 855       break;
 856
 857     case FFEBLD_opGE:
 858       error =;
 859       break;
 860 #endif
 861
 862     case FFEBLD_opAND:
 863       error = ffetarget_and_integer1 (&result,
 864                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 865                               ffedata_eval_integer1_ (ffebld_right (expr)));
 866       break;
 867
 868     case FFEBLD_opOR:
 869       error = ffetarget_or_integer1 (&result,
 870                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 871                               ffedata_eval_integer1_ (ffebld_right (expr)));
 872       break;
 873
 874     case FFEBLD_opXOR:
 875       error = ffetarget_xor_integer1 (&result,
 876                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 877                               ffedata_eval_integer1_ (ffebld_right (expr)));
 878       break;
 879
 880     case FFEBLD_opEQV:
 881       error = ffetarget_eqv_integer1 (&result,
 882                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 883                               ffedata_eval_integer1_ (ffebld_right (expr)));
 884       break;
 885
 886     case FFEBLD_opNEQV:
 887       error = ffetarget_neqv_integer1 (&result,
 888                                 ffedata_eval_integer1_ (ffebld_left (expr)),
 889                               ffedata_eval_integer1_ (ffebld_right (expr)));
 890       break;
 891
 892     case FFEBLD_opPAREN:
 893       return ffedata_eval_integer1_ (ffebld_left (expr));
 894
 895 #if 0                           /* ~~ no idea how to do this */
 896     case FFEBLD_opPERCENT_LOC:
 897       error =;
 898       break;
 899 #endif
 900
 901 #if 0                           /* not allowed by ANSI, but perhaps as an
 902                                    extension someday? */
 903     case FFEBLD_opCONVERT:
 904       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
 905         {
 906         case FFEINFO_basictypeINTEGER:
 907           switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
 908             {
 909             default:
 910               error = FFEBAD_DATA_EVAL;
 911               break;
 912             }
 913           break;
 914
 915         case FFEINFO_basictypeREAL:
 916           switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
 917             {
 918             default:
 919               error = FFEBAD_DATA_EVAL;
 920               break;
 921             }
 922           break;
 923         }
 924       break;
 925 #endif
 926
 927 #if 0                           /* not valid ops */
 928     case FFEBLD_opREPEAT:
 929       error =;
 930       break;
 931
 932     case FFEBLD_opBOUNDS:
 933       error =;
 934       break;
 935 #endif
 936
 937 #if 0                           /* not allowed by ANSI, but perhaps as an
 938                                    extension someday? */
 939     case FFEBLD_opFUNCREF:
 940       error =;
 941       break;
 942 #endif
 943
 944 #if 0                           /* not valid ops */
 945     case FFEBLD_opSUBRREF:
 946       error =;
 947       break;
 948
 949     case FFEBLD_opARRAYREF:
 950       error =;
 951       break;
 952 #endif
 953
 954 #if 0                           /* not valid for integer1 */
 955     case FFEBLD_opSUBSTR:
 956       error =;
 957       break;
 958 #endif
 959
 960     default:
 961       error = FFEBAD_DATA_EVAL;
 962       break;
 963     }
 964
 965   if (error != FFEBAD)
 966     {
 967       ffebad_start (error);
 968       ffest_ffebad_here_current_stmt (0);
 969       ffebad_finish ();
 970       result = 0;
 971     }
 972
 973   return result;
 974 }
 975
 976 /* ffedata_eval_offset_ -- Evaluate offset info array
 977
 978    ffetargetOffset offset;  // 0...max-1.
 979    ffebld subscripts;  // an opITEM list of subscript exprs.
 980    ffebld dims;  // an opITEM list of opBOUNDS exprs.
 981
 982    result = ffedata_eval_offset_(expr);
 983
 984    Evalues the expression (which yields a kindtypeINTEGER1 result) and
 985    returns the result.  */
 986
 987 static ffetargetOffset
 988 ffedata_eval_offset_ (ffebld subscripts, ffebld dims)
 989 {
 990   ffetargetIntegerDefault offset = 0;
 991   ffetargetIntegerDefault width = 1;
 992   ffetargetIntegerDefault value;
 993   ffetargetIntegerDefault lowbound;
 994   ffetargetIntegerDefault highbound;
 995   ffetargetOffset final;
 996   ffebld subscript;
 997   ffebld dim;
 998   ffebld low;
 999   ffebld high;
1000   int rank = 0;
1001   bool ok;
1002
1003   while (subscripts != NULL)
1004     {
1005       ffeinfoKindtype sub_kind, low_kind, hi_kind;
1006       ffebld sub1, low1, hi1;
1007
1008       ++rank;
1009       assert (dims != NULL);
1010
1011       subscript = ffebld_head (subscripts);
1012       dim = ffebld_head (dims);
1013
1014       assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
1015       if (ffebld_op (subscript) == FFEBLD_opCONTER)
1016         {
1017           /* Force to default - it's a constant expression !  */
1018           sub_kind = ffeinfo_kindtype (ffebld_info (subscript));
1019           sub1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
1020                    sub_kind == FFEINFO_kindtypeINTEGER2 ? subscript->u.conter.expr->u.integer2 :
1021                    sub_kind == FFEINFO_kindtypeINTEGER3 ? subscript->u.conter.expr->u.integer3 :
1022                    sub_kind == FFEINFO_kindtypeINTEGER4 ? subscript->u.conter.expr->u.integer4 :
1023                         subscript->u.conter.expr->u.integer1), NULL);
1024           value = ffedata_eval_integer1_ (sub1);
1025         }
1026       else
1027         value = ffedata_eval_integer1_ (subscript);
1028
1029       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
1030       low = ffebld_left (dim);
1031       high = ffebld_right (dim);
1032
1033       if (low == NULL)
1034         lowbound = 1;
1035       else
1036         {
1037           assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
1038           if (ffebld_op (low) == FFEBLD_opCONTER)
1039             {
1040               /* Force to default - it's a constant expression !  */
1041               low_kind = ffeinfo_kindtype (ffebld_info (low));
1042               low1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
1043                         low_kind == FFEINFO_kindtypeINTEGER2 ? low->u.conter.expr->u.integer2 :
1044                         low_kind == FFEINFO_kindtypeINTEGER3 ? low->u.conter.expr->u.integer3 :
1045                         low_kind == FFEINFO_kindtypeINTEGER4 ? low->u.conter.expr->u.integer4 :
1046                                 low->u.conter.expr->u.integer1), NULL);
1047                lowbound = ffedata_eval_integer1_ (low1);
1048              }
1049            else
1050              lowbound = ffedata_eval_integer1_ (low);
1051         }
1052
1053       assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
1054       if (ffebld_op (high) == FFEBLD_opCONTER)
1055         {
1056           /* Force to default - it's a constant expression !  */
1057           hi_kind = ffeinfo_kindtype (ffebld_info (high));
1058           hi1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
1059                    hi_kind == FFEINFO_kindtypeINTEGER2 ? high->u.conter.expr->u.integer2 :
1060                    hi_kind == FFEINFO_kindtypeINTEGER3 ? high->u.conter.expr->u.integer3 :
1061                    hi_kind == FFEINFO_kindtypeINTEGER4 ? high->u.conter.expr->u.integer4 :
1062                         high->u.conter.expr->u.integer1), NULL);
1063           highbound = ffedata_eval_integer1_ (hi1);
1064         }
1065       else
1066         highbound = ffedata_eval_integer1_ (high);
1067
1068       if ((value < lowbound) || (value > highbound))
1069         {
1070           char rankstr[10];
1071
1072           sprintf (rankstr, "%d", rank);
1073           value = lowbound;
1074           ffebad_start (FFEBAD_DATA_SUBSCRIPT);
1075           ffebad_string (ffesymbol_text (ffedata_symbol_));
1076           ffebad_string (rankstr);
1077           ffebad_finish ();
1078         }
1079
1080       subscripts = ffebld_trail (subscripts);
1081       dims = ffebld_trail (dims);
1082
1083       offset += width * (value - lowbound);
1084       if (subscripts != NULL)
1085         width *= highbound - lowbound + 1;
1086     }
1087
1088   assert (dims == NULL);
1089
1090   ok = ffetarget_offset (&final, offset);
1091   assert (ok);
1092
1093   return final;
1094 }
1095
1096 /* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference
1097
1098    ffetargetCharacterSize beginpoint;
1099    ffebld endval;  // head(colon).
1100
1101    beginpoint = ffedata_eval_substr_end_(endval);
1102
1103    If beginval is NULL, returns 0.  Otherwise makes sure beginval is
1104    kindtypeINTEGERDEFAULT, makes sure its value is > 0,
1105    and returns its value minus one, or issues an error message.  */
1106
1107 static ffetargetCharacterSize
1108 ffedata_eval_substr_begin_ (ffebld expr)
1109 {
1110   ffetargetIntegerDefault val;
1111
1112   if (expr == NULL)
1113     return 0;
1114
1115   assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1116   assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);
1117
1118   val = ffedata_eval_integer1_ (expr);
1119
1120   if (val < 1)
1121     {
1122       val = 1;
1123       ffebad_start (FFEBAD_DATA_RANGE);
1124       ffest_ffebad_here_current_stmt (0);
1125       ffebad_string (ffesymbol_text (ffedata_symbol_));
1126       ffebad_finish ();
1127       ffedata_reported_error_ = TRUE;
1128     }
1129
1130   return val - 1;
1131 }
1132
1133 /* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference
1134
1135    ffetargetCharacterSize endpoint;
1136    ffebld endval;  // head(trail(colon)).
1137    ffetargetCharacterSize min;  // beginpoint of substr reference.
1138    ffetargetCharacterSize max;  // size of entity.
1139
1140    endpoint = ffedata_eval_substr_end_(endval,dflt);
1141
1142    If endval is NULL, returns max.  Otherwise makes sure endval is
1143    kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
1144    and returns its value minus one, or issues an error message.  */
1145
1146 static ffetargetCharacterSize
1147 ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
1148                           ffetargetCharacterSize max)
1149 {
1150   ffetargetIntegerDefault val;
1151
1152   if (expr == NULL)
1153     return max - 1;
1154
1155   assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1156   assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);
1157
1158   val = ffedata_eval_integer1_ (expr);
1159
1160   if ((val < (ffetargetIntegerDefault) min)
1161       || (val > (ffetargetIntegerDefault) max))
1162     {
1163       val = 1;
1164       ffebad_start (FFEBAD_DATA_RANGE);
1165       ffest_ffebad_here_current_stmt (0);
1166       ffebad_string (ffesymbol_text (ffedata_symbol_));
1167       ffebad_finish ();
1168       ffedata_reported_error_ = TRUE;
1169     }
1170
1171   return val - 1;
1172 }
1173
1174 /* ffedata_gather_ -- Gather initial values for sym into master sym inits
1175
1176    ffestorag mst;  // A typeCBLOCK or typeLOCAL aggregate.
1177    ffestorag st;  // A typeCOMMON or typeEQUIV member.
1178    ffedata_gather_(mst,st);
1179
1180    If st has any initialization info, transfer that info into mst and
1181    clear st's info.  */
1182
1183 static void
1184 ffedata_gather_ (ffestorag mst, ffestorag st)
1185 {
1186   ffesymbol s;
1187   ffesymbol s_whine;            /* Symbol to complain about in diagnostics. */
1188   ffebld b;
1189   ffetargetOffset offset;
1190   ffetargetOffset units_expected;
1191   ffebitCount actual;
1192   ffebldConstantArray array;
1193   ffebld accter;
1194   ffetargetCopyfunc fn;
1195   void *ptr1;
1196   void *ptr2;
1197   size_t size;
1198   ffeinfoBasictype bt;
1199   ffeinfoKindtype kt;
1200   ffeinfoBasictype ign_bt;
1201   ffeinfoKindtype ign_kt;
1202   ffetargetAlign units;
1203   ffebit bits;
1204   ffetargetOffset source_offset;
1205   bool whine = FALSE;
1206
1207   if (st == NULL)
1208     return;                     /* Nothing to do. */
1209
1210   s = ffestorag_symbol (st);
1211
1212   assert (s != NULL);           /* Must have a corresponding symbol (else how
1213                                    inited?). */
1214   assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */
1215   assert (ffestorag_accretion (st) == NULL);
1216
1217   if ((((b = ffesymbol_init (s)) == NULL)
1218        && ((b = ffesymbol_accretion (s)) == NULL))
1219       || (ffebld_op (b) == FFEBLD_opANY)
1220       || ((ffebld_op (b) == FFEBLD_opCONVERT)
1221           && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
1222     return;                     /* Nothing to do. */
1223
1224   /* b now holds the init/accretion expr. */
1225
1226   ffesymbol_set_init (s, NULL);
1227   ffesymbol_set_accretion (s, NULL);
1228   ffesymbol_set_accretes (s, 0);
1229
1230   s_whine = ffestorag_symbol (mst);
1231   if (s_whine == NULL)
1232     s_whine = s;
1233
1234   /* Make sure we haven't fully accreted during an array init. */
1235
1236   if (ffestorag_init (mst) != NULL)
1237     {
1238       ffebad_start (FFEBAD_DATA_MULTIPLE);
1239       ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1240       ffebad_string (ffesymbol_text (s_whine));
1241       ffebad_finish ();
1242       return;
1243     }
1244
1245   bt = ffeinfo_basictype (ffebld_info (b));
1246   kt = ffeinfo_kindtype (ffebld_info (b));
1247
1248   /* Calculate offset for aggregate area. */
1249
1250   ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
1251     ? ffebld_size (b) : 1;
1252   ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
1253                             kt);/* Find out unit size of source datum. */
1254   assert (units % ffedata_storage_units_ == 0);
1255   units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1256   offset = (ffestorag_offset (st) - ffestorag_offset (mst))
1257     / ffedata_storage_units_;
1258
1259   /* Does an accretion array exist?  If not, create it. */
1260
1261   if (ffestorag_accretion (mst) == NULL)
1262     {
1263 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1264       if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1265         {
1266           char bignum[40];
1267
1268           sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1269           ffebad_start (FFEBAD_TOO_BIG_INIT);
1270           ffebad_here (0, ffesymbol_where_line (s_whine),
1271                        ffesymbol_where_column (s_whine));
1272           ffebad_string (ffesymbol_text (s_whine));
1273           ffebad_string (bignum);
1274           ffebad_finish ();
1275         }
1276 #endif
1277       array = ffebld_constantarray_new (ffedata_storage_bt_,
1278                                 ffedata_storage_kt_, ffedata_storage_size_);
1279       accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
1280                                                      ffedata_storage_size_));
1281       ffebld_set_info (accter, ffeinfo_new
1282                        (ffedata_storage_bt_,
1283                         ffedata_storage_kt_,
1284                         1,
1285                         FFEINFO_kindENTITY,
1286                         FFEINFO_whereCONSTANT,
1287                         (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1288                         ? 1 : FFETARGET_charactersizeNONE));
1289       ffestorag_set_accretion (mst, accter);
1290       ffestorag_set_accretes (mst, ffedata_storage_size_);
1291     }
1292   else
1293     {
1294       accter = ffestorag_accretion (mst);
1295       assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1296       array = ffebld_accter (accter);
1297     }
1298
1299   /* Put value in accretion array at desired offset. */
1300
1301   fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
1302                                        bt, kt);
1303
1304   switch (ffebld_op (b))
1305     {
1306     case FFEBLD_opCONTER:
1307       ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1308                                     ffedata_storage_kt_, offset,
1309                            ffebld_constant_ptr_to_union (ffebld_conter (b)),
1310                                     bt, kt);
1311       (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1312                                    operation. */
1313       ffebit_count (ffebld_accter_bits (accter),
1314                     offset, FALSE, units_expected, &actual);    /* How many FALSE? */
1315       if (units_expected != (ffetargetOffset) actual)
1316         {
1317           ffebad_start (FFEBAD_DATA_MULTIPLE);
1318           ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1319           ffebad_string (ffesymbol_text (s));
1320           ffebad_finish ();
1321         }
1322       ffestorag_set_accretes (mst,
1323                               ffestorag_accretes (mst)
1324                               - actual);        /* Decrement # of values
1325                                                    actually accreted. */
1326       ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1327
1328       /* If done accreting for this storage area, establish as initialized. */
1329
1330       if (ffestorag_accretes (mst) == 0)
1331         {
1332           ffestorag_set_init (mst, accter);
1333           ffestorag_set_accretion (mst, NULL);
1334           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1335           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1336           ffebld_set_arrter (ffestorag_init (mst),
1337                              ffebld_accter (ffestorag_init (mst)));
1338           ffebld_arrter_set_size (ffestorag_init (mst),
1339                                   ffedata_storage_size_);
1340           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1341           ffecom_notify_init_storage (mst);
1342         }
1343
1344       return;
1345
1346     case FFEBLD_opARRTER:
1347       ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1348                              ffedata_storage_kt_, offset, ffebld_arrter (b),
1349                                       bt, kt);
1350       size *= ffebld_arrter_size (b);
1351       units_expected *= ffebld_arrter_size (b);
1352       (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1353                                    operation. */
1354       ffebit_count (ffebld_accter_bits (accter),
1355                     offset, FALSE, units_expected, &actual);    /* How many FALSE? */
1356       if (units_expected != (ffetargetOffset) actual)
1357         {
1358           ffebad_start (FFEBAD_DATA_MULTIPLE);
1359           ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1360           ffebad_string (ffesymbol_text (s));
1361           ffebad_finish ();
1362         }
1363       ffestorag_set_accretes (mst,
1364                               ffestorag_accretes (mst)
1365                               - actual);        /* Decrement # of values
1366                                                    actually accreted. */
1367       ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1368
1369       /* If done accreting for this storage area, establish as initialized. */
1370
1371       if (ffestorag_accretes (mst) == 0)
1372         {
1373           ffestorag_set_init (mst, accter);
1374           ffestorag_set_accretion (mst, NULL);
1375           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1376           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1377           ffebld_set_arrter (ffestorag_init (mst),
1378                              ffebld_accter (ffestorag_init (mst)));
1379           ffebld_arrter_set_size (ffestorag_init (mst),
1380                                   ffedata_storage_size_);
1381           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1382           ffecom_notify_init_storage (mst);
1383         }
1384
1385       return;
1386
1387     case FFEBLD_opACCTER:
1388       ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1389                              ffedata_storage_kt_, offset, ffebld_accter (b),
1390                                       bt, kt);
1391       bits = ffebld_accter_bits (b);
1392       source_offset = 0;
1393
1394       for (;;)
1395         {
1396           ffetargetOffset unexp;
1397           ffetargetOffset siz;
1398           ffebitCount length;
1399           bool value;
1400
1401           ffebit_test (bits, source_offset, &value, &length);
1402           if (length == 0)
1403             break;              /* Exit the loop early. */
1404           siz = size * length;
1405           unexp = units_expected * length;
1406           if (value)
1407             {
1408               (*fn) (ptr1, ptr2, siz);  /* Does memcpy-like operation. */
1409               ffebit_count (ffebld_accter_bits (accter),        /* How many FALSE? */
1410                             offset, FALSE, unexp, &actual);
1411               if (!whine && (unexp != (ffetargetOffset) actual))
1412                 {
1413                   whine = TRUE; /* Don't whine more than once for one gather. */
1414                   ffebad_start (FFEBAD_DATA_MULTIPLE);
1415                   ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1416                   ffebad_string (ffesymbol_text (s));
1417                   ffebad_finish ();
1418                 }
1419               ffestorag_set_accretes (mst,
1420                                       ffestorag_accretes (mst)
1421                                       - actual);        /* Decrement # of values
1422                                                            actually accreted. */
1423               ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
1424             }
1425           source_offset += length;
1426           offset += unexp;
1427           ptr1 = ((char *) ptr1) + siz;
1428           ptr2 = ((char *) ptr2) + siz;
1429         }
1430
1431       /* If done accreting for this storage area, establish as initialized. */
1432
1433       if (ffestorag_accretes (mst) == 0)
1434         {
1435           ffestorag_set_init (mst, accter);
1436           ffestorag_set_accretion (mst, NULL);
1437           ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1438           ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1439           ffebld_set_arrter (ffestorag_init (mst),
1440                              ffebld_accter (ffestorag_init (mst)));
1441           ffebld_arrter_set_size (ffestorag_init (mst),
1442                                   ffedata_storage_size_);
1443           ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1444           ffecom_notify_init_storage (mst);
1445         }
1446
1447       return;
1448
1449     default:
1450       assert ("bad init op in gather_" == NULL);
1451       return;
1452     }
1453 }
1454
1455 /* ffedata_pop_ -- Pop an impdo stack entry
1456
1457    ffedata_pop_();  */
1458
1459 static void
1460 ffedata_pop_ (void)
1461 {
1462   ffedataImpdo_ victim = ffedata_stack_;
1463
1464   assert (victim != NULL);
1465
1466   ffedata_stack_ = ffedata_stack_->outer;
1467
1468   malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
1469 }
1470
1471 /* ffedata_push_ -- Push an impdo stack entry
1472
1473    ffedata_push_();  */
1474
1475 static void
1476 ffedata_push_ (void)
1477 {
1478   ffedataImpdo_ baby;
1479
1480   baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));
1481
1482   baby->outer = ffedata_stack_;
1483   ffedata_stack_ = baby;
1484 }
1485
1486 /* ffedata_value_ -- Provide an initial value
1487
1488    ffebld value;
1489    ffelexToken t;  // Points to the value.
1490    if (ffedata_value(value,t))
1491        // Everything's ok
1492
1493    Makes sure the value is ok, then remembers it according to the list
1494    provided to ffedata_begin.  */
1495
1496 static bool
1497 ffedata_value_ (ffebld value, ffelexToken token)
1498 {
1499
1500   /* If already reported an error, don't do anything. */
1501
1502   if (ffedata_reported_error_)
1503     return FALSE;
1504
1505   /* If the value is an error marker, remember we've seen one and do nothing
1506      else. */
1507
1508   if ((value != NULL)
1509       && (ffebld_op (value) == FFEBLD_opANY))
1510     {
1511       ffedata_reported_error_ = TRUE;
1512       return FALSE;
1513     }
1514
1515   /* If too many values (no more targets), complain. */
1516
1517   if (ffedata_symbol_ == NULL)
1518     {
1519       ffebad_start (FFEBAD_DATA_TOOMANY);
1520       ffebad_here (0, ffelex_token_where_line (token),
1521                    ffelex_token_where_column (token));
1522       ffebad_finish ();
1523       ffedata_reported_error_ = TRUE;
1524       return FALSE;
1525     }
1526
1527   /* If ffedata_advance_ wanted to register a complaint, do it now
1528      that we have the token to point at instead of just the start
1529      of the whole statement.  */
1530
1531   if (ffedata_reinit_)
1532     {
1533       ffebad_start (FFEBAD_DATA_REINIT);
1534       ffebad_here (0, ffelex_token_where_line (token),
1535                    ffelex_token_where_column (token));
1536       ffebad_string (ffesymbol_text (ffedata_symbol_));
1537       ffebad_finish ();
1538       ffedata_reported_error_ = TRUE;
1539       return FALSE;
1540     }
1541
1542 #if FFEGLOBAL_ENABLED
1543   if (ffesymbol_common (ffedata_symbol_) != NULL)
1544     ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token);
1545 #endif
1546
1547   /* Convert value to desired type. */
1548
1549   if (value != NULL)
1550     {
1551       if (ffedata_convert_cache_use_ == -1)
1552         value = ffeexpr_convert
1553           (value, token, NULL, ffedata_basictype_,
1554            ffedata_kindtype_, 0,
1555            (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1556            ? ffedata_charexpected_ : FFETARGET_charactersizeNONE,
1557            FFEEXPR_contextDATA);
1558       else                              /* Use the cache. */
1559         value = ffedata_convert_
1560           (value, token, NULL, ffedata_basictype_,
1561            ffedata_kindtype_, 0,
1562            (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1563            ? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
1564     }
1565
1566   /* If we couldn't, bug out. */
1567
1568   if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
1569     {
1570       ffedata_reported_error_ = TRUE;
1571       return FALSE;
1572     }
1573
1574   /* Handle the case where initializes go to a parent's storage area. */
1575
1576   if (ffedata_storage_ != NULL)
1577     {
1578       ffetargetOffset offset;
1579       ffetargetOffset units_expected;
1580       ffebitCount actual;
1581       ffebldConstantArray array;
1582       ffebld accter;
1583       ffetargetCopyfunc fn;
1584       void *ptr1;
1585       void *ptr2;
1586       size_t size;
1587       ffeinfoBasictype ign_bt;
1588       ffeinfoKindtype ign_kt;
1589       ffetargetAlign units;
1590
1591       /* Make sure we haven't fully accreted during an array init. */
1592
1593       if (ffestorag_init (ffedata_storage_) != NULL)
1594         {
1595           ffebad_start (FFEBAD_DATA_MULTIPLE);
1596           ffebad_here (0, ffelex_token_where_line (token),
1597                        ffelex_token_where_column (token));
1598           ffebad_string (ffesymbol_text (ffedata_symbol_));
1599           ffebad_finish ();
1600           ffedata_reported_error_ = TRUE;
1601           return FALSE;
1602         }
1603
1604       /* Calculate offset. */
1605
1606       offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1607
1608       /* Is offset within range?  If not, whine, but don't do anything else. */
1609
1610       if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1611         {
1612           ffebad_start (FFEBAD_DATA_RANGE);
1613           ffest_ffebad_here_current_stmt (0);
1614           ffebad_string (ffesymbol_text (ffedata_symbol_));
1615           ffebad_finish ();
1616           ffedata_reported_error_ = TRUE;
1617           return FALSE;
1618         }
1619
1620       /* Now calculate offset for aggregate area. */
1621
1622       ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
1623                                 ffedata_kindtype_);     /* Find out unit size of
1624                                                            source datum. */
1625       assert (units % ffedata_storage_units_ == 0);
1626       units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1627       offset *= units / ffedata_storage_units_;
1628       offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_))
1629                  - ffestorag_offset (ffedata_storage_))
1630         / ffedata_storage_units_;
1631
1632       assert (offset + units_expected - 1 <= ffedata_storage_size_);
1633
1634       /* Does an accretion array exist?  If not, create it. */
1635
1636       if (value != NULL)
1637         {
1638           if (ffestorag_accretion (ffedata_storage_) == NULL)
1639             {
1640 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1641               if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1642                 {
1643                   char bignum[40];
1644
1645                   sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1646                   ffebad_start (FFEBAD_TOO_BIG_INIT);
1647                   ffebad_here (0, ffelex_token_where_line (token),
1648                                ffelex_token_where_column (token));
1649                   ffebad_string (ffesymbol_text (ffedata_symbol_));
1650                   ffebad_string (bignum);
1651                   ffebad_finish ();
1652                 }
1653 #endif
1654               array = ffebld_constantarray_new
1655                 (ffedata_storage_bt_, ffedata_storage_kt_,
1656                  ffedata_storage_size_);
1657               accter = ffebld_new_accter (array,
1658                                           ffebit_new (ffe_pool_program_unit (),
1659                                                       ffedata_storage_size_));
1660               ffebld_set_info (accter, ffeinfo_new
1661                                (ffedata_storage_bt_,
1662                                 ffedata_storage_kt_,
1663                                 1,
1664                                 FFEINFO_kindENTITY,
1665                                 FFEINFO_whereCONSTANT,
1666                                 (ffedata_basictype_
1667                                  == FFEINFO_basictypeCHARACTER)
1668                                 ? 1 : FFETARGET_charactersizeNONE));
1669               ffestorag_set_accretion (ffedata_storage_, accter);
1670               ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_);
1671             }
1672           else
1673             {
1674               accter = ffestorag_accretion (ffedata_storage_);
1675               assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1676               array = ffebld_accter (accter);
1677             }
1678
1679           /* Put value in accretion array at desired offset. */
1680
1681           fn = ffetarget_aggregate_ptr_memcpy
1682             (ffedata_storage_bt_, ffedata_storage_kt_,
1683              ffedata_basictype_, ffedata_kindtype_);
1684           ffebld_constantarray_prepare
1685             (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1686              ffedata_storage_kt_, offset,
1687              ffebld_constant_ptr_to_union (ffebld_conter (value)),
1688              ffedata_basictype_, ffedata_kindtype_);
1689           (*fn) (ptr1, ptr2, size);     /* Does the appropriate memcpy-like
1690                                            operation. */
1691           ffebit_count (ffebld_accter_bits (accter),
1692                         offset, FALSE, units_expected,
1693                         &actual);       /* How many FALSE? */
1694           if (units_expected != (ffetargetOffset) actual)
1695             {
1696               ffebad_start (FFEBAD_DATA_MULTIPLE);
1697               ffebad_here (0, ffelex_token_where_line (token),
1698                            ffelex_token_where_column (token));
1699               ffebad_string (ffesymbol_text (ffedata_symbol_));
1700               ffebad_finish ();
1701             }
1702           ffestorag_set_accretes (ffedata_storage_,
1703                                   ffestorag_accretes (ffedata_storage_)
1704                                   - actual);    /* Decrement # of values
1705                                                    actually accreted. */
1706           ffebit_set (ffebld_accter_bits (accter), offset,
1707                       1, units_expected);
1708
1709           /* If done accreting for this storage area, establish as
1710              initialized. */
1711
1712           if (ffestorag_accretes (ffedata_storage_) == 0)
1713             {
1714               ffestorag_set_init (ffedata_storage_, accter);
1715               ffestorag_set_accretion (ffedata_storage_, NULL);
1716               ffebit_kill (ffebld_accter_bits
1717                            (ffestorag_init (ffedata_storage_)));
1718               ffebld_set_op (ffestorag_init (ffedata_storage_),
1719                              FFEBLD_opARRTER);
1720               ffebld_set_arrter
1721                 (ffestorag_init (ffedata_storage_),
1722                  ffebld_accter (ffestorag_init (ffedata_storage_)));
1723               ffebld_arrter_set_size (ffestorag_init (ffedata_storage_),
1724                                       ffedata_storage_size_);
1725               ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_),
1726                                      0);
1727               ffecom_notify_init_storage (ffedata_storage_);
1728             }
1729         }
1730
1731       /* If still accreting, adjust specs accordingly and return. */
1732
1733       if (++ffedata_number_ < ffedata_expected_)
1734         {
1735           ++ffedata_offset_;
1736           return TRUE;
1737         }
1738
1739       return ffedata_advance_ ();
1740     }
1741
1742   /* Figure out where the value goes -- in an accretion array or directly
1743      into the final initial-value slot for the symbol. */
1744
1745   if ((ffedata_number_ != 0)
1746       || (ffedata_arraysize_ > 1)
1747       || (ffedata_charnumber_ != 0)
1748       || (ffedata_size_ > ffedata_charexpected_))
1749     {                           /* Accrete this value. */
1750       ffetargetOffset offset;
1751       ffebitCount actual;
1752       ffebldConstantArray array;
1753       ffebld accter = NULL;
1754
1755       /* Calculate offset. */
1756
1757       offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1758
1759       /* Is offset within range?  If not, whine, but don't do anything else. */
1760
1761       if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1762         {
1763           ffebad_start (FFEBAD_DATA_RANGE);
1764           ffest_ffebad_here_current_stmt (0);
1765           ffebad_string (ffesymbol_text (ffedata_symbol_));
1766           ffebad_finish ();
1767           ffedata_reported_error_ = TRUE;
1768           return FALSE;
1769         }
1770
1771       /* Does an accretion array exist?  If not, create it. */
1772
1773       if (value != NULL)
1774         {
1775           if (ffesymbol_accretion (ffedata_symbol_) == NULL)
1776             {
1777 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1778               if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ )
1779                 {
1780                   char bignum[40];
1781
1782                   sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_);
1783                   ffebad_start (FFEBAD_TOO_BIG_INIT);
1784                   ffebad_here (0, ffelex_token_where_line (token),
1785                                ffelex_token_where_column (token));
1786                   ffebad_string (ffesymbol_text (ffedata_symbol_));
1787                   ffebad_string (bignum);
1788                   ffebad_finish ();
1789                 }
1790 #endif
1791               array = ffebld_constantarray_new
1792                 (ffedata_basictype_, ffedata_kindtype_,
1793                  ffedata_symbolsize_);
1794               accter = ffebld_new_accter (array,
1795                                           ffebit_new (ffe_pool_program_unit (),
1796                                                       ffedata_symbolsize_));
1797               ffebld_set_info (accter, ffeinfo_new
1798                                (ffedata_basictype_,
1799                                 ffedata_kindtype_,
1800                                 1,
1801                                 FFEINFO_kindENTITY,
1802                                 FFEINFO_whereCONSTANT,
1803                                 (ffedata_basictype_
1804                                  == FFEINFO_basictypeCHARACTER)
1805                                 ? 1 : FFETARGET_charactersizeNONE));
1806               ffesymbol_set_accretion (ffedata_symbol_, accter);
1807               ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_);
1808             }
1809           else
1810             {
1811               accter = ffesymbol_accretion (ffedata_symbol_);
1812               assert (ffedata_symbolsize_
1813                       == (ffetargetOffset) ffebld_accter_size (accter));
1814               array = ffebld_accter (accter);
1815             }
1816
1817           /* Put value in accretion array at desired offset. */
1818
1819           ffebld_constantarray_put
1820             (array, ffedata_basictype_, ffedata_kindtype_,
1821              offset, ffebld_constant_union (ffebld_conter (value)));
1822           ffebit_count (ffebld_accter_bits (accter), offset, FALSE,
1823                         ffedata_charexpected_,
1824                         &actual);       /* How many FALSE? */
1825           if (actual != (unsigned long int) ffedata_charexpected_)
1826             {
1827               ffebad_start (FFEBAD_DATA_MULTIPLE);
1828               ffebad_here (0, ffelex_token_where_line (token),
1829                            ffelex_token_where_column (token));
1830               ffebad_string (ffesymbol_text (ffedata_symbol_));
1831               ffebad_finish ();
1832             }
1833           ffesymbol_set_accretes (ffedata_symbol_,
1834                                   ffesymbol_accretes (ffedata_symbol_)
1835                                   - actual);    /* Decrement # of values
1836                                                    actually accreted. */
1837           ffebit_set (ffebld_accter_bits (accter), offset,
1838                       1, ffedata_charexpected_);
1839           ffesymbol_signal_unreported (ffedata_symbol_);
1840         }
1841
1842       /* If still accreting, adjust specs accordingly and return. */
1843
1844       if (++ffedata_number_ < ffedata_expected_)
1845         {
1846           ++ffedata_offset_;
1847           return TRUE;
1848         }
1849
1850       /* Else, if done accreting for this symbol, establish as initialized. */
1851
1852       if ((value != NULL)
1853           && (ffesymbol_accretes (ffedata_symbol_) == 0))
1854         {
1855           ffesymbol_set_init (ffedata_symbol_, accter);
1856           ffesymbol_set_accretion (ffedata_symbol_, NULL);
1857           ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_)));
1858           ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER);
1859           ffebld_set_arrter (ffesymbol_init (ffedata_symbol_),
1860                           ffebld_accter (ffesymbol_init (ffedata_symbol_)));
1861           ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_),
1862                                   ffedata_symbolsize_);
1863           ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0);
1864           ffecom_notify_init_symbol (ffedata_symbol_);
1865         }
1866     }
1867   else if (value != NULL)
1868     {
1869       /* Simple, direct, one-shot assignment. */
1870       ffesymbol_set_init (ffedata_symbol_, value);
1871       ffecom_notify_init_symbol (ffedata_symbol_);
1872     }
1873
1874   /* Call on advance function to get next target in list. */
1875
1876   return ffedata_advance_ ();
1877 }