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
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
ffedata_begin(ffebld list)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
ffedata_end(bool reported_error,ffelexToken t)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
ffedata_gather(ffestorag st)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
ffedata_value(ffetargetIntegerDefault rpt,ffebld value,ffelexToken token)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
ffedata_advance_(void)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
ffedata_convert_(ffebld source,ffelexToken source_token,ffelexToken dest_token,ffeinfoBasictype bt,ffeinfoKindtype kt,ffeinfoRank rk,ffetargetCharacterSize sz)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
ffedata_eval_integer1_(ffebld expr)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
ffedata_eval_offset_(ffebld subscripts,ffebld dims)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
ffedata_eval_substr_begin_(ffebld expr)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
ffedata_eval_substr_end_(ffebld expr,ffetargetCharacterSize min,ffetargetCharacterSize max)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
ffedata_gather_(ffestorag mst,ffestorag st)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
ffedata_pop_(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
ffedata_push_(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
ffedata_value_(ffebld value,ffelexToken token)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 }
1878