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