* config/arm/arm.c (is_load_address): Rename to... (arm_memory_load_p) ... this
[official-gcc.git] / gcc / f / data.c
blob3e1ae6213cbcaa39b9295cd81962cff96d67f4cf
1 /* data.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2002 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
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.
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.
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.
22 Related Modules:
24 Description:
25 Do the tough things for DATA statement (and INTEGER FOO/.../-style
26 initializations), like implied-DO and suchlike.
28 Modifications:
31 /* Include files. */
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"
45 /* Externals defined here. */
48 /* Simple definitions and enumerations. */
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
64 /* Internal typedefs. */
66 typedef struct _ffedata_convert_cache_ *ffedataConvertCache_;
67 typedef struct _ffedata_impdo_ *ffedataImpdo_;
69 /* Private include files. */
72 /* Internal structure definitions. */
74 struct _ffedata_convert_cache_
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;
84 struct _ffedata_impdo_
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;
94 /* Static objects accessed by functions in this module. */
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. */
123 /* Static functions (internal). */
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);
140 /* Internal macros. */
143 /* ffedata_begin -- Initialize with list of targets
145 ffebld list;
146 ffedata_begin(list); // ITEM... list of SYMTERs, ARRAYs, SUBSTRs, ...
148 Remember the list. After this call, 0...n calls to ffedata_value must
149 follow, and then a single call to ffedata_end. */
151 void
152 ffedata_begin (ffebld list)
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_ ();
162 /* ffedata_end -- End of initialization sequence
164 if (ffedata_end(FALSE))
165 // everything's ok
167 Make sure the end of the list is valid here. */
169 bool
170 ffedata_end (bool reported_error, ffelexToken t)
172 reported_error |= ffedata_reported_error_;
174 /* If still targets to initialize, too few initializers, so complain. */
176 if ((ffedata_symbol_ != NULL) && !reported_error)
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 ();
185 /* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */
187 while (ffedata_stack_ != NULL)
188 ffedata_pop_ ();
190 if (ffedata_list_ != NULL)
192 assert (reported_error);
193 ffedata_list_ = NULL;
196 return TRUE;
199 /* ffedata_gather -- Gather previously disparate initializations into one place
201 ffestorag st; // A typeCBLOCK or typeLOCAL aggregate.
202 ffedata_gather(st);
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. */
211 void
212 ffedata_gather (ffestorag st)
214 ffesymbol s;
215 ffebld b;
217 /* Prepare info on the storage area we're putting init info into. */
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);
225 /* If a CBLOCK, gather all the init info for its explicit members. */
227 if ((ffestorag_type (st) == FFESTORAG_typeCBLOCK)
228 && (ffestorag_symbol (st) != NULL))
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))));
236 /* For CBLOCK or LOCAL, gather all the init info for equivalenced members. */
238 ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st);
241 /* ffedata_value -- Provide some number of initial values
243 ffebld value;
244 ffelexToken t; // Points to the value.
245 if (ffedata_value(1,value,t))
246 // Everything's ok
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. */
252 bool
253 ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token)
255 ffetargetIntegerDefault i;
257 /* Maybe ignore zero values, to speed up compiling, even though we lose
258 checking for multiple initializations for now. */
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
270 /* Must be a constant. */
271 assert (value != NULL);
272 assert (ffebld_op (value) == FFEBLD_opCONTER);
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_. */
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. */
283 for (i = 0; i < rpt; ++i)
285 if ((ffedata_symbol_ != NULL)
286 && !ffesymbol_is_init (ffedata_symbol_))
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_);
299 if (!ffedata_value_ (value, token))
300 return FALSE;
303 return TRUE;
306 /* ffedata_advance_ -- Advance initialization target to next item in list
308 if (ffedata_advance_())
309 // everything's ok
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. */
316 static bool
317 ffedata_advance_ ()
319 ffebld next;
321 /* Come here after handling an IMPDO. */
323 tail_recurse: /* :::::::::::::::::::: */
325 /* Assume we're not going to find a new target for now. */
327 ffedata_symbol_ = NULL;
329 /* If at the end of the list, we're done. */
331 if (ffedata_list_ == NULL)
333 ffetargetIntegerDefault newval;
335 if (ffedata_stack_ == NULL)
336 return TRUE; /* No IMPDO in progress, we is done! */
338 /* Iterate the IMPDO. */
340 newval = ffesymbol_value (ffedata_stack_->itervar)
341 + ffedata_stack_->increment;
343 /* See if we're still in the loop. */
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. */
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);
362 goto tail_recurse; /* :::::::::::::::::::: */
365 /* Move to the next item in the list. */
367 next = ffebld_head (ffedata_list_);
368 ffedata_list_ = ffebld_trail (ffedata_list_);
370 /* Really shouldn't happen. */
372 if (next == NULL)
373 return TRUE;
375 /* See what kind of target this is. */
377 switch (ffebld_op (next))
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)
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);
394 if ((ffesymbol_init (ffedata_symbol_) != NULL)
395 || (ffesymbol_accretion (ffedata_symbol_) != NULL)
396 || ((ffedata_storage_ != NULL)
397 && (ffestorag_init (ffedata_storage_) != NULL)))
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
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
417 ffebld size = ffesymbol_arraysize (ffedata_symbol_);
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));
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;
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)
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);
454 if ((ffesymbol_init (ffedata_symbol_) != NULL)
455 || ((ffedata_storage_ != NULL)
456 && (ffestorag_init (ffedata_storage_) != NULL)))
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
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
476 ffebld size = ffesymbol_arraysize (ffedata_symbol_);
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));
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;
499 case FFEBLD_opSUBSTR: /* Substring reference to scalar or array
500 element. */
502 bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF;
503 ffebld colon = ffebld_right (next);
505 assert (colon != NULL);
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)
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);
522 if ((ffesymbol_init (ffedata_symbol_) != NULL)
523 || ((ffedata_storage_ != NULL)
524 && (ffestorag_init (ffedata_storage_) != NULL)))
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
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
544 ffebld size = ffesymbol_arraysize (ffedata_symbol_);
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));
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;
567 break;
569 case FFEBLD_opIMPDO: /* Implied-DO construct. */
571 ffebld itervar;
572 ffebld start;
573 ffebld end;
574 ffebld incr;
575 ffebld item = ffebld_right (next);
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);
585 ffedata_push_ ();
586 ffedata_stack_->outer_list = ffedata_list_;
587 ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next);
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);
595 assert (ffeinfo_basictype (ffebld_info (start))
596 == FFEINFO_basictypeINTEGER);
597 assert (ffeinfo_kindtype (ffebld_info (start))
598 == FFEINFO_kindtypeINTEGERDEFAULT);
599 ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start));
601 assert (ffeinfo_basictype (ffebld_info (end))
602 == FFEINFO_basictypeINTEGER);
603 assert (ffeinfo_kindtype (ffebld_info (end))
604 == FFEINFO_kindtypeINTEGERDEFAULT);
605 ffedata_stack_->final = ffedata_eval_integer1_ (end);
607 if (incr == NULL)
608 ffedata_stack_->increment = 1;
609 else
611 assert (ffeinfo_basictype (ffebld_info (incr))
612 == FFEINFO_basictypeINTEGER);
613 assert (ffeinfo_kindtype (ffebld_info (incr))
614 == FFEINFO_kindtypeINTEGERDEFAULT);
615 ffedata_stack_->increment = ffedata_eval_integer1_ (incr);
616 if (ffedata_stack_->increment == 0)
618 ffebad_start (FFEBAD_DATA_ZERO);
619 ffest_ffebad_here_current_stmt (0);
620 ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
621 ffebad_finish ();
622 ffedata_pop_ ();
623 ffedata_reported_error_ = TRUE;
624 return FALSE;
628 if ((ffedata_stack_->increment > 0)
629 ? ffesymbol_value (ffedata_stack_->itervar)
630 > ffedata_stack_->final
631 : ffesymbol_value (ffedata_stack_->itervar)
632 < ffedata_stack_->final)
634 ffedata_reported_error_ = TRUE;
635 ffebad_start (FFEBAD_DATA_EMPTY);
636 ffest_ffebad_here_current_stmt (0);
637 ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
638 ffebad_finish ();
639 ffedata_pop_ ();
640 return FALSE;
643 goto tail_recurse; /* :::::::::::::::::::: */
645 case FFEBLD_opANY:
646 ffedata_reported_error_ = TRUE;
647 return FALSE;
649 default:
650 assert ("bad op" == NULL);
651 break;
654 return TRUE;
657 /* ffedata_convert_ -- Convert source expression to given type using cache
659 ffebld source;
660 ffelexToken source_token;
661 ffelexToken dest_token; // Any appropriate token for "destination".
662 ffeinfoBasictype bt;
663 ffeinfoKindtype kt;
664 ffetargetCharactersize sz;
665 source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);
667 Like ffeexpr_convert, but calls it only if necessary (if the converted
668 expression doesn't already exist in the cache) and then puts the result
669 in the cache. */
671 static ffebld
672 ffedata_convert_ (ffebld source, ffelexToken source_token,
673 ffelexToken dest_token, ffeinfoBasictype bt,
674 ffeinfoKindtype kt, ffeinfoRank rk,
675 ffetargetCharacterSize sz)
677 ffebld converted;
678 int i;
679 int max;
680 ffedataConvertCache_ cache;
682 for (i = 0; i < ffedata_convert_cache_use_; ++i)
683 if ((bt == ffedata_convert_cache_[i].basic_type)
684 && (kt == ffedata_convert_cache_[i].kind_type)
685 && (sz == ffedata_convert_cache_[i].size)
686 && (rk == ffedata_convert_cache_[i].rank))
687 return ffedata_convert_cache_[i].converted;
689 converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk,
690 sz, FFEEXPR_contextDATA);
692 if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_)
694 if (ffedata_convert_cache_max_ == 0)
695 max = 4;
696 else
697 max = ffedata_convert_cache_max_ << 1;
699 if (max > ffedata_convert_cache_max_)
701 cache = (ffedataConvertCache_) malloc_new_ks (malloc_pool_image (),
702 "FFEDATA cache", max * sizeof (*cache));
703 if (ffedata_convert_cache_max_ != 0)
705 memcpy (cache, ffedata_convert_cache_,
706 ffedata_convert_cache_max_ * sizeof (*cache));
707 malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_,
708 ffedata_convert_cache_max_ * sizeof (*cache));
710 ffedata_convert_cache_ = cache;
711 ffedata_convert_cache_max_ = max;
713 else
714 return converted; /* In case int overflows! */
717 i = ffedata_convert_cache_use_++;
719 ffedata_convert_cache_[i].converted = converted;
720 ffedata_convert_cache_[i].basic_type = bt;
721 ffedata_convert_cache_[i].kind_type = kt;
722 ffedata_convert_cache_[i].size = sz;
723 ffedata_convert_cache_[i].rank = rk;
725 return converted;
728 /* ffedata_eval_integer1_ -- Evaluate expression
730 ffetargetIntegerDefault result;
731 ffebld expr; // must be kindtypeINTEGER1.
733 result = ffedata_eval_integer1_(expr);
735 Evalues the expression (which yields a kindtypeINTEGER1 result) and
736 returns the result. */
738 static ffetargetIntegerDefault
739 ffedata_eval_integer1_ (ffebld expr)
741 ffetargetInteger1 result;
742 ffebad error;
744 assert (expr != NULL);
746 switch (ffebld_op (expr))
748 case FFEBLD_opCONTER:
749 return ffebld_constant_integer1 (ffebld_conter (expr));
751 case FFEBLD_opSYMTER:
752 return ffesymbol_value (ffebld_symter (expr));
754 case FFEBLD_opUPLUS:
755 return ffedata_eval_integer1_ (ffebld_left (expr));
757 case FFEBLD_opUMINUS:
758 error = ffetarget_uminus_integer1 (&result,
759 ffedata_eval_integer1_ (ffebld_left (expr)));
760 break;
762 case FFEBLD_opADD:
763 error = ffetarget_add_integer1 (&result,
764 ffedata_eval_integer1_ (ffebld_left (expr)),
765 ffedata_eval_integer1_ (ffebld_right (expr)));
766 break;
768 case FFEBLD_opSUBTRACT:
769 error = ffetarget_subtract_integer1 (&result,
770 ffedata_eval_integer1_ (ffebld_left (expr)),
771 ffedata_eval_integer1_ (ffebld_right (expr)));
772 break;
774 case FFEBLD_opMULTIPLY:
775 error = ffetarget_multiply_integer1 (&result,
776 ffedata_eval_integer1_ (ffebld_left (expr)),
777 ffedata_eval_integer1_ (ffebld_right (expr)));
778 break;
780 case FFEBLD_opDIVIDE:
781 error = ffetarget_divide_integer1 (&result,
782 ffedata_eval_integer1_ (ffebld_left (expr)),
783 ffedata_eval_integer1_ (ffebld_right (expr)));
784 break;
786 case FFEBLD_opPOWER:
788 ffebld r = ffebld_right (expr);
790 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
791 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
792 error = FFEBAD_DATA_EVAL;
793 else
794 error = ffetarget_power_integerdefault_integerdefault (&result,
795 ffedata_eval_integer1_ (ffebld_left (expr)),
796 ffedata_eval_integer1_ (r));
798 break;
800 #if 0 /* Only for character basictype. */
801 case FFEBLD_opCONCATENATE:
802 error =;
803 break;
804 #endif
806 case FFEBLD_opNOT:
807 error = ffetarget_not_integer1 (&result,
808 ffedata_eval_integer1_ (ffebld_left (expr)));
809 break;
811 #if 0 /* Only for logical basictype. */
812 case FFEBLD_opLT:
813 error =;
814 break;
816 case FFEBLD_opLE:
817 error =;
818 break;
820 case FFEBLD_opEQ:
821 error =;
822 break;
824 case FFEBLD_opNE:
825 error =;
826 break;
828 case FFEBLD_opGT:
829 error =;
830 break;
832 case FFEBLD_opGE:
833 error =;
834 break;
835 #endif
837 case FFEBLD_opAND:
838 error = ffetarget_and_integer1 (&result,
839 ffedata_eval_integer1_ (ffebld_left (expr)),
840 ffedata_eval_integer1_ (ffebld_right (expr)));
841 break;
843 case FFEBLD_opOR:
844 error = ffetarget_or_integer1 (&result,
845 ffedata_eval_integer1_ (ffebld_left (expr)),
846 ffedata_eval_integer1_ (ffebld_right (expr)));
847 break;
849 case FFEBLD_opXOR:
850 error = ffetarget_xor_integer1 (&result,
851 ffedata_eval_integer1_ (ffebld_left (expr)),
852 ffedata_eval_integer1_ (ffebld_right (expr)));
853 break;
855 case FFEBLD_opEQV:
856 error = ffetarget_eqv_integer1 (&result,
857 ffedata_eval_integer1_ (ffebld_left (expr)),
858 ffedata_eval_integer1_ (ffebld_right (expr)));
859 break;
861 case FFEBLD_opNEQV:
862 error = ffetarget_neqv_integer1 (&result,
863 ffedata_eval_integer1_ (ffebld_left (expr)),
864 ffedata_eval_integer1_ (ffebld_right (expr)));
865 break;
867 case FFEBLD_opPAREN:
868 return ffedata_eval_integer1_ (ffebld_left (expr));
870 #if 0 /* ~~ no idea how to do this */
871 case FFEBLD_opPERCENT_LOC:
872 error =;
873 break;
874 #endif
876 #if 0 /* not allowed by ANSI, but perhaps as an
877 extension someday? */
878 case FFEBLD_opCONVERT:
879 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
881 case FFEINFO_basictypeINTEGER:
882 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
884 default:
885 error = FFEBAD_DATA_EVAL;
886 break;
888 break;
890 case FFEINFO_basictypeREAL:
891 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
893 default:
894 error = FFEBAD_DATA_EVAL;
895 break;
897 break;
899 break;
900 #endif
902 #if 0 /* not valid ops */
903 case FFEBLD_opREPEAT:
904 error =;
905 break;
907 case FFEBLD_opBOUNDS:
908 error =;
909 break;
910 #endif
912 #if 0 /* not allowed by ANSI, but perhaps as an
913 extension someday? */
914 case FFEBLD_opFUNCREF:
915 error =;
916 break;
917 #endif
919 #if 0 /* not valid ops */
920 case FFEBLD_opSUBRREF:
921 error =;
922 break;
924 case FFEBLD_opARRAYREF:
925 error =;
926 break;
927 #endif
929 #if 0 /* not valid for integer1 */
930 case FFEBLD_opSUBSTR:
931 error =;
932 break;
933 #endif
935 default:
936 error = FFEBAD_DATA_EVAL;
937 break;
940 if (error != FFEBAD)
942 ffebad_start (error);
943 ffest_ffebad_here_current_stmt (0);
944 ffebad_finish ();
945 result = 0;
948 return result;
951 /* ffedata_eval_offset_ -- Evaluate offset info array
953 ffetargetOffset offset; // 0...max-1.
954 ffebld subscripts; // an opITEM list of subscript exprs.
955 ffebld dims; // an opITEM list of opBOUNDS exprs.
957 result = ffedata_eval_offset_(expr);
959 Evalues the expression (which yields a kindtypeINTEGER1 result) and
960 returns the result. */
962 static ffetargetOffset
963 ffedata_eval_offset_ (ffebld subscripts, ffebld dims)
965 ffetargetIntegerDefault offset = 0;
966 ffetargetIntegerDefault width = 1;
967 ffetargetIntegerDefault value;
968 ffetargetIntegerDefault lowbound;
969 ffetargetIntegerDefault highbound;
970 ffetargetOffset final;
971 ffebld subscript;
972 ffebld dim;
973 ffebld low;
974 ffebld high;
975 int rank = 0;
976 bool ok;
978 while (subscripts != NULL)
980 ffeinfoKindtype sub_kind, low_kind, hi_kind;
981 ffebld sub1, low1, hi1;
983 ++rank;
984 assert (dims != NULL);
986 subscript = ffebld_head (subscripts);
987 dim = ffebld_head (dims);
989 assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
990 if (ffebld_op (subscript) == FFEBLD_opCONTER)
992 /* Force to default - it's a constant expression ! */
993 sub_kind = ffeinfo_kindtype (ffebld_info (subscript));
994 sub1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
995 sub_kind == FFEINFO_kindtypeINTEGER2 ? subscript->u.conter.expr->u.integer2 :
996 sub_kind == FFEINFO_kindtypeINTEGER3 ? subscript->u.conter.expr->u.integer3 :
997 sub_kind == FFEINFO_kindtypeINTEGER4 ? subscript->u.conter.expr->u.integer4 :
998 subscript->u.conter.expr->u.integer1), NULL);
999 value = ffedata_eval_integer1_ (sub1);
1001 else
1002 value = ffedata_eval_integer1_ (subscript);
1004 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
1005 low = ffebld_left (dim);
1006 high = ffebld_right (dim);
1008 if (low == NULL)
1009 lowbound = 1;
1010 else
1012 assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
1013 if (ffebld_op (low) == FFEBLD_opCONTER)
1015 /* Force to default - it's a constant expression ! */
1016 low_kind = ffeinfo_kindtype (ffebld_info (low));
1017 low1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
1018 low_kind == FFEINFO_kindtypeINTEGER2 ? low->u.conter.expr->u.integer2 :
1019 low_kind == FFEINFO_kindtypeINTEGER3 ? low->u.conter.expr->u.integer3 :
1020 low_kind == FFEINFO_kindtypeINTEGER4 ? low->u.conter.expr->u.integer4 :
1021 low->u.conter.expr->u.integer1), NULL);
1022 lowbound = ffedata_eval_integer1_ (low1);
1024 else
1025 lowbound = ffedata_eval_integer1_ (low);
1028 assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
1029 if (ffebld_op (high) == FFEBLD_opCONTER)
1031 /* Force to default - it's a constant expression ! */
1032 hi_kind = ffeinfo_kindtype (ffebld_info (high));
1033 hi1 = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (
1034 hi_kind == FFEINFO_kindtypeINTEGER2 ? high->u.conter.expr->u.integer2 :
1035 hi_kind == FFEINFO_kindtypeINTEGER3 ? high->u.conter.expr->u.integer3 :
1036 hi_kind == FFEINFO_kindtypeINTEGER4 ? high->u.conter.expr->u.integer4 :
1037 high->u.conter.expr->u.integer1), NULL);
1038 highbound = ffedata_eval_integer1_ (hi1);
1040 else
1041 highbound = ffedata_eval_integer1_ (high);
1043 if ((value < lowbound) || (value > highbound))
1045 char rankstr[10];
1047 sprintf (rankstr, "%d", rank);
1048 value = lowbound;
1049 ffebad_start (FFEBAD_DATA_SUBSCRIPT);
1050 ffebad_string (ffesymbol_text (ffedata_symbol_));
1051 ffebad_string (rankstr);
1052 ffebad_finish ();
1055 subscripts = ffebld_trail (subscripts);
1056 dims = ffebld_trail (dims);
1058 offset += width * (value - lowbound);
1059 if (subscripts != NULL)
1060 width *= highbound - lowbound + 1;
1063 assert (dims == NULL);
1065 ok = ffetarget_offset (&final, offset);
1066 assert (ok);
1068 return final;
1071 /* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference
1073 ffetargetCharacterSize beginpoint;
1074 ffebld endval; // head(colon).
1076 beginpoint = ffedata_eval_substr_end_(endval);
1078 If beginval is NULL, returns 0. Otherwise makes sure beginval is
1079 kindtypeINTEGERDEFAULT, makes sure its value is > 0,
1080 and returns its value minus one, or issues an error message. */
1082 static ffetargetCharacterSize
1083 ffedata_eval_substr_begin_ (ffebld expr)
1085 ffetargetIntegerDefault val;
1087 if (expr == NULL)
1088 return 0;
1090 assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1091 assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);
1093 val = ffedata_eval_integer1_ (expr);
1095 if (val < 1)
1097 val = 1;
1098 ffebad_start (FFEBAD_DATA_RANGE);
1099 ffest_ffebad_here_current_stmt (0);
1100 ffebad_string (ffesymbol_text (ffedata_symbol_));
1101 ffebad_finish ();
1102 ffedata_reported_error_ = TRUE;
1105 return val - 1;
1108 /* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference
1110 ffetargetCharacterSize endpoint;
1111 ffebld endval; // head(trail(colon)).
1112 ffetargetCharacterSize min; // beginpoint of substr reference.
1113 ffetargetCharacterSize max; // size of entity.
1115 endpoint = ffedata_eval_substr_end_(endval,dflt);
1117 If endval is NULL, returns max. Otherwise makes sure endval is
1118 kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
1119 and returns its value minus one, or issues an error message. */
1121 static ffetargetCharacterSize
1122 ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
1123 ffetargetCharacterSize max)
1125 ffetargetIntegerDefault val;
1127 if (expr == NULL)
1128 return max - 1;
1130 assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
1131 assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);
1133 val = ffedata_eval_integer1_ (expr);
1135 if ((val < (ffetargetIntegerDefault) min)
1136 || (val > (ffetargetIntegerDefault) max))
1138 val = 1;
1139 ffebad_start (FFEBAD_DATA_RANGE);
1140 ffest_ffebad_here_current_stmt (0);
1141 ffebad_string (ffesymbol_text (ffedata_symbol_));
1142 ffebad_finish ();
1143 ffedata_reported_error_ = TRUE;
1146 return val - 1;
1149 /* ffedata_gather_ -- Gather initial values for sym into master sym inits
1151 ffestorag mst; // A typeCBLOCK or typeLOCAL aggregate.
1152 ffestorag st; // A typeCOMMON or typeEQUIV member.
1153 ffedata_gather_(mst,st);
1155 If st has any initialization info, transfer that info into mst and
1156 clear st's info. */
1158 static void
1159 ffedata_gather_ (ffestorag mst, ffestorag st)
1161 ffesymbol s;
1162 ffesymbol s_whine; /* Symbol to complain about in diagnostics. */
1163 ffebld b;
1164 ffetargetOffset offset;
1165 ffetargetOffset units_expected;
1166 ffebitCount actual;
1167 ffebldConstantArray array;
1168 ffebld accter;
1169 ffetargetCopyfunc fn;
1170 void *ptr1;
1171 void *ptr2;
1172 size_t size;
1173 ffeinfoBasictype bt;
1174 ffeinfoKindtype kt;
1175 ffeinfoBasictype ign_bt;
1176 ffeinfoKindtype ign_kt;
1177 ffetargetAlign units;
1178 ffebit bits;
1179 ffetargetOffset source_offset;
1180 bool whine = FALSE;
1182 if (st == NULL)
1183 return; /* Nothing to do. */
1185 s = ffestorag_symbol (st);
1187 assert (s != NULL); /* Must have a corresponding symbol (else how
1188 inited?). */
1189 assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */
1190 assert (ffestorag_accretion (st) == NULL);
1192 if ((((b = ffesymbol_init (s)) == NULL)
1193 && ((b = ffesymbol_accretion (s)) == NULL))
1194 || (ffebld_op (b) == FFEBLD_opANY)
1195 || ((ffebld_op (b) == FFEBLD_opCONVERT)
1196 && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
1197 return; /* Nothing to do. */
1199 /* b now holds the init/accretion expr. */
1201 ffesymbol_set_init (s, NULL);
1202 ffesymbol_set_accretion (s, NULL);
1203 ffesymbol_set_accretes (s, 0);
1205 s_whine = ffestorag_symbol (mst);
1206 if (s_whine == NULL)
1207 s_whine = s;
1209 /* Make sure we haven't fully accreted during an array init. */
1211 if (ffestorag_init (mst) != NULL)
1213 ffebad_start (FFEBAD_DATA_MULTIPLE);
1214 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1215 ffebad_string (ffesymbol_text (s_whine));
1216 ffebad_finish ();
1217 return;
1220 bt = ffeinfo_basictype (ffebld_info (b));
1221 kt = ffeinfo_kindtype (ffebld_info (b));
1223 /* Calculate offset for aggregate area. */
1225 ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
1226 ? ffebld_size (b) : 1;
1227 ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
1228 kt);/* Find out unit size of source datum. */
1229 assert (units % ffedata_storage_units_ == 0);
1230 units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1231 offset = (ffestorag_offset (st) - ffestorag_offset (mst))
1232 / ffedata_storage_units_;
1234 /* Does an accretion array exist? If not, create it. */
1236 if (ffestorag_accretion (mst) == NULL)
1238 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1239 if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1241 char bignum[40];
1243 sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1244 ffebad_start (FFEBAD_TOO_BIG_INIT);
1245 ffebad_here (0, ffesymbol_where_line (s_whine),
1246 ffesymbol_where_column (s_whine));
1247 ffebad_string (ffesymbol_text (s_whine));
1248 ffebad_string (bignum);
1249 ffebad_finish ();
1251 #endif
1252 array = ffebld_constantarray_new (ffedata_storage_bt_,
1253 ffedata_storage_kt_, ffedata_storage_size_);
1254 accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
1255 ffedata_storage_size_));
1256 ffebld_set_info (accter, ffeinfo_new
1257 (ffedata_storage_bt_,
1258 ffedata_storage_kt_,
1260 FFEINFO_kindENTITY,
1261 FFEINFO_whereCONSTANT,
1262 (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1263 ? 1 : FFETARGET_charactersizeNONE));
1264 ffestorag_set_accretion (mst, accter);
1265 ffestorag_set_accretes (mst, ffedata_storage_size_);
1267 else
1269 accter = ffestorag_accretion (mst);
1270 assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1271 array = ffebld_accter (accter);
1274 /* Put value in accretion array at desired offset. */
1276 fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
1277 bt, kt);
1279 switch (ffebld_op (b))
1281 case FFEBLD_opCONTER:
1282 ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1283 ffedata_storage_kt_, offset,
1284 ffebld_constant_ptr_to_union (ffebld_conter (b)),
1285 bt, kt);
1286 (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1287 operation. */
1288 ffebit_count (ffebld_accter_bits (accter),
1289 offset, FALSE, units_expected, &actual); /* How many FALSE? */
1290 if (units_expected != (ffetargetOffset) actual)
1292 ffebad_start (FFEBAD_DATA_MULTIPLE);
1293 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1294 ffebad_string (ffesymbol_text (s));
1295 ffebad_finish ();
1297 ffestorag_set_accretes (mst,
1298 ffestorag_accretes (mst)
1299 - actual); /* Decrement # of values
1300 actually accreted. */
1301 ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1303 /* If done accreting for this storage area, establish as initialized. */
1305 if (ffestorag_accretes (mst) == 0)
1307 ffestorag_set_init (mst, accter);
1308 ffestorag_set_accretion (mst, NULL);
1309 ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1310 ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1311 ffebld_set_arrter (ffestorag_init (mst),
1312 ffebld_accter (ffestorag_init (mst)));
1313 ffebld_arrter_set_size (ffestorag_init (mst),
1314 ffedata_storage_size_);
1315 ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1316 ffecom_notify_init_storage (mst);
1319 return;
1321 case FFEBLD_opARRTER:
1322 ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1323 ffedata_storage_kt_, offset, ffebld_arrter (b),
1324 bt, kt);
1325 size *= ffebld_arrter_size (b);
1326 units_expected *= ffebld_arrter_size (b);
1327 (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1328 operation. */
1329 ffebit_count (ffebld_accter_bits (accter),
1330 offset, FALSE, units_expected, &actual); /* How many FALSE? */
1331 if (units_expected != (ffetargetOffset) actual)
1333 ffebad_start (FFEBAD_DATA_MULTIPLE);
1334 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1335 ffebad_string (ffesymbol_text (s));
1336 ffebad_finish ();
1338 ffestorag_set_accretes (mst,
1339 ffestorag_accretes (mst)
1340 - actual); /* Decrement # of values
1341 actually accreted. */
1342 ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);
1344 /* If done accreting for this storage area, establish as initialized. */
1346 if (ffestorag_accretes (mst) == 0)
1348 ffestorag_set_init (mst, accter);
1349 ffestorag_set_accretion (mst, NULL);
1350 ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1351 ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1352 ffebld_set_arrter (ffestorag_init (mst),
1353 ffebld_accter (ffestorag_init (mst)));
1354 ffebld_arrter_set_size (ffestorag_init (mst),
1355 ffedata_storage_size_);
1356 ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1357 ffecom_notify_init_storage (mst);
1360 return;
1362 case FFEBLD_opACCTER:
1363 ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1364 ffedata_storage_kt_, offset, ffebld_accter (b),
1365 bt, kt);
1366 bits = ffebld_accter_bits (b);
1367 source_offset = 0;
1369 for (;;)
1371 ffetargetOffset unexp;
1372 ffetargetOffset siz;
1373 ffebitCount length;
1374 bool value;
1376 ffebit_test (bits, source_offset, &value, &length);
1377 if (length == 0)
1378 break; /* Exit the loop early. */
1379 siz = size * length;
1380 unexp = units_expected * length;
1381 if (value)
1383 (*fn) (ptr1, ptr2, siz); /* Does memcpy-like operation. */
1384 ffebit_count (ffebld_accter_bits (accter), /* How many FALSE? */
1385 offset, FALSE, unexp, &actual);
1386 if (!whine && (unexp != (ffetargetOffset) actual))
1388 whine = TRUE; /* Don't whine more than once for one gather. */
1389 ffebad_start (FFEBAD_DATA_MULTIPLE);
1390 ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
1391 ffebad_string (ffesymbol_text (s));
1392 ffebad_finish ();
1394 ffestorag_set_accretes (mst,
1395 ffestorag_accretes (mst)
1396 - actual); /* Decrement # of values
1397 actually accreted. */
1398 ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
1400 source_offset += length;
1401 offset += unexp;
1402 ptr1 = ((char *) ptr1) + siz;
1403 ptr2 = ((char *) ptr2) + siz;
1406 /* If done accreting for this storage area, establish as initialized. */
1408 if (ffestorag_accretes (mst) == 0)
1410 ffestorag_set_init (mst, accter);
1411 ffestorag_set_accretion (mst, NULL);
1412 ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
1413 ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
1414 ffebld_set_arrter (ffestorag_init (mst),
1415 ffebld_accter (ffestorag_init (mst)));
1416 ffebld_arrter_set_size (ffestorag_init (mst),
1417 ffedata_storage_size_);
1418 ffebld_arrter_set_pad (ffestorag_init (mst), 0);
1419 ffecom_notify_init_storage (mst);
1422 return;
1424 default:
1425 assert ("bad init op in gather_" == NULL);
1426 return;
1430 /* ffedata_pop_ -- Pop an impdo stack entry
1432 ffedata_pop_(); */
1434 static void
1435 ffedata_pop_ ()
1437 ffedataImpdo_ victim = ffedata_stack_;
1439 assert (victim != NULL);
1441 ffedata_stack_ = ffedata_stack_->outer;
1443 malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
1446 /* ffedata_push_ -- Push an impdo stack entry
1448 ffedata_push_(); */
1450 static void
1451 ffedata_push_ ()
1453 ffedataImpdo_ baby;
1455 baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby));
1457 baby->outer = ffedata_stack_;
1458 ffedata_stack_ = baby;
1461 /* ffedata_value_ -- Provide an initial value
1463 ffebld value;
1464 ffelexToken t; // Points to the value.
1465 if (ffedata_value(value,t))
1466 // Everything's ok
1468 Makes sure the value is ok, then remembers it according to the list
1469 provided to ffedata_begin. */
1471 static bool
1472 ffedata_value_ (ffebld value, ffelexToken token)
1475 /* If already reported an error, don't do anything. */
1477 if (ffedata_reported_error_)
1478 return FALSE;
1480 /* If the value is an error marker, remember we've seen one and do nothing
1481 else. */
1483 if ((value != NULL)
1484 && (ffebld_op (value) == FFEBLD_opANY))
1486 ffedata_reported_error_ = TRUE;
1487 return FALSE;
1490 /* If too many values (no more targets), complain. */
1492 if (ffedata_symbol_ == NULL)
1494 ffebad_start (FFEBAD_DATA_TOOMANY);
1495 ffebad_here (0, ffelex_token_where_line (token),
1496 ffelex_token_where_column (token));
1497 ffebad_finish ();
1498 ffedata_reported_error_ = TRUE;
1499 return FALSE;
1502 /* If ffedata_advance_ wanted to register a complaint, do it now
1503 that we have the token to point at instead of just the start
1504 of the whole statement. */
1506 if (ffedata_reinit_)
1508 ffebad_start (FFEBAD_DATA_REINIT);
1509 ffebad_here (0, ffelex_token_where_line (token),
1510 ffelex_token_where_column (token));
1511 ffebad_string (ffesymbol_text (ffedata_symbol_));
1512 ffebad_finish ();
1513 ffedata_reported_error_ = TRUE;
1514 return FALSE;
1517 #if FFEGLOBAL_ENABLED
1518 if (ffesymbol_common (ffedata_symbol_) != NULL)
1519 ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token);
1520 #endif
1522 /* Convert value to desired type. */
1524 if (value != NULL)
1526 if (ffedata_convert_cache_use_ == -1)
1527 value = ffeexpr_convert
1528 (value, token, NULL, ffedata_basictype_,
1529 ffedata_kindtype_, 0,
1530 (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1531 ? ffedata_charexpected_ : FFETARGET_charactersizeNONE,
1532 FFEEXPR_contextDATA);
1533 else /* Use the cache. */
1534 value = ffedata_convert_
1535 (value, token, NULL, ffedata_basictype_,
1536 ffedata_kindtype_, 0,
1537 (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
1538 ? ffedata_charexpected_ : FFETARGET_charactersizeNONE);
1541 /* If we couldn't, bug out. */
1543 if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY))
1545 ffedata_reported_error_ = TRUE;
1546 return FALSE;
1549 /* Handle the case where initializes go to a parent's storage area. */
1551 if (ffedata_storage_ != NULL)
1553 ffetargetOffset offset;
1554 ffetargetOffset units_expected;
1555 ffebitCount actual;
1556 ffebldConstantArray array;
1557 ffebld accter;
1558 ffetargetCopyfunc fn;
1559 void *ptr1;
1560 void *ptr2;
1561 size_t size;
1562 ffeinfoBasictype ign_bt;
1563 ffeinfoKindtype ign_kt;
1564 ffetargetAlign units;
1566 /* Make sure we haven't fully accreted during an array init. */
1568 if (ffestorag_init (ffedata_storage_) != NULL)
1570 ffebad_start (FFEBAD_DATA_MULTIPLE);
1571 ffebad_here (0, ffelex_token_where_line (token),
1572 ffelex_token_where_column (token));
1573 ffebad_string (ffesymbol_text (ffedata_symbol_));
1574 ffebad_finish ();
1575 ffedata_reported_error_ = TRUE;
1576 return FALSE;
1579 /* Calculate offset. */
1581 offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1583 /* Is offset within range? If not, whine, but don't do anything else. */
1585 if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1587 ffebad_start (FFEBAD_DATA_RANGE);
1588 ffest_ffebad_here_current_stmt (0);
1589 ffebad_string (ffesymbol_text (ffedata_symbol_));
1590 ffebad_finish ();
1591 ffedata_reported_error_ = TRUE;
1592 return FALSE;
1595 /* Now calculate offset for aggregate area. */
1597 ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_,
1598 ffedata_kindtype_); /* Find out unit size of
1599 source datum. */
1600 assert (units % ffedata_storage_units_ == 0);
1601 units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
1602 offset *= units / ffedata_storage_units_;
1603 offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_))
1604 - ffestorag_offset (ffedata_storage_))
1605 / ffedata_storage_units_;
1607 assert (offset + units_expected - 1 <= ffedata_storage_size_);
1609 /* Does an accretion array exist? If not, create it. */
1611 if (value != NULL)
1613 if (ffestorag_accretion (ffedata_storage_) == NULL)
1615 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1616 if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
1618 char bignum[40];
1620 sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
1621 ffebad_start (FFEBAD_TOO_BIG_INIT);
1622 ffebad_here (0, ffelex_token_where_line (token),
1623 ffelex_token_where_column (token));
1624 ffebad_string (ffesymbol_text (ffedata_symbol_));
1625 ffebad_string (bignum);
1626 ffebad_finish ();
1628 #endif
1629 array = ffebld_constantarray_new
1630 (ffedata_storage_bt_, ffedata_storage_kt_,
1631 ffedata_storage_size_);
1632 accter = ffebld_new_accter (array,
1633 ffebit_new (ffe_pool_program_unit (),
1634 ffedata_storage_size_));
1635 ffebld_set_info (accter, ffeinfo_new
1636 (ffedata_storage_bt_,
1637 ffedata_storage_kt_,
1639 FFEINFO_kindENTITY,
1640 FFEINFO_whereCONSTANT,
1641 (ffedata_basictype_
1642 == FFEINFO_basictypeCHARACTER)
1643 ? 1 : FFETARGET_charactersizeNONE));
1644 ffestorag_set_accretion (ffedata_storage_, accter);
1645 ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_);
1647 else
1649 accter = ffestorag_accretion (ffedata_storage_);
1650 assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
1651 array = ffebld_accter (accter);
1654 /* Put value in accretion array at desired offset. */
1656 fn = ffetarget_aggregate_ptr_memcpy
1657 (ffedata_storage_bt_, ffedata_storage_kt_,
1658 ffedata_basictype_, ffedata_kindtype_);
1659 ffebld_constantarray_prepare
1660 (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
1661 ffedata_storage_kt_, offset,
1662 ffebld_constant_ptr_to_union (ffebld_conter (value)),
1663 ffedata_basictype_, ffedata_kindtype_);
1664 (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like
1665 operation. */
1666 ffebit_count (ffebld_accter_bits (accter),
1667 offset, FALSE, units_expected,
1668 &actual); /* How many FALSE? */
1669 if (units_expected != (ffetargetOffset) actual)
1671 ffebad_start (FFEBAD_DATA_MULTIPLE);
1672 ffebad_here (0, ffelex_token_where_line (token),
1673 ffelex_token_where_column (token));
1674 ffebad_string (ffesymbol_text (ffedata_symbol_));
1675 ffebad_finish ();
1677 ffestorag_set_accretes (ffedata_storage_,
1678 ffestorag_accretes (ffedata_storage_)
1679 - actual); /* Decrement # of values
1680 actually accreted. */
1681 ffebit_set (ffebld_accter_bits (accter), offset,
1682 1, units_expected);
1684 /* If done accreting for this storage area, establish as
1685 initialized. */
1687 if (ffestorag_accretes (ffedata_storage_) == 0)
1689 ffestorag_set_init (ffedata_storage_, accter);
1690 ffestorag_set_accretion (ffedata_storage_, NULL);
1691 ffebit_kill (ffebld_accter_bits
1692 (ffestorag_init (ffedata_storage_)));
1693 ffebld_set_op (ffestorag_init (ffedata_storage_),
1694 FFEBLD_opARRTER);
1695 ffebld_set_arrter
1696 (ffestorag_init (ffedata_storage_),
1697 ffebld_accter (ffestorag_init (ffedata_storage_)));
1698 ffebld_arrter_set_size (ffestorag_init (ffedata_storage_),
1699 ffedata_storage_size_);
1700 ffebld_arrter_set_pad (ffestorag_init (ffedata_storage_),
1702 ffecom_notify_init_storage (ffedata_storage_);
1706 /* If still accreting, adjust specs accordingly and return. */
1708 if (++ffedata_number_ < ffedata_expected_)
1710 ++ffedata_offset_;
1711 return TRUE;
1714 return ffedata_advance_ ();
1717 /* Figure out where the value goes -- in an accretion array or directly
1718 into the final initial-value slot for the symbol. */
1720 if ((ffedata_number_ != 0)
1721 || (ffedata_arraysize_ > 1)
1722 || (ffedata_charnumber_ != 0)
1723 || (ffedata_size_ > ffedata_charexpected_))
1724 { /* Accrete this value. */
1725 ffetargetOffset offset;
1726 ffebitCount actual;
1727 ffebldConstantArray array;
1728 ffebld accter = NULL;
1730 /* Calculate offset. */
1732 offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_;
1734 /* Is offset within range? If not, whine, but don't do anything else. */
1736 if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_)
1738 ffebad_start (FFEBAD_DATA_RANGE);
1739 ffest_ffebad_here_current_stmt (0);
1740 ffebad_string (ffesymbol_text (ffedata_symbol_));
1741 ffebad_finish ();
1742 ffedata_reported_error_ = TRUE;
1743 return FALSE;
1746 /* Does an accretion array exist? If not, create it. */
1748 if (value != NULL)
1750 if (ffesymbol_accretion (ffedata_symbol_) == NULL)
1752 #if FFEDATA_sizeTOO_BIG_INIT_ != 0
1753 if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ )
1755 char bignum[40];
1757 sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_);
1758 ffebad_start (FFEBAD_TOO_BIG_INIT);
1759 ffebad_here (0, ffelex_token_where_line (token),
1760 ffelex_token_where_column (token));
1761 ffebad_string (ffesymbol_text (ffedata_symbol_));
1762 ffebad_string (bignum);
1763 ffebad_finish ();
1765 #endif
1766 array = ffebld_constantarray_new
1767 (ffedata_basictype_, ffedata_kindtype_,
1768 ffedata_symbolsize_);
1769 accter = ffebld_new_accter (array,
1770 ffebit_new (ffe_pool_program_unit (),
1771 ffedata_symbolsize_));
1772 ffebld_set_info (accter, ffeinfo_new
1773 (ffedata_basictype_,
1774 ffedata_kindtype_,
1776 FFEINFO_kindENTITY,
1777 FFEINFO_whereCONSTANT,
1778 (ffedata_basictype_
1779 == FFEINFO_basictypeCHARACTER)
1780 ? 1 : FFETARGET_charactersizeNONE));
1781 ffesymbol_set_accretion (ffedata_symbol_, accter);
1782 ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_);
1784 else
1786 accter = ffesymbol_accretion (ffedata_symbol_);
1787 assert (ffedata_symbolsize_
1788 == (ffetargetOffset) ffebld_accter_size (accter));
1789 array = ffebld_accter (accter);
1792 /* Put value in accretion array at desired offset. */
1794 ffebld_constantarray_put
1795 (array, ffedata_basictype_, ffedata_kindtype_,
1796 offset, ffebld_constant_union (ffebld_conter (value)));
1797 ffebit_count (ffebld_accter_bits (accter), offset, FALSE,
1798 ffedata_charexpected_,
1799 &actual); /* How many FALSE? */
1800 if (actual != (unsigned long int) ffedata_charexpected_)
1802 ffebad_start (FFEBAD_DATA_MULTIPLE);
1803 ffebad_here (0, ffelex_token_where_line (token),
1804 ffelex_token_where_column (token));
1805 ffebad_string (ffesymbol_text (ffedata_symbol_));
1806 ffebad_finish ();
1808 ffesymbol_set_accretes (ffedata_symbol_,
1809 ffesymbol_accretes (ffedata_symbol_)
1810 - actual); /* Decrement # of values
1811 actually accreted. */
1812 ffebit_set (ffebld_accter_bits (accter), offset,
1813 1, ffedata_charexpected_);
1814 ffesymbol_signal_unreported (ffedata_symbol_);
1817 /* If still accreting, adjust specs accordingly and return. */
1819 if (++ffedata_number_ < ffedata_expected_)
1821 ++ffedata_offset_;
1822 return TRUE;
1825 /* Else, if done accreting for this symbol, establish as initialized. */
1827 if ((value != NULL)
1828 && (ffesymbol_accretes (ffedata_symbol_) == 0))
1830 ffesymbol_set_init (ffedata_symbol_, accter);
1831 ffesymbol_set_accretion (ffedata_symbol_, NULL);
1832 ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_)));
1833 ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER);
1834 ffebld_set_arrter (ffesymbol_init (ffedata_symbol_),
1835 ffebld_accter (ffesymbol_init (ffedata_symbol_)));
1836 ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_),
1837 ffedata_symbolsize_);
1838 ffebld_arrter_set_pad (ffestorag_init (ffedata_symbol_), 0);
1839 ffecom_notify_init_symbol (ffedata_symbol_);
1842 else if (value != NULL)
1844 /* Simple, direct, one-shot assignment. */
1845 ffesymbol_set_init (ffedata_symbol_, value);
1846 ffecom_notify_init_symbol (ffedata_symbol_);
1849 /* Call on advance function to get next target in list. */
1851 return ffedata_advance_ ();